From 3b73f64d00e14593f9c47fd546eb32d159fe8a4c Mon Sep 17 00:00:00 2001 From: Tommi Reiman Date: Fri, 26 Jan 2024 15:10:33 +0200 Subject: [PATCH 1/6] guard! --- src/malli/core.cljc | 16 +++++++++------- src/malli/generator.cljc | 19 ++++++++++--------- 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/malli/core.cljc b/src/malli/core.cljc index 0d5e260ba..4b567f8e3 100644 --- a/src/malli/core.cljc +++ b/src/malli/core.cljc @@ -204,12 +204,13 @@ (defn -function-info [schema] (when (= (type schema) :=>) - (let [[input output] (-children schema) + (let [[input output guard] (-children schema) {:keys [min max]} (-regex-min-max input false)] (cond-> {:min min :arity (if (= min max) min :varargs) :input input :output output} + guard (assoc :guard guard) max (assoc :max max))))) (defn -group-by-arity! [infos] @@ -1750,15 +1751,16 @@ ^{:type ::into-schema} (reify AST - (-from-ast [parent {:keys [input output properties]} options] - (-into-schema parent properties [(from-ast input options) (from-ast output options)] options)) + (-from-ast [parent {:keys [input output guard properties]} options] + (-into-schema parent properties [(from-ast input options) (from-ast output options) guard] options)) IntoSchema (-type [_] :=>) (-type-properties [_]) (-into-schema [parent properties children {::keys [function-checker] :as options}] - (-check-children! :=> properties children 2 2) - (let [[input output :as children] (-vmap #(schema % options) children) - form (delay (-simple-form parent properties children -form 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)) cache (-create-cache options) ->checker (if function-checker #(function-checker % options) (constantly nil))] (when-not (#{:cat :catn} (type input)) @@ -1768,7 +1770,7 @@ AST (-to-ast [_ _] (cond-> {:type :=>, :input (ast input), :output (ast output)} - properties (assoc :properties properties))) + guard (assoc :guard guard), properties (assoc :properties properties))) Schema (-validator [this] (if-let [checker (->checker this)] diff --git a/src/malli/generator.cljc b/src/malli/generator.cljc index aee33d875..4e88fe8b3 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -561,25 +561,26 @@ ([?schema] (function-checker ?schema nil)) ([?schema {::keys [=>iterations] :or {=>iterations 100} :as options}] (let [schema (m/schema ?schema options) + -try (fn [f] (try (f) (catch #?(:clj Exception, :cljs js/Error) e e))) check (fn [schema] - (let [{:keys [input output]} (m/-function-info schema) + (let [{:keys [input output guard]} (m/-function-info schema) input-generator (generator input options) - output-validator (m/validator output options) - validate (fn [f args] (output-validator (apply f args)))] + validate (m/validator output options) + valid? (fn [f args] (as-> (apply f args) $ (and (validate $) (if guard (guard args $) true))))] (fn [f] - (let [{:keys [result shrunk]} (->> (prop/for-all* [input-generator] #(validate f %)) + (let [{:keys [result shrunk]} (->> (prop/for-all* [input-generator] #(valid? 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 (apply f smallest) (catch #?(:clj Exception, :cljs js/Error) e e))) - explain-output (when-not explain-input (m/explain output response))] + 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 explain-input (assoc ::explain-input explain-input) explain-output (assoc ::explain-output explain-output) - (ex-message result) (-> (update :result ex-message) - (dissoc :result-data)))))))))] + guard (assoc ::response response, ::guard explain-guard) + (ex-message result) (-> (update :result ex-message) (dissoc :result-data)))))))))] (condp = (m/type schema) :=> (check schema) :function (let [checkers (map #(function-checker % options) (m/-children schema))] From b3c5f2632ccdf12c7f860b7d4534ccbade3bd967 Mon Sep 17 00:00:00 2001 From: Tommi Reiman Date: Fri, 26 Jan 2024 15:25:43 +0200 Subject: [PATCH 2/6] test-it --- test/malli/core_test.cljc | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/test/malli/core_test.cljc b/test/malli/core_test.cljc index e440bb8e2..5fd8e9bea 100644 --- a/test/malli/core_test.cljc +++ b/test/malli/core_test.cljc @@ -2447,6 +2447,30 @@ :value invalid-f}]} (m/explain schema2 invalid-f)))) + (testing "guards" + (let [guard (fn [[x y] z] (> (+ x y) z)) + schema (m/schema + [:=> [:cat :int :int] :int 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}]}, + :output {:type :int}, + :guard guard} + (m/ast schema))) + + (is (= nil (m/explain schema valid))) + + (is (results= {:schema schema, + :value invalid + :errors [{:path [], + :in [], + :schema schema + :value invalid}]} + (m/explain schema invalid))))) + (testing "non-accumulating errors" (let [schema (m/schema [:tuple :int [:function [:=> [:cat :int] :int]]] From a644bfa45455c3379d7dd1e999c3a64d188b2dd0 Mon Sep 17 00:00:00 2001 From: Tommi Reiman Date: Sat, 27 Jan 2024 11:46:03 +0200 Subject: [PATCH 3/6] 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 From e34e1fbf6a6bc5b4f136e12b2fe2bd693ea974ea Mon Sep 17 00:00:00 2001 From: Tommi Reiman Date: Sat, 27 Jan 2024 18:50:10 +0200 Subject: [PATCH 4/6] finish it --- CHANGELOG.md | 12 ++++++ docs/function-schemas.md | 72 ++++++++++++++++++++++++++++++++--- src/malli/core.cljc | 10 ++++- src/malli/dev/pretty.cljc | 79 ++++++++++++++++++++++----------------- src/malli/generator.cljc | 16 ++++---- test/malli/core_test.cljc | 49 +++++++++++++++++------- 6 files changed, 175 insertions(+), 63 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 64a26b2c6..ea5432a6c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,18 @@ We use [Break Versioning][breakver]. The version numbers follow a `.` takes optional 3rd child, the guard schema validating vector of arguments and return value `[args ret]`. See [Function Guards](docs/function-schemas.md#function-guards) for more details. + +```clojure +;; function of arg:int -> ret:int, where arg < ret +[:=> + [:cat :int] + :int + [:fn (fn [[[arg] ret]] (< arg ret))]] +``` + ## 0.14.0 (2024-01-16) * Better development-time tooling diff --git a/docs/function-schemas.md b/docs/function-schemas.md index 5ca0ae5b3..10f283040 100644 --- a/docs/function-schemas.md +++ b/docs/function-schemas.md @@ -78,7 +78,10 @@ Examples of function definitions: [:=> [:catn [:x :int] [:xs [:+ :int]]] :int] - + +;; arg:int -> ret:int, arg > ret +[:=> [:cat :int] :int [:fn (fn [[arg] ret] (> arg ret))]] + ;; multi-arity function [:function [:=> [:cat :int] :int] @@ -156,6 +159,65 @@ Smallest failing invocation is `(str 0 0)`, which returns `"00"`, which is not a But, why `mg/function-checker` is not enabled by default? The reason is that it uses generartive testing, which is orders of magnitude slower than normal validation and requires an extra dependency to `test.check`, which would make `malli.core` much heavier. This would be expecially bad for CLJS bundle size. +### Function Guards + +`:=>` accepts optional third child, a guard schema that is used to validate a vector of function arguments and return value. + +```clojure +;; function schema of arg:int -> ret:int, where arg < ret +;; with generative function checking always enabled +(def input + [:cat :int] + :int + [:fn {:error/message "argument should be less than return"} + (fn [[[arg] ret]] (< arg ret))]] + {::m/function-checker mg/function-checker})) + +(m/explain input + :input {:type :cat + :children [{:type :int}]} + :output {:type :int} + :guard {:type :fn + :value (fn [[[arg] ret]] (< arg ret)) + :properties {:error/message "argument should be less than return"}}} + {::m/function-checker mg/function-checker}) +``` + ### Generating Functions We can also generate function implementations based on the function schemas. The generated functions check the function arity and arguments at runtime and return generated values. @@ -620,8 +682,8 @@ It's main entry points is `dev/start!`, taking same options as `mi/instrument!`. (m/=> plus1 [:=> [:cat :int] [:int {:max 6}]]) (dev/start!) -; =prints=> ..instrumented #'user/plus1 -; =prints=> started instrumentation +; malli: instrumented 1 function var +; malli: dev-mode started (plus1 "6") ; =throws=> :malli.core/invalid-input {:input [:cat :int], :args ["6"], :schema [:=> [:cat :int] [:int {:max 6}]]} @@ -636,8 +698,8 @@ It's main entry points is `dev/start!`, taking same options as `mi/instrument!`. ; => 7 (dev/stop!) -; =prints=> ..unstrumented #'user/plus1 -; =prints=> stopped instrumentation +; malli: unstrumented 1 function vars +; malli: dev-mode stopped ``` ## ClojureScript support diff --git a/src/malli/core.cljc b/src/malli/core.cljc index 6027bfe66..0d872620e 100644 --- a/src/malli/core.cljc +++ b/src/malli/core.cljc @@ -1752,7 +1752,8 @@ (reify AST (-from-ast [parent {:keys [input output guard properties]} options] - (-into-schema parent properties [(from-ast input options) (from-ast output options) guard] options)) + (-into-schema parent properties (cond-> [(from-ast input options) (from-ast output options)] + guard (conj (from-ast guard))) options)) IntoSchema (-type [_] :=>) (-type-properties [_]) @@ -1781,7 +1782,12 @@ (if (not (fn? x)) (conj acc (miu/-error path in this x)) (if-let [res (checker x)] - (conj acc (assoc (miu/-error path in this x) :check res)) + (let [{::keys [explain-input explain-output explain-guard]} res + res (dissoc res ::explain-input ::explain-output ::explain-guard) + {:keys [path in] :as error} (assoc (miu/-error path in this x) :check res) + -push (fn [acc i e] + (cond-> acc e (into (map #(assoc % :path (conj path i), :in in) (:errors e)))))] + (-> (conj acc error) (-push 0 explain-input) (-push 1 explain-output) (-push 2 explain-guard))) acc))) (let [validator (-validator this)] (fn explain [x in acc] diff --git a/src/malli/dev/pretty.cljc b/src/malli/dev/pretty.cljc index c153eb456..1c54fbd80 100644 --- a/src/malli/dev/pretty.cljc +++ b/src/malli/dev/pretty.cljc @@ -13,7 +13,7 @@ :width 80 :colors v/-dark-colors :unknown (fn [x] (when (m/schema? x) (m/form x))) - :throwing-fn-top-level-ns-names ["malli" "clojure" "malli"] + :throwing-fn-top-level-ns-names ["malli" "clojure" "malli" "nrepl"] ::me/mask-valid-values '...} options)))) @@ -28,7 +28,7 @@ (v/-print-doc printer))) (defn -ref-text [printer] - [:group "Reference should be one of the following:" :break :break + [:group "Reference should be one of the following" :break :break "- a qualified keyword, " (v/-visit [:ref :user/id] printer) :break "- a qualified symbol, " (v/-visit [:ref (symbol "'user" "id")] printer) :break "- a string, " (v/-visit [:ref "user/id"] printer) :break @@ -40,52 +40,63 @@ (defmethod v/-format ::m/explain [_ {:keys [schema] :as explanation} printer] {:body [:group - (v/-block "Value:" (v/-visit (me/error-value explanation printer) printer) printer) :break :break - (v/-block "Errors:" (v/-visit (me/humanize (me/with-spell-checking explanation)) printer) printer) :break :break - (v/-block "Schema:" (v/-visit schema printer) printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}) + (v/-block "Value" (v/-visit (me/error-value explanation printer) printer) printer) :break :break + (v/-block "Errors" (v/-visit (me/humanize (me/with-spell-checking explanation)) printer) printer) :break :break + (v/-block "Schema" (v/-visit schema printer) printer) :break :break + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}) (defmethod v/-format ::m/coercion [_ {:keys [explain]} printer] (v/format (m/-exception ::m/explain explain) printer)) (defmethod v/-format ::m/invalid-input [_ {:keys [args input fn-name]} printer] - {:body [:group - (v/-block "Invalid function arguments:" (v/-visit args printer) printer) :break :break - (v/-block "Function Var:" (v/-visit fn-name printer) printer) :break :break - (v/-block "Input Schema:" (v/-visit input printer) printer) :break :break - (v/-block "Errors:" (-explain input args printer) printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) + {:title "Invalid Function Input" + :body [:group + (v/-block "Invalid function arguments" (v/-visit args printer) printer) :break :break + (when fn-name [:span (v/-block "Function Var" (v/-visit fn-name printer) printer) :break :break]) + (v/-block "Input Schema" (v/-visit input printer) printer) :break :break + (v/-block "Errors" (-explain input args printer) printer) :break :break + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) (defmethod v/-format ::m/invalid-output [_ {:keys [value args output fn-name]} printer] - {:body [:group - (v/-block "Invalid function return value:" (v/-visit value printer) printer) :break :break - (v/-block "Function Var:" (v/-visit fn-name printer) printer) :break :break - (v/-block "Function arguments:" (v/-visit args printer) printer) :break :break - (v/-block "Output Schema:" (v/-visit output printer) printer) :break :break - (v/-block "Errors:" (-explain output value printer) printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) + {:title "Invalid Function Output" + :body [:group + (v/-block "Invalid function return value" (v/-visit value printer) printer) :break :break + (when fn-name [:span (v/-block "Function Var" (v/-visit fn-name printer) printer) :break :break]) + (v/-block "Function arguments" (v/-visit args printer) printer) :break :break + (v/-block "Output Schema" (v/-visit output printer) printer) :break :break + (v/-block "Errors" (-explain output value printer) printer) :break :break + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) + +(defmethod v/-format ::m/invalid-guard [_ {:keys [value args guard fn-name]} printer] + {:title "Function Guard Error" + :body [:group + (when fn-name [:span (v/-block "Function Var" (v/-visit fn-name printer) printer) :break :break]) + (v/-block "Guard arguments" (v/-visit [args value] printer) printer) :break :break + (v/-block "Guard Schema" (v/-visit guard printer) printer) :break :break + (v/-block "Errors" (-explain guard [args value] printer) printer) :break :break + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) (defmethod v/-format ::m/invalid-arity [_ {:keys [args arity schema fn-name]} printer] {:body [:group - (v/-block (str "Invalid function arity (" arity "):") (v/-visit args printer) printer) :break :break - (v/-block "Function Schema:" (v/-visit schema printer) printer) :break :break - #?(:cljs (v/-block "Function Var:" (v/-visit fn-name printer) printer)) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) + (v/-block (str "Invalid function arity (" arity ")") (v/-visit args printer) printer) :break :break + (v/-block "Function Schema" (v/-visit schema printer) printer) :break :break + #?(:cljs (v/-block "Function Var" (v/-visit fn-name printer) printer)) :break :break + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) (defmethod v/-format ::m/register-function-schema [_ {:keys [ns name schema _data key _exception]} printer] {:title "Error in registering a Function Schema" :body [:group - (v/-block "Function Var:" [:group - (v/-visit (symbol (str ns) (str name)) printer) - " (" (v/-visit key printer) ")"] printer) :break :break - (v/-block "Function Schema:" (v/-visit schema printer) printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) + (v/-block "Function Var" [:group + (v/-visit (symbol (str ns) (str name)) printer) + " (" (v/-visit key printer) ")"] printer) :break :break + (v/-block "Function Schema" (v/-visit schema printer) printer) :break :break + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]}) (defmethod v/-format ::m/invalid-ref [_ {:keys [ref]} printer] {:body [:group (v/-block "Invalid Reference" (v/-visit [:ref ref] printer) printer) :break :break (v/-block "Reason" (-ref-text printer) printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}) + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}) (defmethod v/-format ::m/invalid-schema [_ {:keys [schema form]} printer] (let [proposals (seq (me/-most-similar-to #{schema} schema (set (keys (mr/schemas m/default-registry)))))] @@ -95,7 +106,7 @@ (when proposals [:group (v/-block "Did you mean" (->> (for [proposal proposals] (v/-visit proposal printer)) (interpose :break)) printer) :break :break]) - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) (defmethod v/-format ::m/child-error [_ {:keys [type children properties] :as data} printer] (let [form (m/-raw-form type properties children) @@ -107,7 +118,7 @@ (v/-block "Reason" [:group "Schema has " (v/-visit size printer) (if (= 1 size) " child" " children") ", expected " (v/-visit constraints printer)] printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) (defmethod v/-format ::m/invalid-entry [_ {:keys [entry]} printer] (let [wrap (if (sequential? entry) vec vector) @@ -117,14 +128,14 @@ :body [:group (v/-block "Invalid Entry" (v/-visit entry printer) printer) :break :break (v/-block "Did you mean" (v/-visit example printer) printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) (defmethod v/-format ::m/duplicate-keys [_ {:keys [arr]} printer] (let [keys (->> arr (vec) (take-nth 2))] {:title "Schema Creation Error" :body [:group (v/-block "Duplicate Keys" (v/-visit keys printer) printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) (defmethod v/-format :malli.edn/var-parsing-not-supported [_ {:keys [string var]} printer] (let [parse (fn [string] @@ -144,7 +155,7 @@ ~string {:malli.edn/edamame-options {:regex true, :fn true, :var resolve}}) printer)] printer) :break :break - (v/-block "More information:" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) + (v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})) ;; ;; public api diff --git a/src/malli/generator.cljc b/src/malli/generator.cljc index 77fc0c9cf..16ac6fcbe 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -561,7 +561,7 @@ ([?schema] (function-checker ?schema nil)) ([?schema {::keys [=>iterations] :or {=>iterations 100} :as options}] (let [schema (m/schema ?schema options) - -try (fn [f] (try (f) (catch #?(:clj Exception, :cljs js/Error) e e))) + -try (fn [f] (try [(f) true] (catch #?(:clj Exception, :cljs js/Error) e [e false]))) check (fn [schema] (let [{:keys [input output guard]} (m/-function-info schema) input-generator (generator input options) @@ -574,13 +574,13 @@ smallest (-> shrunk :smallest first)] (when-not (true? result) (let [explain-input (m/explain input smallest) - 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) - explain-guard (assoc ::explain-guard explain-guard) + [result success] (when-not explain-input (-try (fn [] (apply f smallest)))) + explain-output (when (and success (not explain-input)) (m/explain output result)) + explain-guard (when (and success guard (not explain-output)) (m/explain guard [smallest result]))] + (cond-> (assoc shrunk ::m/result result) + explain-input (assoc ::m/explain-input explain-input) + explain-output (assoc ::m/explain-output explain-output) + explain-guard (assoc ::m/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 10922f15a..38db46708 100644 --- a/test/malli/core_test.cljc +++ b/test/malli/core_test.cljc @@ -2363,13 +2363,29 @@ (is (false? (m/validate schema2 (fn [x y] (str x y))))) (is (nil? (explain-times function-schema-validation-times schema2 (fn [x y] (unchecked-add x y))))) - (is (results= {:schema [:=> [:cat int? int?] int?] - :value single-arity - :errors [{:path [] - :in [] - :schema [:=> [:cat int? int?] int?] - :value single-arity}]} - (m/explain schema2 single-arity))) + + (testing "exception in execution causes single error to root schema path" + (is (results= {:schema [:=> [:cat int? int?] int?] + :value single-arity + :errors [{:path [] + :in [] + :schema [:=> [:cat int? int?] int?] + :value single-arity}]} + (m/explain schema2 single-arity)))) + + (testing "error in output adds error to child in path 1" + (let [f (fn [x y] (str x y))] + (is (results= {:schema [:=> [:cat int? int?] int?] + :value f + :errors [{:path [] + :in [] + :schema [:=> [:cat int? int?] int?] + :value f} + {:path [1] + :in [] + :schema int? + :value "00"}]} + (m/explain schema2 f))))) (is (= single-arity (m/decode schema2 single-arity mt/string-transformer))) @@ -2465,13 +2481,18 @@ (is (= nil (m/explain schema valid))) - (is (results= {:schema schema, - :value invalid - :errors [{:path [], - :in [], - :schema schema - :value invalid}]} - (m/explain schema invalid))) + (testing "error in guard adds error on path 2" + (is (results= {:schema schema, + :value invalid + :errors [{:path [], + :in [], + :schema schema + :value invalid} + {:path [2] + :in [] + :schema [:fn guard] + :value ['(0 0) 0]}]} + (m/explain schema invalid)))) (testing "instrument" (let [schema [:=> [:cat :int] :int [:fn (fn [[[arg] ret]] (< arg ret))]] From 7f727feff3e0e19245bf10c5d0eec909b202349c Mon Sep 17 00:00:00 2001 From: Tommi Reiman Date: Sat, 27 Jan 2024 18:55:40 +0200 Subject: [PATCH 5/6] doc --- docs/function-schemas.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/docs/function-schemas.md b/docs/function-schemas.md index 10f283040..10045574d 100644 --- a/docs/function-schemas.md +++ b/docs/function-schemas.md @@ -166,7 +166,7 @@ But, why `mg/function-checker` is not enabled by default? The reason is that it ```clojure ;; function schema of arg:int -> ret:int, where arg < ret ;; with generative function checking always enabled -(def input [:cat :int] @@ -175,10 +175,10 @@ But, why `mg/function-checker` is not enabled by default? The reason is that it (fn [[[arg] ret]] (< arg ret))]] {::m/function-checker mg/function-checker})) -(m/explain input Date: Sat, 27 Jan 2024 18:59:37 +0200 Subject: [PATCH 6/6] CHANGELOG --- CHANGELOG.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index ea5432a6c..329e26a37 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -26,6 +26,12 @@ Malli is in well matured [alpha](README.md#alpha). [:fn (fn [[[arg] ret]] (< arg ret))]] ``` +* **BREAKING**: `malli.generator/function-checker` returns explanations under new keys: + * `::mg/explain-input` -> `::m/explain-input` + * `::mg/explain-output` -> `::m/explain-output` + * new `::m/explain-guard` to return guard explanation, if any +* `m/explain` for `:=>` returns also errors for args, return and guard if they exist + ## 0.14.0 (2024-01-16) * Better development-time tooling