From a644bfa45455c3379d7dd1e999c3a64d188b2dd0 Mon Sep 17 00:00:00 2001 From: Tommi Reiman Date: Sat, 27 Jan 2024 11:46:03 +0200 Subject: [PATCH] guard schema --- src/malli/core.cljc | 24 ++++++++++++------------ src/malli/generator.cljc | 17 +++++++++-------- test/malli/core_test.cljc | 23 ++++++++++++++++++----- 3 files changed, 39 insertions(+), 25 deletions(-) diff --git a/src/malli/core.cljc b/src/malli/core.cljc index 4b567f8e3..6027bfe66 100644 --- a/src/malli/core.cljc +++ b/src/malli/core.cljc @@ -1758,9 +1758,8 @@ (-type-properties [_]) (-into-schema [parent properties children {::keys [function-checker] :as options}] (-check-children! :=> properties children 2 3) - (let [-vmapc (fn [f c] (cond-> (-vmap f (take 2 c)) (= 3 (count c)) (conj (last c)))) - [input output guard :as children] (-vmapc #(schema % options) children ) - form (delay (-create-form (-type parent) properties (-vmapc -form children) options)) + (let [[input output guard :as children] (-vmap #(schema % options) children) + form (delay (-create-form (-type parent) properties (-vmap -form children) options)) cache (-create-cache options) ->checker (if function-checker #(function-checker % options) (constantly nil))] (when-not (#{:cat :catn} (type input)) @@ -1770,7 +1769,7 @@ AST (-to-ast [_ _] (cond-> {:type :=>, :input (ast input), :output (ast output)} - guard (assoc :guard guard), properties (assoc :properties properties))) + guard (assoc :guard (ast guard)), properties (assoc :properties properties))) Schema (-validator [this] (if-let [checker (->checker this)] @@ -2584,19 +2583,19 @@ | key | description | | ----------|-------------| | `:schema` | function schema - | `:scope` | optional set of scope definitions, defaults to `#{:input :output}` + | `:scope` | optional set of scope definitions, defaults to `#{:input :output :guard}` | `:report` | optional side-effecting function of `key data -> any` to report problems, defaults to `m/-fail!` | `:gen` | optional function of `schema -> schema -> value` to be invoked on the args to get the return value" ([props] (-instrument props nil nil)) ([props f] (-instrument props f nil)) - ([{:keys [scope report gen] :or {scope #{:input :output}, report -fail!} :as props} f options] + ([{:keys [scope report gen] :or {scope #{:input :output :guard}, report -fail!} :as props} f options] (let [schema (-> props :schema (schema options))] (case (type schema) - :=> (let [{:keys [min max input output]} (-function-info schema) - [validate-input validate-output] (-vmap validator [input output]) - [wrap-input wrap-output] (-vmap (partial contains? scope) [:input :output]) + :=> (let [{:keys [min max input output guard]} (-function-info schema) + [validate-input validate-output validate-guard] (-vmap validator [input output (or guard :any)]) + [wrap-input wrap-output wrap-guard] (-vmap #(contains? scope %) [:input :output :guard]) f (or (if gen (gen schema) f) (-fail! ::missing-function {:props props}))] (fn [& args] (let [args (vec args), arity (count args)] @@ -2606,9 +2605,10 @@ (when-not (validate-input args) (report ::invalid-input {:input input, :args args, :schema schema}))) (let [value (apply f args)] - (when wrap-output - (when-not (validate-output value) - (report ::invalid-output {:output output, :value value, :args args, :schema schema}))) + (when (and wrap-output (not (validate-output value))) + (report ::invalid-output {:output output, :value value, :args args, :schema schema})) + (when (and wrap-guard (not (validate-guard [args value]))) + (report ::invalid-guard {:guard guard, :value value, :args args, :schema schema})) value)))) :function (let [arity->info (->> (children schema) (map (fn [s] (assoc (-function-info s) :f (-instrument (assoc props :schema s) f options)))) diff --git a/src/malli/generator.cljc b/src/malli/generator.cljc index 4e88fe8b3..77fc0c9cf 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -565,21 +565,22 @@ check (fn [schema] (let [{:keys [input output guard]} (m/-function-info schema) input-generator (generator input options) - validate (m/validator output options) - valid? (fn [f args] (as-> (apply f args) $ (and (validate $) (if guard (guard args $) true))))] + valid-output? (m/validator output options) + valid-guard? (if guard (m/validator guard options) (constantly true)) + validate (fn [f args] (as-> (apply f args) $ (and (valid-output? $) (valid-guard? [args $]))))] (fn [f] - (let [{:keys [result shrunk]} (->> (prop/for-all* [input-generator] #(valid? f %)) + (let [{:keys [result shrunk]} (->> (prop/for-all* [input-generator] #(validate f %)) (check/quick-check =>iterations)) smallest (-> shrunk :smallest first)] (when-not (true? result) (let [explain-input (m/explain input smallest) - response (when-not explain-input (-try (fn [] (apply f smallest)))) - explain-output (when-not explain-input (m/explain output response)) - explain-guard (when guard (-try (fn [] (guard smallest response))))] - (cond-> shrunk + result (when-not explain-input (-try (fn [] (apply f smallest)))) + explain-output (when-not explain-input (m/explain output result)) + explain-guard (when (and guard (not explain-input)) (m/explain guard [smallest result]))] + (cond-> (assoc shrunk ::result result) explain-input (assoc ::explain-input explain-input) explain-output (assoc ::explain-output explain-output) - guard (assoc ::response response, ::guard explain-guard) + explain-guard (assoc ::explain-guard explain-guard) (ex-message result) (-> (update :result ex-message) (dissoc :result-data)))))))))] (condp = (m/type schema) :=> (check schema) diff --git a/test/malli/core_test.cljc b/test/malli/core_test.cljc index 5fd8e9bea..10922f15a 100644 --- a/test/malli/core_test.cljc +++ b/test/malli/core_test.cljc @@ -2448,17 +2448,19 @@ (m/explain schema2 invalid-f)))) (testing "guards" - (let [guard (fn [[x y] z] (> (+ x y) z)) + (let [guard (fn [[[x y] z]] (> (+ x y) z)) schema (m/schema - [:=> [:cat :int :int] :int guard] + [:=> [:cat :int :int] :int [:fn guard]] {::m/function-checker mg/function-checker}) valid (fn [x y] (dec (+ x y))) invalid (fn [x y] (+ x y))] (is (= {:type :=>, - :input {:type :cat, :children [{:type :int} {:type :int}]}, + :input {:type :cat + :children [{:type :int} {:type :int}]}, :output {:type :int}, - :guard guard} + :guard {:type :fn + :value guard}} (m/ast schema))) (is (= nil (m/explain schema valid))) @@ -2469,7 +2471,18 @@ :in [], :schema schema :value invalid}]} - (m/explain schema invalid))))) + (m/explain schema invalid))) + + (testing "instrument" + (let [schema [:=> [:cat :int] :int [:fn (fn [[[arg] ret]] (< arg ret))]] + fn (m/-instrument {:schema schema} (fn [x] (* x x)))] + + (is (= 4 (fn 2))) + + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli.core/invalid-guard" + (fn 0))))))) (testing "non-accumulating errors" (let [schema (m/schema