Skip to content

Commit

Permalink
guard schema
Browse files Browse the repository at this point in the history
  • Loading branch information
@ikitommi
ikitommi committed Jan 27, 2024
1 parent b3c5f26 commit a644bfa
Show file tree
Hide file tree
Showing 3 changed files with 39 additions and 25 deletions.
24 changes: 12 additions & 12 deletions src/malli/core.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand All @@ -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)]
Expand Down Expand Up @@ -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)]
Expand All @@ -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))))
Expand Down
17 changes: 9 additions & 8 deletions src/malli/generator.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
23 changes: 18 additions & 5 deletions test/malli/core_test.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand All @@ -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
Expand Down

0 comments on commit a644bfa

Please sign in to comment.