Merge pull request #1000 from metosin/fn-guard

Fn guard

CHANGELOG.md

@@ -14,6 +14,24 @@ We use [Break Versioning][breakver]. The version numbers follow a `<major>.<mino
 
 Malli is in well matured [alpha](README.md#alpha).
 
+## Unreleased
+
+* `:=>` 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))]]
+```
+
+* **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

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 arg<ret
+  (m/schema
+   [:=>
+    [: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 arg<ret (fn [x] (inc x)))
+; nil
+
+(m/explain arg<ret (fn [x] x))
+;{:schema ...
+; :value #object[user$eval19073$fn__19074],
+; :errors ({:path [],
+;           :in [],
+;           :schema ...,
+;           :value #object[user$eval19073$fn__19074],
+;           :check {:total-nodes-visited 1,
+;                   :result false,
+;                   :result-data nil,
+;                   :smallest [(0)],
+;                   :time-shrinking-ms 0,
+;                   :pass? false,
+;                   :depth 0,
+;                   :malli.core/result 0}},
+;          {:path [2],
+;           :in [],
+;           :schema [:fn
+;                    #:error{:message "argument should be less than return"}
+;                    (fn [[[arg] ret]] (< arg ret))],
+;           :value [(0) 0]})}
+
+(me/humanize *1)
+; ["invalid function" "argument should be less than return"]
+```
+
+Identical schema using the Schema AST syntax:
+
+```clojure
+(m/from-ast
+ {:type :=>
+  :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

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 (cond-> [(from-ast input options) (from-ast output options)]
+                                        guard (conj (from-ast 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 [[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))
@@ -1768,7 +1770,7 @@
           AST
           (-to-ast [_ _]
             (cond-> {:type :=>, :input (ast input), :output (ast output)}
-              properties (assoc :properties properties)))
+              guard (assoc :guard (ast guard)), properties (assoc :properties properties)))
           Schema
           (-validator [this]
             (if-let [checker (->checker this)]
@@ -1780,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]
@@ -2582,19 +2589,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)]
@@ -2604,9 +2611,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))))