diff --git a/.github/workflows/clojure.yml b/.github/workflows/clojure.yml index 502e35cd8..722bdeeaf 100644 --- a/.github/workflows/clojure.yml +++ b/.github/workflows/clojure.yml @@ -9,13 +9,15 @@ on: jobs: build-clj: + timeout-minutes: 5 + strategy: matrix: # Supported Java versions: LTS releases and latest jdk: [8, 11, 17, 21] clojure: [11] - name: Clojure ${{ matrix.clojure }} (Java ${{ matrix.jdk }}) + name: Java ${{ matrix.jdk }} runs-on: ubuntu-latest @@ -26,23 +28,34 @@ jobs: with: distribution: zulu java-version: ${{ matrix.jdk }} - - uses: actions/cache@v4 + - uses: actions/cache/restore@v4 + id: cache-restore with: path: | ~/.m2/repository ~/.gitlibs - key: ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-${{ matrix.clojure }}-${{ matrix.jdk }} + key: ${{ runner.os }}-build-clj-${{ hashFiles('**/deps.edn') }}-${{ matrix.jdk }} restore-keys: | - ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-${{ matrix.clojure }}- - ${{ runner.os }}-test-deps- + ${{ runner.os }}-build-clj-${{ hashFiles('**/deps.edn') }}- + ${{ runner.os }}-build-clj- - name: Setup Clojure uses: DeLaGuardo/setup-clojure@master with: cli: latest - name: Run tests - run: CLOJURE_ALIAS=clojure-${{ matrix.clojure }} bin/kaocha + run: bin/kaocha + - name: Always Save Cache + id: cache-save + if: always() && steps.cache-restore.outputs.cache-hit != 'true' + uses: actions/cache/save@v4 + with: + key: ${{ steps.cache-restore.outputs.cache-primary-key }} + path: | + ~/.m2/repository + ~/.gitlibs build-cljs: + timeout-minutes: 5 name: ClojureScript strategy: matrix: @@ -56,14 +69,15 @@ jobs: with: distribution: zulu java-version: 11 - - uses: actions/cache@v4 + - uses: actions/cache/restore@v4 + id: cache-restore with: path: | ~/.m2/repository ~/.gitlibs - key: ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }} + key: ${{ runner.os }}-build-cljs-${{ hashFiles('**/deps.edn') }} restore-keys: | - ${{ runner.os }}-test-deps- + ${{ runner.os }}-build-cljs- - name: Setup Clojure uses: DeLaGuardo/setup-clojure@master with: @@ -72,12 +86,23 @@ jobs: uses: actions/setup-node@v4.0.3 with: node-version: 16 + cache: 'npm' - name: Install dependencies run: npm ci - name: Run tests on ${{ matrix.mode }} run: bin/node ${{ matrix.mode }} + - name: Always Save Cache + id: cache-save + if: always() && steps.cache-restore.outputs.cache-hit != 'true' + uses: actions/cache/save@v4 + with: + key: ${{ steps.cache-restore.outputs.cache-primary-key }} + path: | + ~/.m2/repository + ~/.gitlibs build-bb: + timeout-minutes: 5 name: Babashka runs-on: ubuntu-latest @@ -88,16 +113,17 @@ jobs: with: distribution: zulu java-version: 11 - - uses: actions/cache@v4 + - uses: actions/cache/restore@v4 + id: cache-restore with: path: | ~/.m2/repository ~/.deps.clj ~/.gitlibs - key: ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-${{ hashFiles('**/bb.edn') }} + key: ${{ runner.os }}-build-bb-${{ hashFiles('**/deps.edn') }}-${{ hashFiles('**/bb.edn') }} restore-keys: | - ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}- - ${{ runner.os }}-test-deps- + ${{ runner.os }}-build-bb-${{ hashFiles('**/deps.edn') }}- + ${{ runner.os }}-build-bb- - name: Setup Clojure uses: DeLaGuardo/setup-clojure@master with: @@ -105,3 +131,13 @@ jobs: bb: latest - name: Run tests run: bb test-bb + - name: Always Save Cache + id: cache-save + if: always() && steps.cache-restore.outputs.cache-hit != 'true' + uses: actions/cache/save@v4 + with: + key: ${{ steps.cache-restore.outputs.cache-primary-key }} + path: | + ~/.m2/repository + ~/.deps.clj + ~/.gitlibs diff --git a/bin/kaocha b/bin/kaocha index 9c1c4cea1..1ac0574f9 100755 --- a/bin/kaocha +++ b/bin/kaocha @@ -1,3 +1,3 @@ #!/usr/bin/env bash # Should work if the env var is empty -clojure -A:$CLOJURE_ALIAS -M:test -m kaocha.runner "$@" +clojure -M:test -m kaocha.runner "$@" diff --git a/deps.edn b/deps.edn index c5f5a91b1..c6325e3cd 100644 --- a/deps.edn +++ b/deps.edn @@ -5,8 +5,12 @@ org.clojure/test.check {:mvn/version "1.1.1"} ;; pretty errors, optional deps fipp/fipp {:mvn/version "0.6.26"} - mvxcvi/arrangement {:mvn/version "2.1.0"}} - :aliases {:test {:extra-paths ["test"] + mvxcvi/arrangement {:mvn/version "2.1.0"} + ;; for constrained schema generators + org.clojure/math.combinatorics {:mvn/version "0.1.6"}} + :aliases {:test {:extra-paths ["test" + ;;remove me + "dev"] :extra-deps {com.gfredericks/test.chuck {:mvn/version "0.2.14"} lambdaisland/kaocha {:mvn/version "1.91.1392"} lambdaisland/kaocha-cljs {:mvn/version "1.5.154"} diff --git a/dev/user.clj b/dev/user.clj index e4933c9b1..dc6ff9ab6 100644 --- a/dev/user.clj +++ b/dev/user.clj @@ -3,6 +3,7 @@ [clojure.pprint :refer [pprint]] [clojure.test :as test] [clojure.tools.namespace.repl :as r] + malli.constraint [clojure.walk :refer [macroexpand-all]])) (r/set-refresh-dirs "src/malli" "dev" "test/malli") diff --git a/docs/constraints.md b/docs/constraints.md new file mode 100644 index 000000000..cb0630942 --- /dev/null +++ b/docs/constraints.md @@ -0,0 +1,67 @@ +# Constraints + +Typical nested schemas like `[:vector :string]` have corresponding +levels in the values they describe: the `:vector` for the outer +value and `:string for the first level of nesting. + +The exceptions are composite schemas like `[:and :int [:< 42]]` which +describe the same value. This is problematic for generation: one +schema must generate values and the other filter them, yielding brittle +generators. Validators may also perform redundant checks, such has both +`:int` and `[:< 42]` needing to check the class of the validated value. + +Constraints are intended to address this situation. A parent schema +has other "constraint" schemas attached to them which may collaborate +with the each other to yield reliable generators and lean validators. + +For example, `[:int {:max 41}]` is actually two schemas (when constraints are enabled): +- the parent schema `:int` +- a constraint `[:max 41]` + +## Reading this document + +This document assumes this has been evaluated in the current namespace: + +```clojure +(require '[malli.core :as m] + '[malli.constraint.protocols :as mcp] + '[malli.constraint :as mc]) + +(defn constraint-options [] + (-> {:registry (m/default-schemas)} + mc/with-base-constraints)) +``` + +## Activating Constraints + +Constraints are an opt-in Malli feature. + +To activate constraints locally, use `mc/with-base-constraints` to upgrade +your options map. You can see an example in `constraint-options` above. + +To activate the base constraints globally, call `(malli.constraint/activate-base-constraints!)`. + +Constraints are themselves Schemas that also live in the registry. + +Behind the scenes, an atom `malli.constraint.extension/constraint-extensions` +is used to configure constraints. The entire atom is ignored if `::m/constraint-options` +WIPWIPWIP + +TODO rename constraint-options? or the atom? default-constraint-options? + + +## Constraint vs Schema + +A constraint implements the same protocols as a Schema, and additionally +`malli.constraint.protocols/Constraint`. + +Schemas that support schemas also implement +`malli.constraint.protocols/ConstrainedSchema`. + +Validators on schemas ensure they check preconditions + +## Constraint Extensions Registry + +Constraints schema represents + +Constraint extensions are described as a schema in `malli.dev.constraint/ConstraintExtension`. diff --git a/src/malli/constraint.cljc b/src/malli/constraint.cljc new file mode 100644 index 000000000..9156d88a3 --- /dev/null +++ b/src/malli/constraint.cljc @@ -0,0 +1,33 @@ +(ns malli.constraint) + +#?(:cljs (goog-define mode "on") + :clj (def mode (or (System/getProperty "malli.constraint/mode") "on"))) + +(defprotocol Constraint + (-constraint? [this]) + (-constraint-form [this])) + +(defprotocol ConstrainedSchema + (-constrained-schema? [this]) + (-get-constraint [this]) + (-set-constraint [this c])) + +(extend-type #?(:clj Object, :cljs default) + Constraint + (-constraint? [_] false) + (-intersect [_ _ _]) + + ConstrainedSchema + (-constrained-schema? [this] false) + (-get-constraint [this]) + (-set-constraint [this c])) + +(extend-type nil + Constraint + (-constraint? [_] false) + (-constraint-form [_]) + + ConstrainedSchema + (-constrained-schema? [this] false) + (-get-constraint [this]) + (-set-constraint [this c])) diff --git a/src/malli/constraint/extension.cljc b/src/malli/constraint/extension.cljc new file mode 100644 index 000000000..53ccad425 --- /dev/null +++ b/src/malli/constraint/extension.cljc @@ -0,0 +1,22 @@ +(ns malli.constraint.extension) + +#_ +[:atom [:map + [:registry [:map-of Type IntoSchema]] + [:extensions [:map-of Type [:map + [:-walk + {:optional true} + [:=> [:maybe Schema] Schema Walker Path Constraint Options]]]]]]] +(defonce ^:private constraint-extensions (atom {})) + +(defn get-constraint-extension [type] + (get-in @constraint-extensions [:extensions type])) + +(defn get-constraint [type] + (get-in @constraint-extensions [:registry type])) + +(defn register-constraints [reg] + (swap! constraint-extensions update :registry #(merge % reg))) + +(defn register-constraint-extensions! [extensions] + (swap! constraint-extensions update :extensions #(merge-with into % extensions))) diff --git a/src/malli/constraint/solver.cljc b/src/malli/constraint/solver.cljc new file mode 100644 index 000000000..18ae68b43 --- /dev/null +++ b/src/malli/constraint/solver.cljc @@ -0,0 +1,121 @@ +(ns malli.constraint.solver + (:require [clojure.math.combinatorics :as comb] + [clojure.set :as set] + [malli.core :as m] + [malli.constraint :as mc])) + +(defn -number-solutions [min-int max-int mink maxk] + (if (and min-int max-int) + (if (<= min-int max-int) + [{mink min-int + maxk max-int}] + []) + (if min-int + [{mink min-int}] + (when max-int + [{maxk max-int}])))) + +(defn -number-constraints [all-sols mink maxk] + (let [the-max (some->> (seq (keep maxk all-sols)) (apply min)) + the-min (some->> (seq (keep mink all-sols)) (apply max))] + (-number-solutions the-min the-max mink maxk))) + +(defn -conj-number-constraints [all-sols] + (if-some [sols (when (seq all-sols) + (not-empty (into [] (keep (fn [[mink maxk]] + (-number-constraints all-sols mink maxk))) + [[:min-count :max-count] + [:min-range :max-range]])))] + (lazy-seq + (->> (apply comb/cartesian-product sols) + (map #(apply merge %)))) + [{}])) + +(defn -conj-solutions [& sols] + (letfn [(rec [cart-sols] + (lazy-seq + (when-some [[[sol1 & sols :as all-sols]] (seq cart-sols)] + (when-some [unsupported-keys (not-empty + (disj (into #{} (mapcat keys) all-sols) + :max-count :min-count + :max-range :min-range))] + (m/-fail! ::unsupported-conj-solution {:unsupported-keys unsupported-keys})) + (let [number-solutions (-conj-number-constraints all-sols) + combined-sols (comb/cartesian-product + number-solutions)] + (if (empty? combined-sols) + [] + (concat (map #(apply merge %) combined-sols) + (rec (rest cart-sols))))))))] + (distinct (rec (apply comb/cartesian-product (distinct sols)))))) + +;; math.combinatorics +(defn- unchunk + "Given a sequence that may have chunks, return a sequence that is 1-at-a-time +lazy with no chunks. Chunks are good for efficiency when the data items are +small, but when being processed via map, for example, a reference is kept to +every function result in the chunk until the entire chunk has been processed, +which increases the amount of memory in use that cannot be garbage +collected." + [s] + (lazy-seq + (when (seq s) + (cons (first s) (unchunk (rest s)))))) + +;; math.combinatorics +(defn- join + "Lazily concatenates a collection of collections into a flat sequence, + because Clojure's `apply concat` is insufficiently lazy." + [colls] + (lazy-seq + (when-let [s (seq colls)] + (concat (first s) (join (rest s)))))) + +;; math.combinatorics +(defn- mapjoin + "Uses join to achieve lazier version of mapcat (on one collection)" + [f coll] + (join (map f coll))) + +(defn- -min-max [min max gen-min gen-max mink maxk] + (cond + ;; not sure about these cases, why is a smaller :gen/min contradictory? + (and min gen-min (< gen-min min)) [] + (and max gen-max (> gen-max max)) [] + :else (let [min (or gen-min min) + max (or gen-max max)] + (if (and min max (> min max)) + [] + [(cond-> {} + min (assoc mink min) + max (assoc maxk max))])))) + +(defmulti -constraint-solutions* (fn [constraint constraint-opts options] (m/type constraint))) + +(defn -constraint-solutions [constraint constraint-opts options] + {:post [(every? map? %)]} + (assert (mc/-constraint? constraint) (pr-str (#?(:cljs type :default class) constraint))) + (lazy-seq + (-constraint-solutions* constraint constraint-opts options))) + +(defmethod -constraint-solutions* ::m/true-constraint [constraint constraint-opts options] [{}]) +(defmethod -constraint-solutions* ::m/false-constraint [constraint constraint-opts options] []) + +(defmethod -constraint-solutions* :and + [constraint constraint-opts options] + (apply -conj-solutions (map #(-constraint-solutions % constraint-opts options) (m/children constraint)))) + +(defmethod -constraint-solutions* ::m/count-constraint + [constraint constraint-opts {::keys [mode] :as options}] + (let [{:keys [min max]} (m/properties constraint) + {gen-min :gen/min gen-max :gen/max} (when (= :gen mode) (m/properties constraint))] + (-min-max min max gen-min gen-max :min-count :max-count))) + +(defmethod -constraint-solutions* ::m/range-constraint + [constraint constraint-opts {::keys [mode] :as options}] + (let [{:keys [min max]} (m/properties constraint) + {gen-min :gen/min gen-max :gen/max} (when (= :gen mode) (m/properties constraint))] + (-min-max min max gen-min gen-max :min-range :max-range))) + +(defmethod -constraint-solutions* :default [constraint constraint-opts options] + (m/-fail! ::unknown-constraint {:constraint constraint})) diff --git a/src/malli/core.cljc b/src/malli/core.cljc index d713bb694..f0a5718c6 100644 --- a/src/malli/core.cljc +++ b/src/malli/core.cljc @@ -3,6 +3,8 @@ #?(:cljs (:require-macros malli.core)) (:require #?(:clj [clojure.walk :as walk]) [clojure.core :as c] + [malli.constraint :as mc] + [malli.constraint.extension :as mce] [malli.impl.regex :as re] [malli.impl.util :as miu] [malli.registry :as mr] @@ -14,7 +16,8 @@ (declare schema schema? into-schema into-schema? type eval default-registry -simple-schema -val-schema -ref-schema -schema-schema -registry - parser unparser ast from-ast -instrument ^:private -safely-countable?) + parser unparser ast from-ast -instrument ^:private -safely-countable? + -set-constraint -constraint-context -constraint-from-properties -constraint-form) ;; ;; protocols and records @@ -660,12 +663,15 @@ (and max f) (fn [x] (<= (f x) max)) max (fn [x] (<= x max))))) -(defn- -safe-count [x] +;;TODO move to miu +(defn -safe-count [x] (if (-safely-countable? x) (count x) (reduce (fn [cnt _] (inc cnt)) 0 x))) -(defn -validate-limits [min max] (or ((-min-max-pred -safe-count) {:min min :max max}) (constantly true))) +(defn -validate-limits + ([min-max] (or ((-min-max-pred -safe-count) min-max) any?)) + ([min max] (-validate-limits {:min min :max max}))) (defn -needed-bounded-checks [min max options] (c/max (or (some-> max inc) 0) @@ -673,7 +679,7 @@ (::coll-check-limit options 101))) (defn -validate-bounded-limits [needed min max] - (or ((-min-max-pred #(bounded-count needed %)) {:min min :max max}) (constantly true))) + (or ((-min-max-pred #(bounded-count needed %)) {:min min :max max}) any?)) (defn -qualified-keyword-pred [properties] (when-let [ns-name (some-> properties :namespace name)] @@ -683,9 +689,13 @@ ;; Schemas ;; +(defn -simple-parser [this] + (let [validator (-validator this)] + (fn [x] (if (validator x) x ::invalid)))) + (defn -simple-schema [props] - (let [{:keys [type type-properties pred property-pred min max from-ast to-ast compile] - :or {min 0, max 0, from-ast -from-value-ast, to-ast -to-type-ast}} props] + (let [{:keys [type type-properties pred property-pred min max from-ast to-ast compile constrained] + constraint? :constraint :or {min 0, max 0, from-ast -from-value-ast, to-ast -to-type-ast}} props] (if (fn? props) (do (-deprecated! "-simple-schema doesn't take fn-props, use :compile property instead") @@ -703,27 +713,54 @@ (if compile (-into-schema (-simple-schema (merge (dissoc props :compile) (compile properties children options))) properties children options) (let [form (delay (-simple-form parent properties children identity options)) + constraint-context (delay (when constrained (-constraint-context type options))) + constraint (delay (when @constraint-context + (-constraint-from-properties properties (assoc options ::constraint-context @constraint-context)))) cache (-create-cache options)] (-check-children! type properties children min max) ^{:type ::schema} (reify + mc/ConstrainedSchema + (-constrained-schema? [this] (boolean @constraint-context)) + (-get-constraint [this] @constraint) + (-set-constraint [this c] (-set-constraint this c @constraint-context)) + mc/Constraint + (-constraint? [_] (boolean constraint?)) + (-simplify [_]) + (-intersect [_ _ _]) AST (-to-ast [this _] (to-ast this)) Schema (-validator [_] - (if-let [pvalidator (when property-pred (property-pred properties))] - (fn [x] (and (pred x) (pvalidator x))) pred)) + (let [cvalidator (some-> @constraint -validator) + pvalidator (when property-pred + (when-not cvalidator + (property-pred properties)))] + (-> [pred] + (cond-> + pvalidator (conj pvalidator) + cvalidator (conj cvalidator)) + miu/-every-pred))) (-explainer [this path] - (let [validator (-validator this)] - (fn explain [x in acc] - (if-not (validator x) (conj acc (miu/-error path in this x)) acc)))) - (-parser [this] - (let [validator (-validator this)] - (fn [x] (if (validator x) x ::invalid)))) + (let [cexplainer (some-> @constraint (-explainer (conj path :malli.constraint/constraint))) + pvalidator (when-not cexplainer (when property-pred (property-pred properties))) + validator (-validator this)] + (fn [x in acc] + (if-not (pred x) + (conj acc (miu/-error path in this x)) + (if cexplainer + (cexplainer x in acc) + (cond-> acc + (and pvalidator (not (pvalidator x))) + (conj (miu/-error path in this x)))))))) + (-parser [this] (-simple-parser this)) (-unparser [this] (-parser this)) (-transformer [this transformer method options] (-intercepting (-value-transformer transformer this method options))) - (-walk [this walker path options] (-walk-leaf this walker path options)) + (-walk [this walker path options] + (if-some [-walk (:-walk @constraint-context)] + (-walk this walker path options) + (-walk-leaf this walker path options))) (-properties [_] properties) (-options [_] options) (-children [_] children) @@ -737,12 +774,13 @@ (-set [this key _] (-fail! ::non-associative-schema {:schema this, :key key})))))))))) (defn -nil-schema [] (-simple-schema {:type :nil, :pred nil?})) -(defn -any-schema [] (-simple-schema {:type :any, :pred any?})) +(defn -any-schema [] (-simple-schema {:type :any, :pred any? :constraint true})) +(defn -never-schema [] (-simple-schema {:type :never, :pred (fn [_] false) :constraint true})) (defn -some-schema [] (-simple-schema {:type :some, :pred some?})) -(defn -string-schema [] (-simple-schema {:type :string, :pred string?, :property-pred (-min-max-pred count)})) -(defn -int-schema [] (-simple-schema {:type :int, :pred int?, :property-pred (-min-max-pred nil)})) -(defn -float-schema [] (-simple-schema {:type :float, :pred float?, :property-pred (-min-max-pred nil)})) -(defn -double-schema [] (-simple-schema {:type :double, :pred double?, :property-pred (-min-max-pred nil)})) +(defn -string-schema [] (-simple-schema {:type :string, :pred string?, :property-pred (-min-max-pred count) :constrained true})) +(defn -int-schema [] (-simple-schema {:type :int, :pred int?, :property-pred (-min-max-pred nil) :constrained true})) +(defn -float-schema [] (-simple-schema {:type :float, :pred float?, :property-pred (-min-max-pred nil) :constrained true})) +(defn -double-schema [] (-simple-schema {:type :double, :pred double?, :property-pred (-min-max-pred nil) :constrained true})) (defn -boolean-schema [] (-simple-schema {:type :boolean, :pred boolean?})) (defn -keyword-schema [] (-simple-schema {:type :keyword, :pred keyword?})) (defn -symbol-schema [] (-simple-schema {:type :symbol, :pred symbol?})) @@ -766,6 +804,9 @@ #(reduce (fn [x parser] (miu/-map-invalid reduced (parser x))) % parsers)))] ^{:type ::schema} (reify + mc/Constraint + (-constraint? [_] true) + (-constraint-form [this] (-constraint-form this options)) Schema (-validator [_] (let [validators (-vmap -validator children)] (miu/-every-pred validators))) @@ -919,9 +960,7 @@ (let [validator (-validator this)] (fn explain [x in acc] (if-not (validator x) (conj acc (miu/-error (conj path 0) in this x)) acc)))) - (-parser [this] - (let [validator (-validator this)] - (fn [x] (if (validator x) x ::invalid)))) + (-parser [this] (-simple-parser this)) (-unparser [this] (-parser this)) (-transformer [this transformer method options] (-parent-children-transformer this children transformer method options)) @@ -1250,7 +1289,7 @@ (-into-schema [parent {:keys [min max] :as properties} children options] (if-let [compile (:compile props)] (-into-schema (-collection-schema (merge (dissoc props :compile) (compile properties children options))) properties children options) - (let [{:keys [type parse unparse], fpred :pred, fempty :empty, fin :in :or {fin (fn [i _] i)}} props] + (let [{:keys [type parse unparse constrained], fpred :pred, fempty :empty, fin :in :or {fin (fn [i _] i)}} props] (-check-children! type properties children 1 1) (let [[schema :as children] (-vmap #(schema % options) children) form (delay (-simple-form parent properties children -form options)) @@ -1262,6 +1301,11 @@ validate-limits (if bounded (-validate-bounded-limits (c/min bounded (or max bounded)) min max) (-validate-limits min max)) + constraint-context (delay (when constrained + (when-not bounded ;;TODO bounded-limits collections + (-constraint-context type options)))) + constraint (delay (when @constraint-context + (-constraint-from-properties properties (assoc options ::constraint-context @constraint-context)))) ->parser (fn [f g] (let [child-parser (f schema)] (fn [x] (cond @@ -1287,23 +1331,32 @@ :else x')))))))] ^{:type ::schema} (reify + mc/ConstrainedSchema + (-constrained-schema? [this] (boolean @constraint-context)) + (-get-constraint [this] @constraint) + (-set-constraint [this c] (-set-constraint this c @constraint-context)) AST (-to-ast [this _] (-to-child-ast this)) Schema (-validator [_] - (let [validator (-validator schema)] + (let [cvalidator (or (some-> @constraint -validator) + validate-limits) + validator (-validator schema)] (fn [x] (and (fpred x) - (validate-limits x) + (cvalidator x) (reduce (fn [acc v] (if (validator v) acc (reduced false))) true (cond->> x (and bounded (not (-safely-countable? x))) (eduction (take bounded)))))))) (-explainer [this path] - (let [explainer (-explainer schema (conj path 0))] + (let [cvalidator (some-> @constraint -validator) + cexplainer (some-> @constraint (-explainer (conj path :malli.constraint/constraint))) + explainer (-explainer schema (conj path 0))] (fn [x in acc] (cond (not (fpred x)) (conj acc (miu/-error path in this x ::invalid-type)) - (not (validate-limits x)) (conj acc (miu/-error path in this x ::limits)) + (and (not cvalidator) (not (validate-limits x))) (conj acc (miu/-error path in this x ::limits)) + (and cvalidator (not (cvalidator x))) (cexplainer x in acc) :else (let [size (when (and bounded (not (-safely-countable? x))) bounded)] (loop [acc acc, i 0, [x & xs :as ne] (seq x)] @@ -1324,6 +1377,7 @@ ->child (-guard collection? ->child)] (-intercepting this-transformer ->child))) (-walk [this walker path options] + ;;TODO constraint walking (when (-accept walker this path options) (-outer walker this path [(-inner walker schema (conj path ::in) options)] options))) (-properties [_] properties) @@ -1488,9 +1542,7 @@ (conj acc (miu/-error path in this x (:type (ex-data e)))))))) (-transformer [this transformer method options] (-intercepting (-value-transformer transformer this method options))) - (-parser [this] - (let [valid? (-validator this)] - (fn [x] (if (valid? x) x ::invalid)))) + (-parser [this] (-simple-parser this)) (-unparser [this] (-parser this)) (-walk [this walker path options] (-walk-leaf this walker path options)) (-properties [_] properties) @@ -1533,9 +1585,7 @@ acc) (catch #?(:clj Exception, :cljs js/Error) e (conj acc (miu/-error path in this x (:type (ex-data e)))))))) - (-parser [this] - (let [validator (-validator this)] - (fn [x] (if (validator x) x ::invalid)))) + (-parser [this] (-simple-parser this)) (-unparser [this] (-parser this)) (-transformer [this transformer method options] (-intercepting (-value-transformer transformer this method options))) @@ -1880,9 +1930,7 @@ (let [validator (-validator this)] (fn explain [x in acc] (if-not (validator x) (conj acc (miu/-error path in this x)) acc))))) - (-parser [this] - (let [validator (-validator this)] - (fn [x] (if (validator x) x ::invalid)))) + (-parser [this] (-simple-parser this)) (-unparser [this] (-parser this)) (-transformer [_ _ _ _]) (-walk [this walker path options] (-walk-indexed this walker path options)) @@ -1962,9 +2010,7 @@ (let [validator (-validator this)] (fn explain [x in acc] (if-not (validator x) (conj acc (miu/-error path in this x)) acc))))) - (-parser [this] - (let [validator (-validator this)] - (fn [x] (if (validator x) x ::invalid)))) + (-parser [this] (-simple-parser this)) (-unparser [this] (-parser this)) (-transformer [_ _ _ _]) (-walk [this walker path options] (-walk-indexed this walker path options)) @@ -2619,6 +2665,7 @@ (defn comparator-schemas [] (->> {:> >, :>= >=, :< <, :<= <=, := =, :not= not=} (-vmap (fn [[k v]] [k (-simple-schema {:type k :from-ast -from-value-ast :to-ast -to-value-ast :min 1 :max 1 + :constraint true :compile (fn [_ [child] _] {:pred (-safe-pred #(v % child))})})])) (into {}) (reduce-kv assoc nil))) @@ -2702,11 +2749,11 @@ :not (-not-schema) :map (-map-schema) :map-of (-map-of-schema) - :vector (-collection-schema {:type :vector, :pred vector?, :empty []}) - :sequential (-collection-schema {:type :sequential, :pred sequential?}) - :seqable (-collection-schema {:type :seqable, :pred seqable?}) + :vector (-collection-schema {:type :vector, :pred vector?, :empty [] :constrained true}) + :sequential (-collection-schema {:type :sequential, :pred sequential? :constrained true}) + :seqable (-collection-schema {:type :seqable, :pred seqable? :constrained true}) :every (-collection-schema {:type :every, :pred seqable?, :bounded true}) - :set (-collection-schema {:type :set, :pred set?, :empty #{}, :in (fn [_ x] x)}) + :set (-collection-schema {:type :set, :pred set?, :empty #{}, :in (fn [_ x] x) :constrained true}) :enum (-enum-schema) :maybe (-maybe-schema) :tuple (-tuple-schema) @@ -2814,3 +2861,292 @@ s (-> props :schema (schema options))] (or (-instrument-f s props f options) (-fail! ::instrument-requires-function-schema {:schema s}))))) + +;; +;; constraints +;; + +(defn -set-constraint + ([schema constraint] (-set-constraint schema constraint (mce/get-constraint-extension (-type schema)))) + ([schema constraint {:keys [parse-properties unparse-properties] :as constraint-opts}] + (-update-properties schema + (fn [properties] + (let [f (or (get unparse-properties (-type constraint)) + (-fail! ::unsupported-constraint {:schema schema :constraint constraint}))] + (f constraint (apply dissoc properties (keys parse-properties)) {::constraint-options constraint-opts})))))) + +(defn -constraint-context [type options] + (some-> (or (get (::constraint-options options) type) + (mce/get-constraint-extension type)) + (assoc :type type))) + +(defn -constraint-form [constraint {{:keys [constraint-form]} ::constraint-context :as options}] + (let [t (type constraint) + f (or (get constraint-form t) + (-fail! ::no-constraint-form {:type t}))] + (f constraint options))) + +(defn constraint + ([?constraint] (constraint ?constraint nil)) + ([?constraint options] + (cond + (mc/-constraint? ?constraint) ?constraint + ;; reserving for now for special per-schema sugar, e.g., "contains" constraints for :map. + (keyword? ?constraint) (-fail! ::constraints-must-be-vectors + {:outer-schema (-> options ::constraint-context :type) + :constraint ?constraint}) + (vector? ?constraint) (let [v #?(:clj ^IPersistentVector ?constraint, :cljs ?constraint) + n #?(:bb (count v) :clj (.count v), :cljs (count v)) + op #?(:clj (.nth v 0), :cljs (nth v 0)) + ?p (when (> n 1) #?(:clj (.nth v 1), :cljs (nth v 1))) + prs (or (-> options ::constraint-context :parse-constraint) + (-fail! ::missing-parse-constraint-options {:constraint ?constraint})) + f (or (prs op) + (-fail! ::missing-constraint-parser {:op op + :constraint ?constraint})) + ?constraint (if (or (nil? ?p) (map? ?p)) + (f {:properties ?p :children (when (< 2 n) (subvec ?constraint 2 n))} options) + (f {:children (when (< 1 n) (subvec ?constraint 1 n))} options))] + (cond + (mc/-constraint? ?constraint) ?constraint + (vector? ?constraint) (let [v #?(:clj ^IPersistentVector ?constraint, :cljs ?constraint) + t #?(:clj (.nth v 0), :cljs (nth v 0)) + t (if (into-schema? t) + t + (or (mce/get-constraint t) + (-fail! ::unknown-constraint {:type t}))) + n #?(:bb (count v) :clj (.count v), :cljs (count v)) + ?p (when (> n 1) #?(:clj (.nth v 1), :cljs (nth v 1)))] + (if (or (nil? ?p) (map? ?p)) + (into-schema t ?p (when (< 2 n) (subvec ?constraint 2 n)) options) + (into-schema t nil (when (< 1 n) (subvec ?constraint 1 n)) options))) + :else (-fail! ::unknown-constraint {:constraint ?constraint}))) + :else (-fail! ::invalid-constraint {:outer-schema (-> options ::constraint-context :type) + :constraint ?constraint})))) + +(defn -constraint-from-properties [properties options] + (let [{:keys [parse-properties]} (::constraint-context options) + cs (into [] (keep #(when-some [[_ v] (find properties %)] + (constraint ((get parse-properties %) v options) options))) + (-> parse-properties keys sort))] + (case (count cs) + 0 (constraint [:true] options) + 1 (first cs) + (constraint (into [:and] cs) options)))) + +(defn default-constraint-extensions [] + {:parse-constraint {:and (fn [{:keys [properties children]} opts] + (into [:and nil] children)) + :true (fn [{:keys [properties children]} opts] + (-check-children! :true properties children 0 0) + [::true-constraint]) + :false (fn [{:keys [properties children]} opts] + (-check-children! :false properties children 0 0) + [::false-constraint])} + :constraint-form {:and (fn [c options] (into [:and] (map -constraint-form) (-children c))) + ::true-constraint (fn [_ _] [:true]) + ::false-constraint (fn [_ _] [:false])} + :parse-properties {:and (fn [v _] (into [:and] v))} + :unparse-properties {:and (fn [c into-properties {{:keys [unparse-properties]} ::constraint-context :as opts}] + (reduce (fn [into-properties c] + (unparse-properties c into-properties opts)) + into-properties (-children c))) + ::true-constraint (fn [_ into-properties _] into-properties) + ::false-constraint (fn [_ into-properties _] (assoc into-properties :and [[:false]]))}}) + +(defn -simple-constraint [{this-type :type :keys [validator explainer intersect into-schema]}] + ^{:type ::into-schema} + (reify + AST + (-from-ast [parent ast options] (throw (ex-info "TODO" {}))) + IntoSchema + (-type [_] this-type) + (-type-properties [_]) + (-properties-schema [_ _]) + (-children-schema [_ _]) + (-into-schema [parent properties children options] + (or (if into-schema + (into-schema parent properties children options) + (-check-children! type properties children 0 0)) + (let [this (volatile! nil) + form (delay (-constraint-form @this options)) + cache (-create-cache options)] + (vreset! + this + ^{:type ::schema} + (reify + mc/Constraint + (-constraint? [_] true) + (-intersect [this that options] (intersect this that options)) + AST + (-to-ast [this _] (throw (ex-info "TODO" {}))) + Schema + (-validator [this] (validator this)) + (-explainer [this path] (explainer this path)) + (-parser [this] (-simple-parser this)) + (-unparser [this] (-parser this)) + (-transformer [this transformer method options] (-fail! ::constraints-cannot-be-transformed this)) + (-walk [this walker path options] (-walk-leaf this walker path options)) + (-properties [_] properties) + (-options [_] options) + (-children [_] children) + (-parent [_] parent) + (-form [_] @form) + Cached + (-cache [_] cache) + LensSchema + (-keep [_]) + (-get [_ _ default] default) + (-set [this key _] (-fail! ::non-associative-constraint {:schema this, :key key}))))))))) + +(defn -tf-constraint [tf] + (let [this-type (if tf ::true-constraint ::false-constraint)] + (-simple-constraint {:type this-type + :validator (fn [_] (if tf any? (fn [_] false))) + ;;TODO unit test + :explainer (fn [this path] (fn [x in acc] (cond-> acc (not tf) (conj (miu/-error (conj path ::constraint) in this x))))) + :intersect (fn [this that _] (when (= this-type (type that)) this))}))) + +(defn- -default-number-min-max-constraint-extensions [this-type] + (let [ks [:min :max :gen/min :gen/max]] + {:parse-constraint (into {} (map (fn [k] + [k (fn [{:keys [properties children]} opts] + (-check-children! k properties children 1 1) + [this-type {k (first children)}])])) + ks) + :constraint-form {this-type (fn [c options] + (let [p (-properties c) + frms (reduce (fn [frms k] + (if-some [v (k p)] + (conj frms [k v]) + frms)) + [] ks)] + (case (count frms) + 0 [:true] + 1 (first frms) + (into [:and] frms))))} + :parse-properties (into {} (map (fn [k] [k (fn [v opts] [k v])])) ks) + :unparse-properties {this-type (fn [c into-properties _] (into into-properties (-properties c)))}})) + +(defn -default-range-constraint-extensions [] (-default-number-min-max-constraint-extensions ::range-constraint)) + +(defn -walk-leaf+constraints [schema walker path {::keys [constraint-opts] :as options}] + (when (-accept walker schema path options) + (let [constraint (mc/-get-constraint schema) + constraint' (when constraint + (let [constraint-walker (or (::constraint-walker options) + (reify Walker + (-accept [_ constraint _ _] constraint) + (-inner [this constraint path options] (-walk constraint this path options)) + (-outer [_ constraint _ children _] (-set-children constraint children))))] + (-walk constraint constraint-walker (conj path ::constraint) + (assoc options + ::constraint-walker constraint-walker + ;; enables constraints that contain schemas, e.g., [:string {:edn :int}] + ::schema-walker walker)))) + schema (cond-> schema + ;; don't try and guess the 'unparsed' properties when we don't need to. + (and (some? constraint') + (not (identical? constraint constraint'))) + (-update-properties (fn [properties] + (let [{:keys [unparse-properties]} constraint-opts + f (or (get unparse-properties (type constraint')) + (-fail! ::cannot-unparse-constraint-into-properties + {:constraint constraint'}))] + (f constraint' properties options)))))] + (-outer walker schema path (-children schema) options)))) + +(defn -base-number-constraint-extension [] + (-> (default-constraint-extensions) + (assoc :-walk -walk-leaf+constraints) + (as-> $ (merge-with into $ (-default-range-constraint-extensions))))) + +(defn -range-or-count-constraint [this-type into-schema validator error-path] + (-simple-constraint {:type this-type + :into-schema into-schema + :validator validator + :explainer (fn [this path] + (let [pred (-validator this)] + (fn [x in acc] + (cond-> acc + (not (pred x)) + (conj (miu/-error path in this x error-path)))))) + :intersect -intersect-min-max})) + +(defn -range-constraint [] + (let [this-type ::range-constraint] + (-range-or-count-constraint + this-type + (fn [parent properties children options] + (-check-children! this-type properties children 0 0) + (let [{min-range :min max-range :max} properties + _ (when-not (or (nil? min-range) + (number? min-range)) + (-fail! ::range-constraint-min {:min min-range})) + _ (when-not (or (nil? max-range) + (number? max-range)) + (-fail! ::range-constraint-max {:max max-range}))] + (when (and min-range max-range (not (<= min-range max-range))) + (constraint [:false] options)))) + (fn [this] (or ((-min-max-pred nil) (-properties this)) any?)) + ::range-limits))) + +(defn default-count-constraint-extensions [] (-default-number-min-max-constraint-extensions ::count-constraint)) + +(defn -count-constraint [] + (let [this-type ::count-constraint] + (-range-or-count-constraint + this-type + (fn [parent properties children options] + (-check-children! this-type properties children 0 0) + (let [{min-count :min max-count :max} properties + ;; unclear if we want to enforce (<= min-count max-count) + ;; it's a perfectly well formed constraint that happens to satisfy no values + _ (when-not (or (nil? min-count) + (nat-int? min-count)) + (-fail! ::count-constraint-min {:min min-count})) + _ (when-not (or (nil? max-count) + (nat-int? max-count)) + (-fail! ::count-constraint-max {:max max-count}))] + (when (and min-count max-count (not (<= min-count max-count))) + (constraint [:false] options)))) + ;;TODO bounded counts + #(-validate-limits (-properties %)) + ::count-limits))) + +(defn -base-collection-constraint-extension [] + (-> (default-constraint-extensions) + ;TODO + ;(assoc :-walk -walk-leaf+constraints) + (as-> $ (merge-with into $ (default-count-constraint-extensions))))) + +(defn base-constraints [] + {::range-constraint (-range-constraint) + ::count-constraint (-count-constraint) + ::true-constraint (-tf-constraint true) + ::false-constraint (-tf-constraint false)}) + +(defn base-constraint-extensions [] + (merge (let [ext (-base-number-constraint-extension)] + {:int ext :double ext :float ext}) + {:string (-> (default-constraint-extensions) + (assoc :-walk -walk-leaf+constraints) + (as-> $ (merge-with into $ (default-count-constraint-extensions))))} + (let [ext (-base-collection-constraint-extension)] + {:vector ext :sequential ext :seqable ext :set ext + ;;TODO :every (bounded) + }))) + +(defn- activate-base-constraints! [] + (mce/register-constraints (base-constraints)) + (mce/register-constraint-extensions! (base-constraint-extensions))) + +(when #?(:cljs (identical? mc/mode "on") + :default (= mc/mode "on")) + (activate-base-constraints!)) + +(comment + ;; simplify [:and :int [:<= 5]] => [:int {:max 5}] during generation + ;; [:<= 5] is a constraint and :int is a constrained schema + ;; :and updates the constrained schema with the constraint, merging them + ) diff --git a/src/malli/dev.clj b/src/malli/dev.clj index 557610b64..fd8da1dd3 100644 --- a/src/malli/dev.clj +++ b/src/malli/dev.clj @@ -2,6 +2,7 @@ (:require [malli.clj-kondo :as clj-kondo] [malli.core :as m] [malli.dev.pretty :as pretty] + malli.dev.constraint ;; collect defn schemas [malli.instrument :as mi])) (defn -log! diff --git a/src/malli/dev/constraint.cljc b/src/malli/dev/constraint.cljc new file mode 100644 index 000000000..42dbc2b6d --- /dev/null +++ b/src/malli/dev/constraint.cljc @@ -0,0 +1,60 @@ +(ns malli.dev.constraint + (:require [malli.core :as m] + [malli.util :as mu] + ;; m/=> doesn't seem to support aliases + malli.constraint + malli.constraint.extension)) + +(def Schema :any) +(def Properties :any) +(def Form :any) +(def ?Constraint :any) +(def ContextualConstraintForm :any) +(def Type :any) +(def Walker :any) +(def Path :any) +(def Constraint :any) +(def Options [:maybe map?]) +(def ConstraintExtension + [:map + ;; a function taking surface-syntax for a constraint and returning a Constraint. + ;; e.g., :string's [:max 5] => [::m/count-constraint {:min 0 :max 5}] + ;; e.g., :int's [:max 5] => [::m/range-constraint {:max 5}] + [:parse-constraint + {:optional true} + [:map-of :any [:-> + ;; for [:max {:foo 1} 5], will be passed: + ;; {:properties {:foo 1} :children [5]} + ;; the function will be registered under :max. + [:map + [:properties Properties] + [:children [:sequential :any]]] + Options + ?Constraint]]] + ;; a function to return the form of a constraint under the current schema. + ;; e.g., :string's [:max 5] <= [::m/count-constraint {:min 0 :max 5}] + ;; e.g., :int's [:max 5] <= [::m/range-constraint {:max 5}] + [:constraint-form + {:optional true} + [:map-of Type [:-> Constraint Options Form]]] + ;; a function to parse a property into a contextual constraint form. + ;; e.g., [:string {:max 1}] => [:max 1] + ;; e.g., [:string {:and [[:max 1]]}] => [:and [:max 1]] + [:parse-properties + [:map-of :any [:-> :any Options ContextualConstraintForm]]] + ;; a function to convert a Constraint back to the properties of its schema. + ;; e.g., [:string {:max 4}] <= [::m/count-constraint {:min 0 :max 4}] + ;; e.g., [:int {:max 4}] <= [::m/range-constraint {:min 0 :max 4}] + [:unparse-properties + [:-> Constraint Properties Options Properties]] + ;; a custom walking function to walk both schema and its constraints. + [:-walk + {:optional true} + [:-> Schema Walker Path Constraint Options [:maybe Schema]]]]) + +(def ConstraintExtensions [:map-of Type ConstraintExtension]) + +(m/=> malli.constraint.extension/get-constraint-extension [:-> :any [:maybe ConstraintExtension]]) +(m/=> malli.constraint.extension/register-constraint-extensions! [:-> ConstraintExtensions ConstraintExtensions]) +(m/=> malli.core/base-constraint-extensions [:-> ConstraintExtensions]) +(m/=> malli.core/default-constraint-extensions [:-> (mu/optional-keys ConstraintExtension)]) diff --git a/src/malli/error.cljc b/src/malli/error.cljc index 6cc2a4313..3d9b9c216 100644 --- a/src/malli/error.cljc +++ b/src/malli/error.cljc @@ -1,28 +1,45 @@ (ns malli.error (:require [clojure.string :as str] + [malli.constraint :as mc] [malli.core :as m] [malli.util :as mu])) (defn -pr-str [v] #?(:clj (pr-str v), :cljs (str v))) +(defn en-range-min-max [min max value] + (cond + (and min (= min max)) (str "should be " min) + (and min (< value min)) (str "should be at least " min) + max (str "should be at most " max))) + +;; if constraints are enabled, this will be handled by ::m/range-limits (defn -pred-min-max-error-fn [{:keys [pred message]}] (fn [{:keys [schema value]} _] (let [{:keys [min max]} (m/properties schema)] - (cond - (not (pred value)) message - (and min (= min max)) (str "should be " min) - (and min (< value min)) (str "should be at least " min) - max (str "should be at most " max))))) + (if (not (pred value)) + message + (en-range-min-max min max value))))) + +(defn- en-count-limits [min max value] + (let [should (if (string? value) "should be " "should have ") + elements #(str " " (if (string? value) "character" "element") (when-not (= 1 %) "s"))] + (cond + (and min (= min max)) (str should min (elements min)) + (and min (< (m/-safe-count value) min)) (str should "at least " min (elements min)) + max (str should "at most " max (elements max))))) (def default-errors {::unknown {:error/message {:en "unknown error"}} ::m/missing-key {:error/message {:en "missing required key"}} + ::m/count-limits {:error/fn {:en (fn [{:keys [schema value]} _] + (let [{:keys [min max]} (m/properties schema)] + (en-count-limits min max value)))}} + ::m/range-limits {:error/fn {:en (fn [{:keys [schema value]} _] + (let [{:keys [min max]} (m/properties schema)] + (en-range-min-max min max value)))}} ::m/limits {:error/fn {:en (fn [{:keys [schema value]} _] (let [{:keys [min max]} (m/properties schema)] - (cond - (and min (= min max)) (str "should have " min " elements") - (and min (< (count value) min)) (str "should have at least " min " elements") - max (str "should have at most " max " elements"))))}} + (en-count-limits min max value)))}} ::m/tuple-size {:error/fn {:en (fn [{:keys [schema value]} _] (let [size (count (m/children schema))] (str "invalid tuple size " (count value) ", expected " size)))}} @@ -96,15 +113,19 @@ :any {:error/message {:en "should be any"}} :nil {:error/message {:en "should be nil"}} :string {:error/fn {:en (fn [{:keys [schema value]} _] - (let [{:keys [min max]} (m/properties schema)] - (cond - (not (string? value)) "should be a string" - (and min (= min max)) (str "should be " min " character" (when (not= 1 min) "s")) - (and min (< (count value) min)) (str "should be at least " min " character" - (when (not= 1 min) "s")) - max (str "should be at most " max " character" (when (not= 1 max) "s")))))}} + (if-not (string? value) + "should be a string" + ;;if constraints are enabled these problems are reported via ::m/count-limits + (when-not (mc/-constrained-schema? schema) + (let [{:keys [min max]} (m/properties schema)] + (cond + (and min (= min max)) (str "should be " min " character" (when (not= 1 min) "s")) + (and min (< (count value) min)) (str "should be at least " min " character" + (when (not= 1 min) "s")) + max (str "should be at most " max " character" (when (not= 1 max) "s")))))))}} :int {:error/fn {:en (-pred-min-max-error-fn {:pred int?, :message "should be an integer"})}} :double {:error/fn {:en (-pred-min-max-error-fn {:pred double?, :message "should be a double"})}} + :float {:error/fn {:en (-pred-min-max-error-fn {:pred float?, :message "should be a float"})}} :boolean {:error/message {:en "should be a boolean"}} :keyword {:error/message {:en "should be a keyword"}} :symbol {:error/message {:en "should be a symbol"}} diff --git a/src/malli/generator.cljc b/src/malli/generator.cljc index 078b4c85e..529ba8dd2 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -1,12 +1,15 @@ ;; See also `malli.generator-ast` for viewing generators as data (ns malli.generator - (:require [clojure.spec.gen.alpha :as ga] + (:require [clojure.set :as set] + [clojure.spec.gen.alpha :as ga] [clojure.string :as str] [clojure.test.check :as check] [clojure.test.check.generators :as gen] [clojure.test.check.properties :as prop] [clojure.test.check.random :as random] [clojure.test.check.rose-tree :as rose] + [malli.constraint :as mc] + [malli.constraint.solver :as solver] [malli.core :as m] [malli.registry :as mr] [malli.util :as mu] @@ -95,18 +98,61 @@ :generator gen :min min}))) -(defn- -string-gen [schema options] - (let [{:keys [min max]} (-min-max schema options)] - (cond - (and min (= min max)) (gen/fmap str/join (gen/vector gen/char-alphanumeric min)) - (and min max) (gen/fmap str/join (gen/vector gen/char-alphanumeric min max)) - min (gen/fmap str/join (gen-vector-min gen/char-alphanumeric min options)) - max (gen/fmap str/join (gen/vector gen/char-alphanumeric 0 max)) - :else gen/string-alphanumeric))) - -(defn- -coll-gen [schema f options] - (let [{:keys [min max]} (-min-max schema options) - child (-> schema m/children first) +(declare gen-one-of) + +(defn- -constraint-solutions [constraint constraint-opts options] + (solver/-constraint-solutions + constraint constraint-opts (assoc options ::solver/mode :gen))) + +(defn- -solve-schema-constraints [schema options] + (let [constraint (or (mc/-get-constraint schema) + (m/-fail! ::missing-constraint {:type (m/type schema) + :schema schema})) + solutions (-constraint-solutions constraint (m/type schema) options)] + (when (empty? solutions) + (m/-fail! ::unsatisfiable-constraint {:type (m/type schema) + :schema schema + :constraint constraint})) + solutions)) + +(defn- -solutions-gen [schema solution->gen options] + (->> (-solve-schema-constraints schema options) + (mapv solution->gen) + gen-one-of)) + +(defn- -min-max-solutions-gen [schema options mink maxk min-max->gen] + (prn "-min-max-solutions-gen" mink maxk) + (-solutions-gen schema + (fn [solution] + (prn "solution" solution) + (when-some [unsupported-keys (not-empty (disj (set (keys solution)) + mink maxk))] + (m/-fail! ::unsupported-constraint-solution {:type (m/type schema) + :schema schema + :solution solution})) + (min-max->gen (set/rename-keys solution {mink :min maxk :max}))) + options)) + +(defn -string-gen* [{:keys [min max]} options] + (cond + (and min (= min max)) (gen/fmap str/join (gen/vector gen/char-alphanumeric min)) + (and min max) (gen/fmap str/join (gen/vector gen/char-alphanumeric min max)) + min (gen/fmap str/join (gen-vector-min gen/char-alphanumeric min options)) + max (gen/fmap str/join (gen/vector gen/char-alphanumeric 0 max)) + :else gen/string-alphanumeric)) + +(defn -constrained-or-legacy-gen [constrained-gen legacy-gen schema & args] + (apply (if (mc/-constrained-schema? schema) constrained-gen legacy-gen) schema args)) + +(defn- -string-gen-legacy [schema options] + (-string-gen* (-min-max schema options) options)) + +(defn- -string-gen-constrained [schema options] + {:pre [(-min-max schema options)]} + (-min-max-solutions-gen schema options :min-count :max-count #(-string-gen* % options))) + +(defn- -coll-gen* [{:keys [min max]} schema f options] + (let [child (-> schema m/children first) gen (generator child options)] (if (-unreachable-gen? gen) (if (= 0 (or min 0)) @@ -119,9 +165,20 @@ max (gen/vector gen 0 max) :else (gen/vector gen)))))) -(defn- -coll-distinct-gen [schema f options] - (let [{:keys [min max]} (-min-max schema options) - child (-> schema m/children first) +(defn- -coll-gen-legacy [schema f options] + (-coll-gen* (-min-max schema options) schema f options)) + +(defn- -coll-gen-constrained [schema f options] + ;; preserve error message when :max < :gen/max. unclear if it's still a good idea + ;; to enforce with constraints, since multiple maxes are allowed and :max-count is the min of all of them. + {:pre [(-min-max schema options)]} + (-min-max-solutions-gen schema options :min-count :max-count #(-coll-gen* % schema f options))) + +(defn- -coll-gen [schema f options] + (-constrained-or-legacy-gen -coll-gen-constrained -coll-gen-legacy schema f options)) + +(defn- -coll-distinct-gen* [{:keys [min max]} schema f options] + (let [child (-> schema m/children first) gen (generator child options)] (if (-unreachable-gen? gen) (if (= 0 (or min 0)) @@ -131,6 +188,16 @@ :ex-fn #(m/-exception ::distinct-generator-failure (assoc % :schema schema))}))))) +(defn- -coll-distinct-legacy-gen [schema f options] + (-coll-distinct-gen* (-min-max schema options) schema f options)) + +(defn -coll-distinct-gen-constrained [schema f options] + {:pre [(-min-max schema options)]} + (-min-max-solutions-gen schema options :min-count :max-count #(-coll-distinct-gen* % schema f options))) + +(defn- -coll-distinct-gen [schema f options] + (-constrained-or-legacy-gen -coll-distinct-gen-constrained -coll-distinct-legacy-gen schema f options)) + (defn -and-gen [schema options] (if-some [gen (-not-unreachable (-> schema (m/children options) first (generator options)))] (gen/such-that (m/validator schema options) gen @@ -144,10 +211,13 @@ (first gs) (gen/one-of gs))) -(defn- -seqable-gen [schema options] +(defn- -seqable-gen* [{:keys [min] :as props} schema options] (let [el (-> schema m/children first)] (gen-one-of - (-> [nil-gen] + (-> [] + (cond-> + (or (nil? min) (zero? min)) + (conj nil-gen)) (into (map #(-coll-gen schema % options)) [identity vec eduction #(into-array #?(:clj Object) %)]) (conj (-coll-distinct-gen schema set options)) @@ -155,7 +225,21 @@ (and (= :tuple (m/type el)) (= 2 (count (m/children el)))) (conj (let [[k v] (m/children el)] - (generator [:map-of (or (m/properties schema) {}) k v] options)))))))) + (when-some [unsupported-keys (not-empty (disj (set (keys props)) + :min :max))] + (m/-fail! ::unsupported-map-of-props-forwarded-from-seqable + {:schema schema :properties props})) + (generator [:map-of (or props {}) k v] options)))))))) + +(defn- -seqable-legacy-gen [schema options] + (-seqable-gen* (-min-max schema options) schema options)) + +(defn- -seqable-gen-constrained [schema options] + {:pre [(-min-max schema options)]} + (-min-max-solutions-gen schema options :min-count :max-count #(-seqable-gen* % schema options))) + +(defn- -seqable-gen [schema options] + (-constrained-or-legacy-gen -seqable-gen-constrained -seqable-legacy-gen schema options)) (defn -or-gen [schema options] (if-some [gs (not-empty @@ -474,30 +558,64 @@ (defmethod -schema-generator :any [_ _] (ga/gen-for-pred any?)) (defmethod -schema-generator :some [_ _] gen/any-printable) (defmethod -schema-generator :nil [_ _] nil-gen) -(defmethod -schema-generator :string [schema options] (-string-gen schema options)) -(defmethod -schema-generator :int [schema options] (gen/large-integer* (-min-max schema options))) -(defmethod -schema-generator :double [schema options] - (gen/double* (merge (let [props (m/properties schema options)] - {:infinite? (get props :gen/infinite? false) - :NaN? (get props :gen/NaN? false)}) - (-> (-min-max schema options) +(defmethod -schema-generator :string [schema options] + (-constrained-or-legacy-gen -string-gen-constrained -string-gen-legacy schema options)) + +(defn -int-gen* [min-max] + (gen/large-integer* min-max)) + +(defn -int-gen-legacy [schema options] + (-int-gen* (-min-max schema options))) + +(defn -int-gen-constrained [schema options] + {:pre [(-min-max schema options)]} + (-min-max-solutions-gen schema options :min-range :max-range -int-gen*)) + +(defmethod -schema-generator :int [schema options] + (-constrained-or-legacy-gen -int-gen-constrained -int-gen-legacy schema options)) + +(defn -double-gen* [props min-max] + (gen/double* (merge {:infinite? (get props :gen/infinite? false) + :NaN? (get props :gen/NaN? false)} + (-> min-max (update :min #(some-> % double)) (update :max #(some-> % double)))))) -(defmethod -schema-generator :float [schema options] + +(defn -double-gen-legacy [schema options] + (-double-gen* (m/properties schema options) (-min-max schema options))) + +(defn -double-gen-constrained [schema options] + {:pre [(-min-max schema options)]} + (-min-max-solutions-gen schema options :min-range :max-range #(-double-gen* (m/properties schema options) %))) + +(defmethod -schema-generator :double [schema options] + (-constrained-or-legacy-gen -double-gen-constrained -double-gen-legacy schema options)) + +(defn -float-gen* [props min-max] (let [max-float #?(:clj Float/MAX_VALUE :cljs (.-MAX_VALUE js/Number)) min-float (- max-float) - props (m/properties schema options) - min-max-props (-min-max schema options) infinite? #?(:clj false :cljs (get props :gen/infinite? false))] (->> (merge {:infinite? infinite? :NaN? (get props :gen/NaN? false)} - (-> min-max-props + (-> min-max (update :min #(or (some-> % float) #?(:clj min-float :cljs nil))) (update :max #(or (some-> % float) #?(:clj max-float :cljs nil))))) (gen/double*) (gen/fmap float)))) + +(defn -float-gen-legacy [schema options] + (-float-gen* (m/properties schema options) (-min-max schema options))) + +(defn -float-gen-constrained [schema options] + {:pre [(-min-max schema options)]} + (-min-max-solutions-gen schema options :min-range :max-range + #(-float-gen* (select-keys (m/properties schema options) [:gen/NaN? :gen/infinite?]) %))) + +(defmethod -schema-generator :float [schema options] + (-constrained-or-legacy-gen -float-gen-constrained -float-gen-legacy schema options)) + (defmethod -schema-generator :boolean [_ _] gen/boolean) (defmethod -schema-generator :keyword [_ _] gen/keyword) (defmethod -schema-generator :symbol [_ _] gen/symbol) @@ -552,25 +670,23 @@ (defn- -create-from-schema [props options] (some-> (:gen/schema props) (generator options))) -(defn- -create-from-fmap [props schema options] +(defn- -create-from-fmap [gen props schema options] (when-some [fmap (:gen/fmap props)] (gen/fmap (m/eval fmap (or options (m/options schema))) - (or (-create-from-return props) - (-create-from-elements props) - (-create-from-schema props options) - (-create-from-gen props schema options) - nil-gen)))) + gen))) (defn- -create [schema options] (let [props (-merge (m/type-properties schema) - (m/properties schema))] - (or (-create-from-fmap props schema options) - (-create-from-return props) - (-create-from-elements props) - (-create-from-schema props options) - (-create-from-gen props schema options) - (m/-fail! ::no-generator {:options options - :schema schema})))) + (m/properties schema)) + gen (or (-create-from-return props) + (-create-from-elements props) + (-create-from-schema props options) + (-create-from-gen props schema options) + (m/-fail! ::no-generator {:options options + :schema schema + :form (m/form schema)}))] + (or (-create-from-fmap gen props schema options) + gen))) ;; ;; public api diff --git a/src/malli/impl/util.cljc b/src/malli/impl/util.cljc index 84f3b13ab..76007edd0 100644 --- a/src/malli/impl/util.cljc +++ b/src/malli/impl/util.cljc @@ -1,4 +1,5 @@ (ns malli.impl.util + (:require [clojure.core :as c]) #?(:clj (:import #?(:bb (clojure.lang MapEntry) :clj (clojure.lang MapEntry LazilyPersistentVector)) (java.util.concurrent TimeoutException TimeUnit FutureTask)))) @@ -67,8 +68,14 @@ (def ^{:arglists '([[& preds]])} -every-pred #?(:clj (-pred-composer and 16) - :cljs (fn [preds] (fn [m] (boolean (reduce #(or (%2 m) (reduced false)) true preds)))))) + :cljs (fn [preds] + (if-some [preds (not-empty (reverse preds))] + (reduce (fn [acc f] (fn [x] (and (f x) (acc x)))) (first preds) (next preds)) + any?)))) (def ^{:arglists '([[& preds]])} -some-pred #?(:clj (-pred-composer or 16) - :cljs (fn [preds] (fn [x] (boolean (some #(% x) preds)))))) + :cljs (fn [preds] + (if-some [preds (not-empty (reverse preds))] + (reduce (fn [acc f] (fn [x] (or (f x) (acc x)))) (first preds) (next preds)) + (fn [_] false))))) diff --git a/src/malli/registry.cljc b/src/malli/registry.cljc index e7bcb13f4..992773902 100644 --- a/src/malli/registry.cljc +++ b/src/malli/registry.cljc @@ -44,6 +44,11 @@ (reset! registry* (registry ?registry)) (throw (ex-info "can't set default registry, invalid mode" {:mode mode, :type type})))) +(defn swap-default-registry! [f & args] + (if-not (identical? mode "strict") + (apply swap! registry* f args) + (throw (ex-info "can't set default registry, invalid mode" {:mode mode, :type type})))) + (defn ^:no-doc custom-default-registry [] (reify Registry diff --git a/src/malli/simplify.cljc b/src/malli/simplify.cljc new file mode 100644 index 000000000..391e2becd --- /dev/null +++ b/src/malli/simplify.cljc @@ -0,0 +1,63 @@ +(ns malli.simplify + (:require [malli.core :as m])) + +(defmulti intersect (fn [this _ _] (m/type this))) +(defmethod intersect :default [_ _ _]) + +(defmethod intersect :and + [this that _] + (when (= :and (m/type that)) + (m/-set-children this (into (m/children this) (m/children that))))) + +(defn -intersect-min-max [this that] + (when (= (m/type this) (m/type that)) + (let [p (m/properties this) + p' (m/properties that)] + (m/-set-properties this + (reduce-kv (fn [m k f] + (if-some [v (let [l (k p) r (k p')] (if (and l r) (f l r) (or l r)))] + (assoc m k v) + m)) + nil {:min c/max :max c/min :gen/min c/max :gen/max c/min}))))) + +(defmethod intersect ::m/range-constraint [this that _] (m/-intersect-min-max this that)) +(defmethod intersect ::m/count-constraint [this that _] (m/-intersect-min-max this that)) + +(defmethod intersect ::m/true-constraint [this that _] (when (= (m/type this) (m/type that)) this)) +(defmethod intersect :any [this that _] (when (= (m/type this) (m/type that)) this)) +(defmethod intersect ::m/false-constraint [this that _] (when (= (m/type this) (m/type that)) this)) +(defmethod intersect :never [this that _] (when (= (m/type this) (m/type that)) this)) + +(defmulti simplify m/type) +(defmethod simplify :default [_ _ _]) + +(defn -intersect-common-constraints [cs] + (->> cs + (group-by type) + (sort-by key) + (into [] (mapcat (fn [[_ v]] + (case (count v) + 1 (subvec v 0 1) + (let [[l r & nxt] v] + ;; if the first two intersect successfully, assume the rest do too + (if-some [in (intersect l r nil)] + [(if nxt + (reduce #(intersect %1 %2 nil) in nxt) + in)] + v)))))))) + +(defn -flatten-and [cs] + (eduction (mapcat #(if (= :and (m/type %)) + (m/children %) + [%])) + cs)) + +;;TODO merge constraints into constrained schemas +(defmethod simplify :and + [this] + (let [ichildren (-> this m/children -flatten-and -intersect-common-constraints)] + (when (not= ichildren (m/children this)) + (case (count ichildren) + 0 (m/schema :any (m/options this)) + 1 (first ichildren) + (m/-set-children ichildren))))) diff --git a/test/malli/constraint/collection_test.cljc b/test/malli/constraint/collection_test.cljc new file mode 100644 index 000000000..a458e53f0 --- /dev/null +++ b/test/malli/constraint/collection_test.cljc @@ -0,0 +1,41 @@ +(ns malli.constraint.collection-test + (:require [clojure.test :refer [deftest is testing]] + [clojure.test.check.generators :as gen] + [malli.core :as m] + [malli.error :as me])) + +(deftest ^:constraints min-max-collection-constraint-test + (doseq [[type coerce] [[:vector #'vec] + [:sequential #'sequence] + ;;TODO bounded count + ;; [:every #'eduction] + [:seqable #'eduction] + [:set #'set]]] + (testing (str type " " coerce " :min/:max") + (is (m/validate [type {:min 1 :max 5} :int] (coerce [0 1]))) + (is (m/validate [type {:min 1 :max 5} :int] (coerce [0 1]))) + (is (m/validate [type {:min 4 :max 4} :int] (coerce [0 1 2 4]))) + (is (m/validate [type {:min 4 :max 4} :int] (coerce [0 1 2 4]))) + (is (not (m/validate [type {:min 1 :max 5} :int] (coerce [])))) + (is (not (m/validate [type {:min 1 :max 5} :int] (coerce [])))) + (is (= ["should have at least 1 element"] + (me/humanize (m/explain [type {:min 1} :int] (coerce []))) + (me/humanize (m/explain [type {:min 1 :max 10} :int] (coerce []))) + (me/humanize (m/explain [type {:min 1 :max 10} :int] (coerce []))) + (me/humanize (m/explain [type {:and [[:min 1]]} :int] (coerce []))))) + (is (= ["should have at least 2 elements"] + (me/humanize (m/explain [type {:min 2} :int] (coerce []))) + (me/humanize (m/explain [type {:min 2 :max 10} :int] (coerce []))) + (me/humanize (m/explain [type {:and [[:min 2]]} :int] (coerce []))))) + (is (= ["should have at most 1 element"] + (me/humanize (m/explain [type {:max 1} :int] (coerce [0 1]))) + (me/humanize (m/explain [type {:min 0 :max 1} :int] (coerce [0 1]))) + (me/humanize (m/explain [type {:and [[:max 1]]} :int] (coerce [0 1]))))) + (is (= ["should have at most 2 elements"] + (me/humanize (m/explain [type {:max 2} :int] (coerce [0 1 2]))) + (me/humanize (m/explain [type {:min 1 :max 2} :int] (coerce [0 1 2]))) + (me/humanize (m/explain [type {:min 1 :max 2} :int] (coerce [0 1 2]))) + (me/humanize (m/explain [type {:and [[:max 2]]} :int] (coerce [0 1 2]))))) + (is (= ["should have 1 element"] + (me/humanize (m/explain [type {:min 1 :max 1} :int] (coerce [0 1 2]))) + (me/humanize (m/explain [type {:and [[:min 1] [:max 1]]} :int] (coerce [0 1 2])))))))) diff --git a/test/malli/constraint/generator_test.cljc b/test/malli/constraint/generator_test.cljc new file mode 100644 index 000000000..9be50868c --- /dev/null +++ b/test/malli/constraint/generator_test.cljc @@ -0,0 +1,232 @@ +(ns malli.constraint.generator-test + (:require [clojure.test :refer [deftest is testing]] + [malli.core :as m] + [malli.constraint :as mc] + [malli.generator :as mg] + [malli.util :as mu])) + +(def options {:seed 0}) + +(deftest string-constraint-generate-test + (testing ":and + :min + :max" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.core/count-constraint-min" + (mg/generate [:string {:min -1}]))) + (is (= ["" "W" "pC" "4C" "x" "61" "8K8" "X5" "I4v" "sy3VC"] + (vec (mg/sample [:string {}] options)) + (vec (mg/sample [:string {:and []}] options)))) + (is (= ["Q0o7BnE37b" "6zNfuEdSsmp" "pwBdA45T9xxH" "4t1X2NXEI963" "p6Xp7IS2qOG" "6h1299fiSw7l" "8K9e51XMppRzg" "X4W88PP18l0P" "I4r432WZE70lJ" "sy3V813e055M00E"] + (vec (mg/sample [:string {:min 10}] options)) + (vec (mg/sample [:string {:and [[:min 10]]}] options)))) + (is (= ["C" "6zNfN" "pwBdA45T9C" "4t1X2Nl" "p6XC" "6ho" "8K99" "X40" "I4v" "sy3VC"] + (vec (mg/sample [:string {:max 10}] options)) + (vec (mg/sample [:string {:and [[:max 10]]}] options)))) + (is (= ["Q0o2" "6zNfN" "pwBdA9" "4t1X2C" "p6XpD" "6h12u" "8K9ew" "X4W9" "I4r47" "sy3VC"] + (vec (mg/sample [:string {:min 4 :max 6}] options)) + (vec (mg/sample [:string {:and [[:min 4] [:max 6]]}] options)))) + (is (every? seq (mg/sample [:string {:min 1}]))) + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.generator/unsatisfiable-constraint" + (mg/generate [:string {:min 10 :max 9}]))))) + +(deftest integer-constraint-generate-test + (testing ":and + :min + :max" + (is (= [0 -1 0 -3 0 1 16 0 7 3] + (mg/sample [:int {}] options) + (mg/sample [:int {:and []}] options))) + (is (= [10 11 10 13 10 11 26 10 17 13] + (mg/sample [:int {:min 10}] options) + (mg/sample [:int {:and [[:min 10]]}] options) + (mg/sample [:int {:and [[:min 10] [:min 5]]}] options))) + (is (= [0 -1 0 -3 0 1 -16 0 7 3] + (mg/sample [:int {:max 10}] options) + (mg/sample [:int {:and [[:max 10]]}] options) + (mg/sample [:int {:and [[:max 15] [:max 10]]}] options))) + (is (= [4 5 4 5 4 5 6 4 5 5] + (mg/sample [:int {:min 4 :max 6}] options) + (mg/sample [:int {:and [[:min 4] [:max 6]]}] options) + (mg/sample [:int {:and [[:min 4] [:max 6] [:min 3] [:max 7]]}] options))) + (is (= [-5 -6 -5 -8 -5 -6 -9 -5 -8 -8] + (mg/sample [:int {:min -10 :max -5}] options) + (mg/sample [:int {:and [[:min -10] [:max -5]]}] options) + (mg/sample [:int {:and [[:min -10] [:max -5] [:min -11] [:max -4]]}] options))) + (is (every? pos-int? (mg/sample [:int {:min 1}]))) + (is (every? neg-int? (mg/sample [:int {:max -1}]))) + (testing "with constraints the solver signals unsatisfiability with zero solutions" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.generator/unsatisfiable-constraint" + (mg/generate [:int {:min 10 :max 9}])))))) + +(deftest double-constraint-generate-test + (testing ":and + :min + :max" + (is (= [-1.0 2.0 -0.0 1.0 -1.0 1.0 3.25 -3.0 -0.9375 -2.0] + (mg/sample [:double {}] options) + (mg/sample [:double {:and []}] options))) + (is (= [10.0 16.0 16.0 24.0 16.0 16.0 16.0 10.0 22.0 13.5] + (mg/sample [:double {:min 10}] options) + (mg/sample [:double {:and [[:min 10]]}] options) + (mg/sample [:double {:and [[:min 10] [:min 5]]}] options))) + (is (= [0.5 -2.0 -0.0 -3.0 3.0 -0.78125 1.75 1.0 1.10546875 -6.0] + (mg/sample [:double {:max 10}] options) + (mg/sample [:double {:and [[:max 10]]}] options) + (mg/sample [:double {:and [[:max 15] [:max 10]]}] options))) + (is (= [4.0 4.0 4.0 6.0 4.0 4.0 4.0 4.0 5.5 5.375] + (mg/sample [:double {:min 4 :max 6}] options) + (mg/sample [:double {:and [[:min 4] [:max 6]]}] options) + (mg/sample [:double {:and [[:min 4] [:max 6] [:min 3] [:max 7]]}] options))) + (is (= [-7.999999999999998 -8.0 -8.0 -9.0 -8.0 -8.0 -8.0 -7.999999999999998 -9.25 -6.75] + (mg/sample [:double {:min -10 :max -5}] options) + (mg/sample [:double {:and [[:min -10] [:max -5]]}] options) + (mg/sample [:double {:and [[:min -10] [:max -5] [:min -11] [:max -4]]}] options))) + (is (every? pos? (mg/sample [:double {:min 0.0000001}]))) + (is (every? neg? (mg/sample [:double {:max -0.0000001}]))) + (testing "with constraints the solver signals unsatisfiability with zero solutions" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.generator/unsatisfiable-constraint" + (mg/generate [:double {:min 10 :max 9}])))))) + +(deftest float-constraint-generate-test + (testing ":and + :min + :max" + (is (= #?(:cljs [-1 2 0 1 -1 1 3.25 -3 -0.9375 -2] + :default (mapv float [0.5 -2.0 -0.0 -3.0 3.0 -0.78125 1.75 1.0 1.1054688 -6.0])) + (mg/sample [:float {}] options) + (mg/sample [:float {:and []}] options))) + (is (= (mapv float [10.0 16.0 16.0 24.0 16.0 16.0 16.0 10.0 22.0 13.5]) + (mg/sample [:float {:min 10}] options) + (mg/sample [:float {:and [[:min 10]]}] options) + (mg/sample [:float {:and [[:min 10] [:min 5]]}] options))) + (is (= (mapv float [0.5 -2.0 -0.0 -3.0 3.0 -0.78125 1.75 1.0 1.10546875 -6.0]) + (mg/sample [:float {:max 10}] options) + (mg/sample [:float {:and [[:max 10]]}] options) + (mg/sample [:float {:and [[:max 15] [:max 10]]}] options))) + (is (= (mapv float [4.0 4.0 4.0 6.0 4.0 4.0 4.0 4.0 5.5 5.375]) + (mg/sample [:float {:min 4 :max 6}] options) + (mg/sample [:float {:and [[:min 4] [:max 6]]}] options) + (mg/sample [:float {:and [[:min 4] [:max 6] [:min 3] [:max 7]]}] options))) + (is (= (mapv float [-7.999999999999998 -8.0 -8.0 -9.0 -8.0 -8.0 -8.0 -7.999999999999998 -9.25 -6.75]) + (mg/sample [:float {:min -10 :max -5}] options) + (mg/sample [:float {:and [[:min -10] [:max -5]]}] options) + (mg/sample [:float {:and [[:min -10] [:max -5] [:min -11] [:max -4]]}] options))) + (is (every? (every-pred pos? float?) (mg/sample [:float {:min 0.0000001}]))) + (is (every? (every-pred neg? float?) (mg/sample [:float {:max -0.0000001}]))) + ;#?(:clj (testing "without constraints properties are checked for satisfiability" + ; (is (thrown-with-msg? + ; AssertionError + ; (-> "(or (nil? lower-bound) (nil? upper-bound) (<= lower-bound upper-bound))" + ; java.util.regex.Pattern/quote + ; re-pattern) + ; (mg/generate [:float {:min 10 :max 9}] {}))))) + (testing "with constraints the solver signals unsatisfiability with zero solutions" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.generator/unsatisfiable-constraint" + (mg/generate [:float {:min 10 :max 9}])))))) + +(deftest vector+sequential-constraint-generate-test + (doseq [type [:vector :sequential]] + (testing (str type " :and + :min + :max") + (is (= [[] [-1] [-1 -1] [0 1] [1] [-3 -2] [-9 8 19] [1 0] [0 112 1] [-213 0 -36 -4 -40]] + (mg/sample [type {} :int] options) + (mg/sample [type {:and []} :int] options))) + (is (= [[0 -1 0 -1 -1 -1 0 0 0 0] [0 0 0 0 0 0 0 -1 -1 0 0] + [-1 0 -1 1 -1 0 1 1 0 -1 0 -1] [0 0 -4 1 -4 1 -1 -1 1 -2 0 1] + [-2 -1 -2 1 0 0 0 0 -1 0 0] [-3 0 -1 7 5 -7 0 0 15 -14 1 -6] + [-9 8 10 -1 1 -3 -1 -2 -2 1 -16 -1 -1] [1 -1 -1 -4 3 8 -1 -2 2 -8 3 -2] + [0 112 -22 -6 3 -47 8 -3 1 35 -7 7 0] [-213 0 -36 -4 -2 -3 -11 -8 -4 -18 -4 -1 -184 -15 -2]] + (mg/sample [type {:min 10} :int] options) + (mg/sample [type {:and [[:min 10]]} :int] options) + (mg/sample [type {:and [[:min 10] [:min 5]]} :int] options))) + (is (= [[-1] [0 0 0 0 0] [-1 0 -1 1 -1 0 1 1 0 0] [0 0 -4 1 -4 1 -1] [-2 -1 -2 0] + [-3 0 1] [-9 8 10 -2] [1 -1 23] [0 112 1] [-213 0 -36 -4 -40]] + (mg/sample [type {:max 10} :int] options) + (mg/sample [type {:and [[:max 10]]} :int] options) + (mg/sample [type {:and [[:max 15] [:max 10]]} :int] options))) + (is (= [[0 -1 0 -1] [0 0 0 0 0] [-1 0 -1 1 -1 -1] [0 0 -4 1 -4 -1] [-2 -1 -2 1 0] + [-3 0 -1 7 0] [-9 8 10 -1 1] [1 -1 -1 0] [0 112 -22 -6 -1] [-213 0 -36 -4 -40]] + (mg/sample [type {:min 4 :max 6} :int] options) + (mg/sample [type {:and [[:min 4] [:max 6]]} :int] options) + (mg/sample [type {:and [[:min 4] [:max 6] [:min 3] [:max 7]]} :int] options))) + (is (every? seq (mg/sample [type {:min 1} :int]))) + (is (every? empty? (mg/sample [type {:max 0} :int]))) + (testing "with constraints the solver signals unsatisfiability with zero solutions" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.generator/unsatisfiable-constraint" + (mg/generate [type {:min 10 :max 9} :int]))))))) + +#?(:clj (defn massage-seqable-sample [s] + (mapv (fn [s] + (cond + (some-> s class .isArray) [::array (vec s)] + (and (instance? java.lang.Iterable s) + (not (instance? clojure.lang.IPersistentCollection s))) [::eduction (vec s)] + :else s)) + s))) + +#?(:clj + (deftest seqable-constraint-generate-test + (testing ":and + :min + :max" + (is (= [nil [::eduction [0]] #{} [::array [0]] [-2 2 0 1] + [1 -2] [-9] [3 -49 -4] [-23 1 82] [::eduction [126 -24 -236 0 -18 0 0 2 -1]]] + (massage-seqable-sample (mg/sample [:seqable {} :int] options)) + (massage-seqable-sample (mg/sample [:seqable {:and []} :int] options)))) + (is (= [[-1 0 0 -1 -1 -1 0 0 0 -1] [::eduction [0 -1 0 -1 -1 -1 0 0 0 0 -1]] #{0 7 1 -2 4 -1 -6 -3 26 10} + [::array [-2 -1 3 -2 1 0 -1 3 -3 -1 -1]] [-2 2 0 3 1 -2 -8 5 2 -3 3 -1 -2 -1] + [1 -1 0 5 -5 0 -1 -1 1 -2 1 1] [::eduction [-1 6 -20 -1 4 -2 -4 1 -4 -1 2]] + [3 -49 -2 7 -2 25 5 12 25 3 9 1 31] [-23 1 2 -51 -1 0 9 -2 -5 53 4 0 -4] + [::eduction [126 -24 -236 0 -18 0 0 2 35 -105 -4 1 -1 -2 0 1 5 -37 -2]]] + (massage-seqable-sample (mg/sample [:seqable {:min 10} :int] options)) + (massage-seqable-sample (mg/sample [:seqable {:and [[:min 10]]} :int] options)) + (massage-seqable-sample (mg/sample [:seqable {:and [[:min 10] [:min 5]]} :int] options)))) + (is (= [nil [::eduction [0 -1 0 -1 -1]] #{0} [::array [-2 -1 -1]] [-2 2 0 3 1 -2 -8 5 2 0] + [1 -1 0 -1] [-1 5] [3 -49 -2 28] [-23 1 2 0] [::eduction [126 -24 -236 0 -18 0 0 2 35 -3]]] + (massage-seqable-sample (mg/sample [:seqable {:max 10} :int] options)) + (massage-seqable-sample (mg/sample [:seqable {:and [[:max 10]]} :int] options)) + (massage-seqable-sample (mg/sample [:seqable {:and [[:max 15] [:max 10]]} :int] options)))) + (is (= [[-1 0 0 -1 -1] [::eduction [0 -1 0 -1 -1]] #{0 -2 -6 -3} [::array [-2 -1 3 1]] [-2 2 0 3 1 -6] + [1 -1 0 5 -1] [::eduction [-1 6 -20 12]] [3 -49 -2 7 8] [-23 1 2 -51 3] [::eduction [126 -24 -236 0 -18 13]]] + (massage-seqable-sample (mg/sample [:seqable {:min 4 :max 6} :int] options)) + (massage-seqable-sample (mg/sample [:seqable {:and [[:min 4] [:max 6]]} :int] options)) + (massage-seqable-sample (mg/sample [:seqable {:and [[:min 4] [:max 6] [:min 3] [:max 7]]} :int] + options)))) + (is (every? seq (mg/sample [:seqable {:min 1} :int]))) + (is (every? empty? (mg/sample [:seqable {:max 0} :int]))) + (testing "with constraints the solver signals unsatisfiability with zero solutions" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.generator/unsatisfiable-constraint" + (mg/generate [:seqable {:min 10 :max 9} :int]))))))) + +(deftest set-constraint-generate-test + (testing ":and + :min + :max" + (is (= [#{} #{0} #{0 -1} #{0 1} #{-1} #{-2 -17} #{-12 9 5} #{0 -1} #{4 -1 -3} #{0 -1 -8 237 6}] + (mg/sample [:set {} :int] options) + (mg/sample [:set {:and []} :int] options))) + (is (= [#{0 -32 -1 -8 13 -15 3 -63 5 42} #{0 -505 1 -20 -2 -1 -3 -957 23 5 -307} #{0 -12 7 1 -2 -1 21 -6 172 -3 26 8} + #{0 -4 1 -1 -6 201 17 3 2 -7 -115 -5} #{0 -4 -1 13 -23 -3 6 3 2 9 -9} #{0 1 -125 -2 4 -1 99 -3 -17 25 3 -13} + #{0 -12 -28 1 -2 6 12 9 5 45 -9 -5 49} #{0 -4 -32 1 39 4 -1 -23 2 107 -168 16} + #{0 -12 -4 4 -1 -6 33 13 -3 3 5 -29 -13} #{0 345 -1 15 -8 -3 237 -43 6 127 -235 -9 10 -5 1021}] + (mg/sample [:set {:min 10} :int] options) + (mg/sample [:set {:and [[:min 10]]} :int] options) + (mg/sample [:set {:and [[:min 10] [:min 5]]} :int] options))) + (is (= [#{0} #{0 1 -20 -2 -1} #{0 -12 7 1 -2 -1 21 -6 -3 8} #{0 1 -1 17 3 2 -7} #{0 -1 13 9} + #{-2 4 -17} #{-12 1 9 5} #{0 -1 -23} #{4 -1 -3} #{0 -1 -8 237 6}] + (mg/sample [:set {:max 10} :int] options) + (mg/sample [:set {:and [[:max 10]]} :int] options) + (mg/sample [:set {:and [[:max 15] [:max 10]]} :int] options))) + (is (= [#{0 -1 -15 5} #{0 1 -20 -2 -1} #{0 7 -2 -1 -6 -3} #{0 1 -1 3 2 -7} #{0 -1 13 6 9} + #{0 -2 4 -17 25} #{-12 1 9 5 -5} #{0 -1 -23 2} #{-4 4 -1 13 -3} #{0 -1 -8 237 6}] + (mg/sample [:set {:min 4 :max 6} :int] options) + (mg/sample [:set {:and [[:min 4] [:max 6]]} :int] options) + (mg/sample [:set {:and [[:min 4] [:max 6] [:min 3] [:max 7]]} :int] options))) + (is (every? seq (mg/sample [:set {:min 1} :int]))) + (is (every? empty? (mg/sample [:set {:max 0} :int]))) + (testing "with constraints the solver signals unsatisfiability with zero solutions" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.generator/unsatisfiable-constraint" + (mg/generate [:set {:min 10 :max 9} :int])))))) diff --git a/test/malli/constraint/markdown_doc_test.cljc b/test/malli/constraint/markdown_doc_test.cljc new file mode 100644 index 000000000..2542beead --- /dev/null +++ b/test/malli/constraint/markdown_doc_test.cljc @@ -0,0 +1,19 @@ +(ns malli.constraint.markdown-doc-test + (:require [clojure.test :refer [deftest is testing]] + [clojure.test.check.generators :as gen] + [malli.constraint :as mc] + [malli.core :as m] + [malli.error :as me])) + +#?(:clj + (deftest ^:constraints constraint-md-test + (testing "constraint validators don't have preconditions" + (is (false? (-> [:string {:max 1}] + m/schema + (m/validate 1)))) + (is (thrown-with-msg? Exception + #"Don't know how to create ISeq from: java\.lang\.Long" + (-> [:string {:max 1}] + m/schema + mc/-get-constraint + (m/validate 1))))))) diff --git a/test/malli/constraint/number_test.cljc b/test/malli/constraint/number_test.cljc new file mode 100644 index 000000000..f4c04cafa --- /dev/null +++ b/test/malli/constraint/number_test.cljc @@ -0,0 +1,65 @@ +(ns malli.constraint.number-test + (:require [clojure.test :refer [deftest is testing]] + [clojure.test.check.generators :as gen] + [malli.constraint :as mc] + [malli.core :as m] + [malli.error :as me])) + +(deftest int-constraint-test + (testing ":min/:max" + (is (m/validate [:int {:min 1 :max 5}] 2)) + (is (m/validate [:int {:min 4 :max 4}] 4)) + (is (not (m/validate [:int {:min 1 :max 5}] ""))) + (is (= ["should be at least 1"] + (me/humanize (m/explain [:int {:min 1}] 0)) + (me/humanize (m/explain [:int {:min 1 :max 10}] 0)) + (me/humanize (m/explain [:int {:and [[:min 1]]}] 0)) + (me/humanize (m/explain [:int {:and [[:min 1] [:min -5]]}] 0)))) + (is (= ["should be at least 2"] + (me/humanize (m/explain [:int {:min 2}] 0)) + (me/humanize (m/explain [:int {:min 2 :max 10}] 0)) + (me/humanize (m/explain [:int {:and [[:min 2]]}] 0)) + (me/humanize (m/explain [:int {:and [[:min -2] [:min 2]]}] 0)))) + (is (= ["should be at most 1"] + (me/humanize (m/explain [:int {:max 1}] 2)) + (me/humanize (m/explain [:int {:min 0 :max 1}] 2)) + (me/humanize (m/explain [:int {:and [[:max 1] [:max 23]]}] 2)))) + (is (= ["should be at most 2"] + (me/humanize (m/explain [:int {:max 2}] 3)) + (me/humanize (m/explain [:int {:min 1 :max 2}] 3)) + (me/humanize (m/explain [:int {:and [[:max 23] [:max 2]]}] 3)))) + (is (= ["should be 1"] + (me/humanize (m/explain [:int {:min 1 :max 1}] 3)) + (me/humanize (m/explain [:int {:and [[:min 1] [:max 1]]}] 3)) + (me/humanize (m/explain [:int {:and [[:min 1] [:max 1] + [:min 0] [:max 2]]}] 3)))))) + +(deftest double+float-constraint-test + (doseq [type [:double :float]] + (testing (str type " :min/:max") + (is (m/validate [type {:min 1.0 :max 5.0}] 2.0)) + (is (m/validate [type {:min 4.0 :max 4.0}] 4.0)) + (is (not (m/validate [type {:min 1.0 :max 5.0}] ""))) + (is (= ["should be at least 1.5"] + (me/humanize (m/explain [type {:min 1.5}] 0.5)) + (me/humanize (m/explain [type {:min 1.5 :max 10.5}] 0.5)) + (me/humanize (m/explain [type {:and [[:min 1.5]]}] 0.5)) + (me/humanize (m/explain [type {:and [[:min 1.5] [:min -1.5]]}] 0.5)))) + (is (= ["should be at least 2.5"] + (me/humanize (m/explain [type {:min 2.5}] 0.5)) + (me/humanize (m/explain [type {:min 2.5 :max 10.5}] 0.5)) + (me/humanize (m/explain [type {:and [[:min 2.5]]}] 0.5)) + (me/humanize (m/explain [type {:and [[:min 0.5] [:min 2.5]]}] 0.5)))) + (is (= ["should be at most 1.5"] + (me/humanize (m/explain [type {:max 1.5}] 2.5)) + (me/humanize (m/explain [type {:max 1.5}] 2.5)) + (me/humanize (m/explain [type {:min 0.5 :max 1.5}] 2.5)) + (me/humanize (m/explain [type {:and [[:max 1.5] [:max 23.5]]}] 2.5)))) + (is (= ["should be at most 2.5"] + (me/humanize (m/explain [type {:max 2.5}] 3.5)) + (me/humanize (m/explain [type {:min 1.5 :max 2.5}] 3.5)) + (me/humanize (m/explain [type {:and [[:max 23.5] [:max 2.5]]}] 3.5)))) + (is (= ["should be 1.5"] + (me/humanize (m/explain [type {:min 1.5 :max 1.5}] 3.5)) + (me/humanize (m/explain [type {:and [[:min 1.5] [:max 1.5] + [:min 0.5] [:max 2.5]]}] 3.5))))))) diff --git a/test/malli/constraint/solver_test.cljc b/test/malli/constraint/solver_test.cljc new file mode 100644 index 000000000..b4440acdb --- /dev/null +++ b/test/malli/constraint/solver_test.cljc @@ -0,0 +1,26 @@ +(ns malli.constraint.solver-test + (:require [clojure.test :refer [deftest is]] + [malli.constraint.solver :as mcs])) + +(deftest -conj-number-constraints-test + (is (= [{:max-count 10 :min-count 1}] + (mcs/-conj-number-constraints + [{:max-count 10} {:min-count 1}]))) + (is (= [] (mcs/-conj-number-constraints [{:max-count 1} {:min-count 10}]))) + (is (= [] (mcs/-conj-number-constraints [{:max-count 1} {:min-count 10}])))) + +(deftest -conj-solutions-test + (is (= [{}] (mcs/-conj-solutions))) + (is (= [{:max-count 2}] (mcs/-conj-solutions '({:max-count 2})))) + (is (= [{:max-count 0}] + (mcs/-conj-solutions '({:max-count 2}) + '({:max-count 0})))) + (is (= [{:min-count 2}] + (mcs/-conj-solutions '({:min-count 2}) + '({:min-count 0}))))) + +#_ ;;TODO +(deftest -constraint-solutions-test + (is (= [{:min-count 0, :max-count 2}] + (mcs/-constraint-solutions + [:and [:min 0] [:max 2]] :string nil)))) diff --git a/test/malli/constraint/string_test.cljc b/test/malli/constraint/string_test.cljc new file mode 100644 index 000000000..19578e0a7 --- /dev/null +++ b/test/malli/constraint/string_test.cljc @@ -0,0 +1,48 @@ +(ns malli.constraint.string-test + (:require [clojure.test :refer [deftest is testing]] + [clojure.test.check.generators :as gen] + [malli.constraint :as mc] + [malli.core :as m] + [malli.error :as me])) + +(deftest string-constraint-test + (testing "default constraint" + (is (= ::m/true-constraint + (-> :string + m/schema + mc/-get-constraint + m/type)))) + (testing "constraint validators don't have preconditions" + (is (false? (-> [:string {:max 1}] + m/schema + (m/validate 1)))) + #?(:clj (is (thrown-with-msg? Exception + #"Don't know how to create ISeq from: java\.lang\.Long" + (-> [:string {:max 1}] + m/schema + mc/-get-constraint + (m/validate 1)))))) + (testing ":min/:max" + (is (m/validate [:string {:min 1 :max 5}] "ab")) + (is (m/validate [:string {:min 4 :max 4}] "🌉🜉")) + (is (not (m/validate [:string {:min 1 :max 5}] ""))) + (is (= ["should be at least 1 character"] + (me/humanize (m/explain [:string {:min 1}] "")) + (me/humanize (m/explain [:string {:min 1 :max 10}] "")) + (me/humanize (m/explain [:string {:and [[:min 1]]}] "")))) + (is (= ["should be at least 2 characters"] + (me/humanize (m/explain [:string {:min 2}] "")) + (me/humanize (m/explain [:string {:min 2 :max 10}] "")) + (me/humanize (m/explain [:string {:and [[:min 2]]}] "")))) + (is (= ["should be at most 1 character"] + (me/humanize (m/explain [:string {:max 1}] "🌉")) + (me/humanize (m/explain [:string {:max 1}] "12")) + (me/humanize (m/explain [:string {:min 0 :max 1}] "12")) + (me/humanize (m/explain [:string {:and [[:max 1]]}] "12")))) + (is (= ["should be at most 2 characters"] + (me/humanize (m/explain [:string {:max 2}] "123")) + (me/humanize (m/explain [:string {:min 1 :max 2}] "123")) + (me/humanize (m/explain [:string {:and [[:max 2]]}] "123")))) + (is (= ["should be 1 character"] + (me/humanize (m/explain [:string {:min 1 :max 1}] "123")) + (me/humanize (m/explain [:string {:and [[:min 1] [:max 1]]}] "123")))))) diff --git a/test/malli/constraint_test.cljc b/test/malli/constraint_test.cljc new file mode 100644 index 000000000..f56b40c9c --- /dev/null +++ b/test/malli/constraint_test.cljc @@ -0,0 +1,110 @@ +(ns malli.constraint-test + (:require [clojure.string :as str] + [clojure.test :refer [are deftest is testing]] + [clojure.test.check.generators :as gen] + [clojure.walk :as walk] + [malli.constraint :as mc] + [malli.core :as m] + [malli.edn :as edn] + [malli.generator :as mg] + [malli.error :as me] + [malli.impl.util :as miu] + [malli.registry :as mr] + [malli.transform :as mt] + [malli.util :as mu] + #?(:clj [malli.test-macros :refer [when-env]])) + #?(:clj (:import (clojure.lang IFn PersistentArrayMap PersistentHashMap)) + :cljs (:require-macros [malli.test-macros :refer [when-env]]))) + +(def count-constraint-options + {::m/constraint-context {:parse-constraint {:min (fn [{:keys [properties children]} opts] + [::m/count-constraint {:min (first children)}]) + :max (fn [{:keys [properties children]} opts] + [::m/count-constraint {:min 0 :max (first children)}])}} + :registry {::m/count-constraint (m/-count-constraint)}}) + +(deftest constraint-test + (testing "Constraints are returned as-is" + (is (= ::m/true-constraint + (m/type (m/constraint (m/schema (m/-tf-constraint true)))) + (m/type (m/constraint (m/schema (m/-tf-constraint true)) nil))))) + (testing "IntoSchema's are not allowed in raw form" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.core/missing-parse-constraint-options" + (m/constraint [::m/true-constraint] + {:registry {::m/true-constraint (m/-tf-constraint true)}})))) + (testing "m/form requires a constraint context" + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli\.core/no-constraint-form" + (m/form (m/constraint (m/schema (m/-tf-constraint true))))))) + (testing ":parse-constraint desugars constraints" + (is (= ::m/count-constraint + (m/type (m/constraint [:min 1] count-constraint-options)))) + (is (= (m/properties (m/constraint [:min 1] count-constraint-options)) + {:min 1})) + (is (= (m/properties (m/constraint [:max 1] count-constraint-options)) + {:min 0 :max 1})) + (testing "properties not forwarded in :max" + (is (= {:min 0 :max 1} (m/properties (m/constraint [:max {:property true} 1] count-constraint-options))))))) + +(defn string-context [] + {::m/constraint-context (:string (m/base-constraint-extensions))}) + +(defn errors [{:keys [errors]}] + (mapv #(update % :schema m/form) errors)) + +(deftest string-constraint-test + (is (= ::m/count-constraint (m/type (m/constraint [:min 1] (string-context))))) + (is (= [:min 1] (m/form (m/constraint [:min 1] (string-context))))) + (is (= ::m/count-constraint (m/type (m/constraint [:max 1] (string-context))))) + (is (= [:max 1] (m/form (m/constraint [:max 1] (string-context))))) + (is (= [:true] (m/form (m/constraint [:true] (string-context))))) + ;;FIXME + #_ + (is (= ::FIXME + (m/ast (m/constraint [:max 1] (string-context))))) + ;;FIXME + #_ + (is (= ::FIXME + (m/ast (m/constraint [:and [:min 1] [:max 2]] (string-context))))) + ;;TODO have a separate -constraint-form for pretty printing + ;; use -form for independent printing + ;; don't store constraint context in constraint + (testing "constraints are simplified" + (is (= [:and [:min 1] [:max 1]] + (m/form (m/constraint [:and [:min 0] [:min 1] [:max 1] [:max 2]] (string-context)))))) + (testing "but properties are preserved" + (is (= [:string {:and [[:and [:min 1] [:max 1]]]}] + (m/form (m/schema [:string {:and [[:and [:min 1] [:max 1]]]}] (string-context)))))) + (is (m/validate (m/constraint [:and [:min 1] [:max 1]] (string-context)) "a")) + (is (m/validate (m/schema [:string {:min 1 :max 1}]) "a")) + (is (m/validate (m/schema [:string {:and [[:min 1] [:max 1]]}]) "a")) + (is (not (m/validate (m/constraint [:and [:min 1] [:max 1]] (string-context)) ""))) + (is (= '({:path [], :in [], :schema [:min 1], :value "" :type ::m/count-limits}) + (errors (m/explain (m/constraint [:min 1] (string-context)) "")))) + (is (= '({:path [], :in [], :schema [:max 1], :value "12" :type ::m/count-limits}) + (errors (m/explain (m/constraint [:max 1] (string-context)) "12")))) + (is (= '({:path [], :in [], :schema [:and [:min 1] [:max 1]], :value "" :type ::m/count-limits}) + (errors (m/explain (m/constraint [:and [:min 1] [:max 1]] (string-context)) "")))) + (is (= [{:path [:malli.constraint/constraint], :in [], :schema [:min 5], :value "", :type ::m/count-limits}] + (errors (m/explain (m/schema [:string {:min 5}]) "")))) + (is (= [{:path [:malli.constraint/constraint], :in [], :schema [:max 1], :value "20", :type ::m/count-limits}] + (errors (m/explain (m/schema [:string {:max 1}]) "20")))) + ;; TODO should be :path [:malli.constraint/constraint 0] + (is (= [{:path [:malli.constraint/constraint], :in [], :schema [:and [:min 5] [:max 10]], :value "", :type ::m/count-limits}] + (errors (m/explain (m/schema [:string {:min 5 :max 10}]) "")) + (errors (m/explain (m/schema [:string {:and [[:min 5] [:max 10]]}]) "")))) + ;; TODO should be [:schema [:min 1]], :in [0] + (is (= [{:path [:malli.constraint/constraint], :in [], :schema [:and [:min 1] [:max 1]], :value "", :type ::m/count-limits}] + (errors (m/explain (m/schema [:string {:min 1 :max 1}]) "")) + (errors (m/explain (m/schema [:string {:and [[:min 1] [:max 1]]}]) "")))) + (is (= [{:path [:malli.constraint/constraint], :in [], :schema [:and [:min 1] [:max 1]], :value "", :type ::m/count-limits}] + (errors (m/explain (m/schema [:string {:and [[:min 1] [:max 1]]}]) "")))) + (is (= ["should be 1 character"] + (me/humanize (m/explain (m/schema [:string {:min 1 :max 1}]) "")) + (me/humanize (m/explain (m/schema [:string {:and [[:min 1] [:max 1]]}]) "")))) + (is (= ["should be at most 1 character"] + (me/humanize (m/explain (m/schema [:string {:and [[:max 1]]}]) "12")) + (me/humanize (m/explain (m/schema [:string {:max 1}]) "12"))))) diff --git a/test/malli/core_test.cljc b/test/malli/core_test.cljc index 8c4641381..efa25e177 100644 --- a/test/malli/core_test.cljc +++ b/test/malli/core_test.cljc @@ -4,6 +4,7 @@ [clojure.test.check.generators :as gen] [clojure.walk :as walk] [malli.core :as m] + [malli.constraint :as mc] [malli.edn :as edn] [malli.generator :as mg] [malli.error :as me] @@ -1452,7 +1453,8 @@ [:age 31]))) (testing "explain" - (let [expectations {"vector" (let [schema [:vector {:min 2, :max 3} int?]] + (let [expectations {"vector" (let [schema [:vector {:min 2, :max 3} int?] + constraint (-> schema m/schema mc/-get-constraint)] [[schema [1 2] nil] @@ -1465,19 +1467,22 @@ [schema [1] {:schema schema :value [1] - :errors [{:path [], :in [], :type ::m/limits, :schema schema, :value [1]}]}] + :errors [{:path [::mc/constraint], :in [], :type ::m/count-limits, + :schema constraint :value [1]}]}] [schema [1 2 3 4] {:schema schema :value [1 2 3 4] - :errors [{:path [], :in [], :type ::m/limits, :schema schema, :value [1 2 3 4]}]}] + :errors [{:path [::mc/constraint], :in [], :type ::m/count-limits, + :schema constraint :value [1 2 3 4]}]}] [schema [1 2 "3"] {:schema schema :value [1 2 "3"] :errors [{:path [0], :in [2], :schema int?, :value "3"}]}]]) - "sequential" (let [schema [:sequential {:min 2, :max 3} int?]] + "sequential" (let [schema [:sequential {:min 2, :max 3} int?] + constraint (-> schema m/schema mc/-get-constraint)] [[schema '(1 2) nil] @@ -1490,19 +1495,20 @@ [schema '(1) {:schema schema :value '(1) - :errors [{:path [], :in [], :type ::m/limits, :schema schema, :value '(1)}]}] + :errors [{:path [::mc/constraint], :in [], :type ::m/count-limits, :schema constraint, :value '(1)}]}] [schema '(1 2 3 4) {:schema schema :value '(1 2 3 4) - :errors [{:path [], :in [], :type ::m/limits, :schema schema, :value '(1 2 3 4)}]}] + :errors [{:path [::mc/constraint], :in [], :type ::m/count-limits, :schema constraint, :value '(1 2 3 4)}]}] [schema '(1 2 "3") {:schema schema :value '(1 2 "3") :errors [{:path [0], :in [2], :schema int?, :value "3"}]}]]) - "set" (let [schema [:set {:min 2, :max 3} int?]] + "set" (let [schema [:set {:min 2, :max 3} int?] + constraint (-> schema m/schema mc/-get-constraint)] [[schema #{1 2} nil] @@ -1515,12 +1521,14 @@ [schema #{1} {:schema schema :value #{1} - :errors [{:path [], :in [], :type ::m/limits, :schema schema, :value #{1}}]}] + :errors [{:path [::mc/constraint], :in [], :type ::m/count-limits, + :schema constraint :value #{1}}]}] [schema #{1 2 3 4} {:schema schema :value #{1 2 3 4} - :errors [{:path [], :in [], :type ::m/limits, :schema schema, :value #{1 2 3 4}}]}] + :errors [{:path [::mc/constraint], :in [], :type ::m/count-limits, + :schema constraint :value #{1 2 3 4}}]}] [schema #{1 2 "3"} {:schema schema diff --git a/test/malli/error_test.cljc b/test/malli/error_test.cljc index bcd55480e..f9727a2e7 100644 --- a/test/malli/error_test.cljc +++ b/test/malli/error_test.cljc @@ -543,7 +543,7 @@ (m/explain [1 2 :foo]) (me/humanize))))) -(deftest error-definion-lookup-test +(deftest error-definition-lookup-test (is (= {:foo ["should be an integer"]} (-> [:map [:foo :int]] diff --git a/test/malli/generator_test.cljc b/test/malli/generator_test.cljc index 3b618c982..3a154efdf 100644 --- a/test/malli/generator_test.cljc +++ b/test/malli/generator_test.cljc @@ -241,7 +241,8 @@ (testing "generator override" (testing "without generator" - (let [schema [:fn {:gen/fmap '(fn [_] (rand-int 10))} + (let [schema [:fn {:gen/return 5 + :gen/fmap '(fn [_] (rand-int 10))} '(fn [x] (<= 0 x 10))] generator (mg/generator schema)] (dotimes [_ 100] @@ -999,7 +1000,10 @@ (defn alphanumeric-char? [c] {:pre [(char? c)]} - (let [i (int c)] + (let [int (fn [c] + #?(:clj (int c) + :cljs (.charCodeAt c 0))) + i (int c)] (or (<= (int \a) i (int \z)) (<= (int \A) i (int \Z)) (<= (int \0) i (int \9))))) @@ -1009,28 +1013,29 @@ (every? alphanumeric-char? s)) (deftest string-gen-alphanumeric-test - (dotimes [seed 100] + (doseq [seed (range 100) + :let [options {:seed seed}]] (testing (pr-str seed) (testing "(and min (= min max))" (is (alphanumeric-string? (mg/generate [:string {:min 10, :max 10}] - {:seed seed})))) + options)))) (testing "(and min max)" (is (alphanumeric-string? (mg/generate [:string {:min 10, :max 20}] - {:seed seed})))) + options)))) (testing "min" (is (alphanumeric-string? (mg/generate [:string {:min 10}] - {:seed seed})))) + options)))) (testing "max" (is (alphanumeric-string? (mg/generate [:string {:max 20}] - {:seed seed})))) + options)))) (testing ":else" (is (alphanumeric-string? (mg/generate [:string {}] - {:seed seed}))))))) + options))))))) (deftest non-empty-vector-generator-test (is (= [:.+ [1]] diff --git a/test/malli/swagger_test.cljc b/test/malli/swagger_test.cljc index 62cb8a2f7..78d45b014 100644 --- a/test/malli/swagger_test.cljc +++ b/test/malli/swagger_test.cljc @@ -2,6 +2,7 @@ (:require [clojure.test :refer [deftest is testing]] [malli.core :as m] [malli.core-test] + malli.constraint [malli.swagger :as swagger] [malli.util :as mu]))