From 96c19c51c8a294454b4323f8736f84252a3044b8 Mon Sep 17 00:00:00 2001 From: Ambrose Bonnaire-Sergeant Date: Wed, 1 May 2024 18:46:37 -0500 Subject: [PATCH] polymorphic schemas --- docs/function-schemas.md | 57 ++++- src/malli/clj_kondo.cljc | 2 + src/malli/core.cljc | 337 +++++++++++++++++++++++++-- src/malli/experimental.cljc | 52 +++-- src/malli/experimental/describe.cljc | 1 + src/malli/generator.cljc | 36 ++- src/malli/json_schema.cljc | 1 + test/malli/core_test.cljc | 39 ++++ test/malli/experimental_test.clj | 59 ++++- test/malli/generator_debug.cljc | 1 + test/malli/generator_test.cljc | 33 +++ 11 files changed, 574 insertions(+), 44 deletions(-) diff --git a/docs/function-schemas.md b/docs/function-schemas.md index b8bb63948..22bdbb5d8 100644 --- a/docs/function-schemas.md +++ b/docs/function-schemas.md @@ -7,7 +7,9 @@ * [Function Guards](#function-guards) * [Generating Functions](#generating-functions) * [Multi-arity Functions](#multi-arity-functions) + * [Polymorphic Functions](#polymorphic-functions) * [Instrumentation](#instrumentation) + * [Instrumentation of Polymorphic Functions](#instrumentation-of-polymorphic-functions) * [Defn Schemas](#defn-schemas) * [Defining Function Schemas](#defining-function-schemas) * [Function Schema Annotations](#function-schema-annotations) @@ -21,6 +23,7 @@ * [Pretty Errors](#pretty-errors) * [Defn Schemas via metadata](#defn-schemas-via-metadata) * [TL;DR](#tldr) +* [Polymorphic Functions](#polymorphic-schemas) ## Functions @@ -64,7 +67,7 @@ Enter, function schemas. ## Function Schemas -Function values can be described with `:=>` and `:function` schemas. They allows description of both function arguments (as [sequence schemas](https://github.com/metosin/malli#sequence-schemas)) and function return values. +Function values can be described with `:=>`, `:function`, and `m/all` schemas. They allow descriptions of both function arguments (as [sequence schemas](https://github.com/metosin/malli#sequence-schemas)) and function return values. Examples of function definitions: @@ -87,9 +90,19 @@ Examples of function definitions: [:function [:=> [:cat :int] :int] [:=> [:cat :int :int [:* :int]] :int]] + +;; polymorphic identity function +(m/all [a] [:=> [:cat a] a]) + +;; polymorphic map function +(m/all [a b] + [:=> [:cat + [:=> [:cat a] b] + [:sequential a]] + [:sequential b]]) ``` -Function definition for the `plus` looks like this: +The schema for `plus` looks like this: ```clojure (def =>plus [:=> [:cat :int :int] :int]) @@ -313,11 +326,29 @@ Generating multi-arity functions: ; => -2326 ``` +### Polymorphic Functions + +A polymorphic function using `m/all` is generatively tested by instantiating schema variables with small schemas. + +For example, the polymorphic identity schema + +```clojure +(m/all [a] [:=> [:cat a] a]) +``` + +is generatively tested with schemas like + +```clojure +[:=> [:cat :nil] :nil] +[:=> [:cat [:enum 50]] [:enum 50]] +[:=> [:cat [:enum 5333344553]] [:enum 5333344553]] +``` + ### Instrumentation Besides testing function schemas as values, we can also instrument functions to enable runtime validation of arguments and return values. -Simplest way to do this is to use `m/-instrument` which takes an options map and a function and returns an instrumented function. Valid options include: +The simplest way to do this is to use `m/-instrument` which takes an options map and a function and returns an instrumented function. Valid options include: | key | description | | ----------|-------------| @@ -391,6 +422,26 @@ With `:gen` we can omit the function body. Here's an example to generate random ; =throws=> :malli.core/invalid-arity {:arity 3, :arities #{1 2}, :args (10 20 30), :input nil, :schema [:function [:=> [:cat :int] [:int {:max 6}]] [:=> [:cat :int :int] [:int {:max 6}]]]} ``` +### Instrumentation of Polymorphic Functions + +A polymorphic function will be instrumented as if all its schema variables were instantiated with +their upper bounds, usually `:any`. The instrumented schema is calculated via `m/deref`. + +Schema variables by default do not allow regex splicing, so instantiations are wrapped in `:schema`. + +```clojure +(-> (m/all [a] [:=> [:cat a] a]) m/deref) +;=> [:=> [:cat [:schema :any]] [:schema :any]] + +(def options {:registry (mr/composite-registry m/default-registry (mu/schemas))}) + +(-> (m/all [[M [:maybe :map]] X] [:=> [:cat M X] [:merge M [:map [:x X]]]]) + (m/schema options) + m/deref) +;=> [:=> [:cat [:schema [:maybe :map]] [:schema :any]] +; [:merge [:schema [:maybe :map]] [:map [:x [:schema :any]]]]] +``` + ## Defn Schemas ### Defining Function Schemas diff --git a/src/malli/clj_kondo.cljc b/src/malli/clj_kondo.cljc index 96971bd38..c89463559 100644 --- a/src/malli/clj_kondo.cljc +++ b/src/malli/clj_kondo.cljc @@ -106,6 +106,7 @@ (defmethod accept :fn [_ _ _ _] :any) (defmethod accept :ref [_ _ _ _] :any) ;;?? (defmethod accept :=> [_ _ _ _] :fn) +(defmethod accept :all [_ schema _ options] (transform (m/deref schema) options)) (defmethod accept :function [_ _ _ _] :fn) (defmethod accept :schema [_ schema _ options] (transform (m/deref schema) options)) @@ -171,6 +172,7 @@ (defn from [{:keys [schema ns name]}] (let [ns-name (-> ns str symbol) + schema (cond-> schema (= :all (m/type schema)) m/deref) schema (if (= :function (m/type schema)) schema (m/into-schema :function nil [schema] (m/options schema)))] (reduce (fn [acc schema] diff --git a/src/malli/core.cljc b/src/malli/core.cljc index 149b6f7ec..c3c997b67 100644 --- a/src/malli/core.cljc +++ b/src/malli/core.cljc @@ -1,7 +1,7 @@ (ns malli.core (:refer-clojure :exclude [eval type -deref deref -lookup -key assert]) #?(:cljs (:require-macros malli.core)) - (:require #?(:clj [clojure.walk :as walk]) + (:require [clojure.walk :as walk] [clojure.core :as c] [malli.impl.regex :as re] [malli.impl.util :as miu] @@ -14,7 +14,7 @@ (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) + parser unparser ast from-ast inst) ;; ;; protocols and records @@ -86,6 +86,10 @@ (-regex-transformer [this transformer method options] "returns the raw internal regex transformer implementation") (-regex-min-max [this nested?] "returns size of the sequence as {:min min :max max}. nil max means unbounded. nested? is true when this schema is nested inside an outer regex schema.")) +(defprotocol AllSchema + (-bounds [this] "return a vector of maps describing the binder") + (-inst [this schemas] "replace variables in polymorphic schema with schemas")) + (defn -ref-schema? [x] (#?(:clj instance?, :cljs implements?) malli.core.RefSchema x)) (defn -entry-parser? [x] (#?(:clj instance?, :cljs implements?) malli.core.EntryParser x)) (defn -entry-schema? [x] (#?(:clj instance?, :cljs implements?) malli.core.EntrySchema x)) @@ -2096,7 +2100,7 @@ (-parent (schema ?schema options)))) (defn walk - "Postwalks recursively over the Schema and it's children. + "Postwalks recursively over the Schema and its children. The walker callback is a arity4 function with the following arguments: schema, path, (walked) children and options." ([?schema f] @@ -2490,6 +2494,284 @@ :re-transformer (fn [_ children] (apply re/alt-transformer children)) :re-min-max (fn [_ children] (reduce -re-alt-min-max {:max 0} (-vmap last children)))})}) +(defn- -all-binder-bounds [binder] + (into [] (map (fn [b] + (if (simple-ident? b) + {:kind :Schema + :default :any + :lower nil + :upper :any} + (if (and (vector? b) + (= 2 (count b)) + (simple-ident? (first b))) + {:kind :Schema + :default (second b) + :lower nil + :upper (second b)} + (if (and (map? b) + (simple-ident? (:name b))) + (dissoc b :name) + (-fail! ::invalid-all-binder {:binder binder})))))) + binder)) + +(defn- -visit-binder-names [binder f] + (mapv (fn [b] + (if (simple-ident? b) + (f b) + (if (and (vector? b) + (= 2 (count b)) + (simple-ident? (first b))) + (update b 0 f) + (if (and (map? b) + (simple-ident? (:name b))) + (update b :name f) + (-fail! ::invalid-all-binder {:binder binder}))))) + binder)) + +(defn -all-binder-names [binder] + (let [vol (volatile! [])] + (-visit-binder-names binder #(do (vswap! vol conj %) %)) + @vol)) + +(defn- -find-allowed-kw [base vforbidden] + (if-not (@vforbidden base) + base + (loop [i 0] + (let [base (keyword (str (name base) i))] + (if-not (@vforbidden base) + (do (vswap! vforbidden conj base) + base) + (recur (inc i))))))) + +(defn- -alpha-rename [s vforbidden options] + (let [inner (fn [this s path options] + (case (type s) + :all (-alpha-rename s vforbidden options) + (-walk s this path options))) + outer (fn [s path children options] + (case (type s) + ::val (first children) + (-set-children s children))) + walk (fn [s] + (inner + (reify Walker + (-accept [_ s path options] true) + (-inner [this s path options] (inner this s path options)) + (-outer [_ schema path children options] + (outer schema path children options))) + s + [] + (assoc options + ::walk-refs false + ::walk-schema-refs false + ::walk-entry-vals true))) + [binder body] (-children s) + names (-all-binder-names binder) + bounds (-all-binder-bounds binder) + renames (into {} (map (fn [n] + [n (-find-allowed-kw n vforbidden)])) + names) + binder (-visit-binder-names binder renames) + defaults (into {} (map-indexed + (fn [i n] + (let [{:keys [default]} (nth bounds i) + rename (renames n)] + [n (form + (-update-properties + (schema default options) + #(assoc % ::alpha-rename rename)) + options)]))) + names) + invert (into {} (map (fn [[k v]] + [v (renames k)])) + defaults) + body (-> body + (->> (walk/postwalk-replace defaults)) + (schema options) + walk + (form options) + (->> (walk/postwalk-replace invert)))] + (schema [:all binder body] options))) + +(defn- -inst* [binder body insts options] + (when-not (= (count insts) + (count binder)) + (-fail! ::wrong-number-of-schemas-to-inst + {:binder binder :schemas insts})) + (let [kws (-all-binder-names binder) + bounds (-all-binder-bounds binder) + insts (mapv (fn [bound s] + ;;TODO regex kinds like [:* :Schema] that allow splicing schemas like + ;; [:all [[Xs [:* :Schema]]] [:=> [:cat Xs] :any]] + ;; which can instantiate to [:=> [:cat [:* :int] :any]] rather than just + ;; [:=> [:cat [:schema [:* :int]] :any]] + (case (:kind bound) + :Schema (let [{:keys [upper lower]} bound + s (form s options) + upper (form upper options)] + (when (some? lower) + (-fail! ::nyi-lower-bounds)) + (form + [:schema ;;disallow regex splicing + (if (or (= s upper) + (= :any upper)) + s + [:and s upper])] + options)))) + bounds insts) + vforbidden-kws (volatile! (set kws)) + _ (walk/postwalk (fn [v] + (when (keyword? v) + (vswap! vforbidden-kws conj v)) + v) + insts) + [binder body] (-> [:all binder body] + (schema options) + (-alpha-rename vforbidden-kws options) + -children) + kws (-all-binder-names binder)] + (-> (walk/postwalk-replace (zipmap kws insts) body) + (schema options)))) + +(defn -all-binder-defaults [binder] + (mapv :default (-all-binder-bounds binder))) + +(defn -all-schema [_] + ^{:type ::into-schema} + (reify IntoSchema + (-type [_] :all) + (-type-properties [_]) + (-properties-schema [_ _]) + (-children-schema [_ _]) + (-into-schema [parent properties children {::keys [function-checker] :as options}] + (-check-children! :all properties children 2 2) + (let [[binder body] children + form (delay (-simple-form parent properties children identity options)) + children [binder body] + cache (-create-cache options) + self-inst (delay (inst [:all binder body] options)) + ->checker (if function-checker #(function-checker % options) (constantly nil))] + ^{:type ::schema} + (reify + Schema + (-validator [this] + (if-let [checker (->checker this)] + (let [validator (fn [x] (nil? (checker x)))] + (fn [x] (and (ifn? x) (validator x)))) + ifn?)) + (-explainer [this path] + (if-let [checker (->checker this)] + (fn explain [x in acc] + (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)) + acc))) + (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)))) + (-unparser [this] (-parser this)) + (-transformer [_ _ _ _]) + (-walk [this walker path options] (-walk-leaf this walker path options)) + (-properties [_] properties) + (-options [_] options) + (-children [_] children) + (-parent [_] parent) + (-form [_] @form) + AllSchema + (-bounds [_] (-all-binder-bounds binder)) + (-inst [_ insts] (-inst* binder body (or insts (-all-binder-defaults binder)) options)) + Cached + (-cache [_] cache) + LensSchema + (-keep [_]) + (-get [_ key default] (get children key default)) + (-set [this key value] (-set-assoc-children this key value)) + RefSchema + (-ref [_]) + (-deref [_] @self-inst)))))) + + +(defn- -find-kws [vol form] + (walk/postwalk (fn [v] + (when (simple-keyword? v) + (vswap! vol conj v)) + v) + form)) + +(defn- -rename-all-binder [forbidden-kws binder] + (-visit-binder-names + binder + (fn [k] + (if (@forbidden-kws k) + (loop [i 0] + (let [k' (keyword (str (name k) i))] + (if (@forbidden-kws k') + (recur (inc i)) + (do (vswap! forbidden-kws conj k') + k')))) + k)))) + +(defn -all-form [binder body] + (let [nbound (count binder) + binder (-visit-binder-names binder (fn [k] + (when-not (simple-symbol? k) + (-fail! ::binder-must-use-simple-symbols {:k k})) + (keyword k))) + forbidden-kws (doto (volatile! #{}) + (-find-kws (apply body (repeatedly nbound random-uuid)))) + binder (-rename-all-binder forbidden-kws binder) + body (apply body (-all-binder-names binder))] + [:all binder body])) + +#?(:clj + (defmacro all + "Children of :all are read-only. Only construct an :all with this macro. + Children will not be walked. + + The only public interface for :all is inst and -bounds. + + Treat type variables as opaque variables in body. i.e., only pass them around, + don't inspect or test them. + + Use deref to instantiate the body with each type variable's upper bounds." + [binder body] + (let [bv (mapv (fn [b] + (if (symbol? b) + b + (if (vector? b) + (first b) + (if (map? b) + (:name b) + (-fail! ::bad-all-binder {:binder binder}))))) + binder)] + `(-all-form '~binder (fn ~bv ~body))))) + +(defn -quoted [[q v :as l]] + (when-not (and (seq? l) + (= 2 (count l)) + (= 'quote (first l))) + (-fail! ::children-of-all-schema-must-be-quoted + {:l l})) + (second v)) + +(defn -binder [all] + (first (-children all))) + +(defn inst + "Instantiate an :all schema with a vector of schemas. If a schema + is nil, its upper bound will be used. If ?schemas is nil or not provided, same as + vector of nils. ?schemas-or-options are treated as options if map?, otherwise ?schemas." + ([?all] (inst ?all nil nil)) + ([?all ?schemas-or-options] (let [options? (map? ?schemas-or-options) + ?schemas (when-not options? ?schemas-or-options) + options (when options? ?schemas-or-options)] + (inst ?all ?schemas options))) + ([?all insts options] (-inst (schema ?all options) insts))) + (defn base-schemas [] {:and (-and-schema) :or (-or-schema) @@ -2508,6 +2790,7 @@ :fn (-fn-schema) :ref (-ref-schema) :=> (-=>-schema) + :all (-all-schema nil) :function (-function-schema nil) :schema (-schema-schema nil) ::schema (-schema-schema {:raw true})}) @@ -2552,7 +2835,12 @@ ([?schema] (function-schema ?schema nil)) ([?schema options] (let [s (schema ?schema options), t (type s)] - (if (#{:=> :function} t) s (-fail! ::invalid-=>schema {:type t, :schema s}))))) + (if (= :all t) + (let [d (deref s)] + (when (= :all (type d)) + (-fail! ::infinite-loop {:s s :d d})) + (function-schema d options)) + (if (#{:=> :function} t) s (-fail! ::invalid-=>schema {:type t, :schema s})))))) ;; for cljs we cannot invoke `function-schema` at macroexpansion-time ;; - `?schema` could contain cljs vars that will only resolve at runtime. @@ -2565,24 +2853,26 @@ (-fail! ::register-function-schema {:ns ns, :name name, :schema ?schema, :data data, :key key, :exception ex}))))) #?(:clj - (defmacro => [given-sym value] - (let [cljs-resolve (when (:ns &env) (ns-resolve 'cljs.analyzer.api 'resolve)) - cljs-resolve-symbols (fn [env d] - (walk/postwalk (fn [x] (cond->> x (symbol? x) (or (:name (cljs-resolve env x))))) - d)) - name-str (name given-sym) - ns-str (str (or (not-empty (namespace given-sym)) *ns*)) - name' `'~(symbol name-str) - ns' `'~(symbol ns-str) - sym `'~(symbol ns-str name-str) - value' (cond->> value (:ns &env) (cljs-resolve-symbols &env))] - ;; in cljs we need to register the schema in clojure (the cljs compiler) - ;; so it is visible in the (function-schemas :cljs) map at macroexpansion time. - (if (:ns &env) - (do - (-register-function-schema! (symbol ns-str) (symbol name-str) value' (meta given-sym) :cljs identity) - `(do (-register-function-schema! ~ns' ~name' ~value' ~(meta given-sym) :cljs identity) ~sym)) - `(do (-register-function-schema! ~ns' ~name' ~value' ~(meta given-sym)) ~sym))))) + (defmacro => + ([given-sym value] `(=> ~given-sym ~value nil)) + ([given-sym value options] + (let [cljs-resolve (when (:ns &env) (ns-resolve 'cljs.analyzer.api 'resolve)) + cljs-resolve-symbols (fn [env d] + (walk/postwalk (fn [x] (cond->> x (symbol? x) (or (:name (cljs-resolve env x))))) + d)) + name-str (name given-sym) + ns-str (str (or (not-empty (namespace given-sym)) *ns*)) + name' `'~(symbol name-str) + ns' `'~(symbol ns-str) + sym `'~(symbol ns-str name-str) + value' (cond->> value (:ns &env) (cljs-resolve-symbols &env))] + ;; in cljs we need to register the schema in clojure (the cljs compiler) + ;; so it is visible in the (function-schemas :cljs) map at macroexpansion time. + (if (:ns &env) + (do + (-register-function-schema! (symbol ns-str) (symbol name-str) value' (meta given-sym) :cljs identity) + `(do (-register-function-schema! ~ns' ~name' ~value' ~(meta given-sym) :cljs #(schema % ~options)) ~sym)) + `(do (-register-function-schema! ~ns' ~name' ~value' ~(meta given-sym) :clj #(function-schema (schema % ~options))) ~sym)))))) (defn -instrument "Takes an instrumentation properties map and a function and returns a wrapped function, @@ -2633,4 +2923,5 @@ (cond info (apply (:f info) args) varargs-info (if (< arity (:min varargs-info)) (report-arity) (apply (:f varargs-info) args)) - :else (report-arity)))))))))) + :else (report-arity)))))) + :all (recur (assoc props :schema (deref schema options)) f options))))) diff --git a/src/malli/experimental.cljc b/src/malli/experimental.cljc index dbf7f137c..c238c81dd 100644 --- a/src/malli/experimental.cljc +++ b/src/malli/experimental.cljc @@ -18,7 +18,13 @@ [:args "Args"] [:prepost [:? "PrePost"]] [:body [:* :any]]] + "Binder" [:vector [:or + simple-symbol? + [:tuple simple-symbol? "Schema"]]] "Params" [:catn + [:poly [:? [:catn + [:all [:enum :all :for-all]] + [:binder "Binder"]]]] [:name symbol?] [:return [:? [:catn [:- "Separator"] @@ -36,7 +42,7 @@ (def Params (-schema false)) (c/defn -defn [schema args] - (let [{:keys [name return doc arities] body-meta :meta :as parsed} (m/parse schema args) + (let [{:keys [name poly return doc arities] body-meta :meta :as parsed} (m/parse schema args) var-meta (meta name) _ (when (= ::m/invalid parsed) (m/-fail! ::parse-error {:schema schema, :args args})) parse (fn [{:keys [args] :as parsed}] (merge (md/parse args) parsed)) @@ -45,23 +51,37 @@ parglists (if single (->> arities val parse vector) (->> arities val :arities (map parse))) raw-arglists (map :raw-arglist parglists) schema (as-> (map ->schema parglists) $ (if single (first $) (into [:function] $))) + schema (if poly + `(m/all ~(:binder poly) ~schema) + schema) bodies (map (fn [{:keys [arglist prepost body]}] `(~arglist ~prepost ~@body)) parglists) validate? (or (:malli/always var-meta) (:malli/always body-meta)) - enriched-meta (assoc body-meta :raw-arglists (list 'quote raw-arglists) :schema schema)] - `(let [defn# ~(if validate? - `(def - ~(with-meta name (merge var-meta - enriched-meta - {:arglists (list 'quote (map :arglist parglists))})) - ~@(some-> doc vector) - (m/-instrument {:schema ~schema} (fn ~(gensym (str name "-instrumented")) ~@bodies))) - `(c/defn - ~name - ~@(some-> doc vector) - ~enriched-meta - ~@bodies - ~@(when-not single (some->> arities val :meta vector))))] - (m/=> ~name ~schema) + goptions (gensym 'options) + options (::m/options body-meta) + gschema (gensym 'schema) + enriched-meta (assoc body-meta :raw-arglists (list 'quote raw-arglists) :schema gschema ::m/options goptions) + let-around-def (if poly + `[~(m/-all-binder-names (:binder poly)) (m/-all-binder-defaults (second ~gschema))] + [])] + (when (some #{name} let-around-def) + (throw (ex-info ":all binder must not bind the same name as the var being defined" {}))) + `(let [~gschema ~schema + ~goptions ~options + defn# (let ~let-around-def + ~(if validate? + `(def + ~(with-meta name (merge var-meta + enriched-meta + {:arglists (list 'quote (map :arglist parglists))})) + ~@(some-> doc vector) + (m/-instrument {:schema ~gschema} (fn ~(gensym (str name "-instrumented")) ~@bodies) ~goptions)) + `(c/defn + ~name + ~@(some-> doc vector) + ~enriched-meta + ~@bodies + ~@(when-not single (some->> arities val :meta vector)))))] + (m/=> ~name ~schema ~goptions) defn#))) ;; diff --git a/src/malli/experimental/describe.cljc b/src/malli/experimental/describe.cljc index 6c6cbc5e6..2450ebf15 100644 --- a/src/malli/experimental/describe.cljc +++ b/src/malli/experimental/describe.cljc @@ -196,6 +196,7 @@ (str "function that takes input: [" (describe input) "] and returns " (describe output)))) (defmethod accept :function [_ _ _children _] "function") +(defmethod accept :all [_ schema _ {::keys [describe] :as options}] (describe (m/deref schema) options)) (defmethod accept :fn [_ _ _ _] "function") (defn -tagged [children] (map (fn [[tag _ c]] (str c " (tag: " tag ")")) children)) diff --git a/src/malli/generator.cljc b/src/malli/generator.cljc index ce3cfd3e6..de51e457b 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -2,6 +2,7 @@ (ns malli.generator (:require [clojure.spec.gen.alpha :as ga] [clojure.string :as str] + [clojure.set :as set] [clojure.test.check :as check] [clojure.test.check.generators :as gen] [clojure.test.check.properties :as prop] @@ -9,6 +10,7 @@ [clojure.test.check.rose-tree :as rose] [malli.core :as m] [malli.registry :as mr] + [malli.util :as u] [malli.impl.util :refer [-last -merge]] #?(:clj [borkdude.dynaload :as dynaload]))) @@ -561,9 +563,11 @@ ;; functions ;; +(def ^:private default-=>iterations 100) + (defn function-checker ([?schema] (function-checker ?schema nil)) - ([?schema {::keys [=>iterations] :or {=>iterations 100} :as options}] + ([?schema {::keys [=>iterations all-iterations] :or {=>iterations default-=>iterations all-iterations 10} :as options}] (let [schema (m/schema ?schema options) -try (fn [f] (try [(f) true] (catch #?(:clj Exception, :cljs js/Error) e [e false]))) check (fn [schema] @@ -590,6 +594,36 @@ :=> (check schema) :function (let [checkers (map #(function-checker % options) (m/-children schema))] (fn [x] (->> checkers (keep #(% x)) (seq)))) + :all (fn [x] + (let [bounds (mapv (fn [{:keys [kind] :as m}] + (case kind + :Schema (:upper m))) + (m/-bounds schema)) + examples (mapv (fn [s] + (vec (sample s {:size all-iterations}))) + bounds) + {:keys [result shrunk]} (->> (prop/for-all* [(gen/bind (apply gen/tuple + (map #(gen/fmap + (fn [v] + [:fn {:gen/return v} (fn [r] (= v r))]) + (gen/elements %)) examples)) + (fn [schemas] + (let [schema (m/inst schema schemas options)] + (gen/return + {:explain (delay + ((function-checker + schema + (update options ::=>iterations + (fn [=>iterations] + (or =>iterations default-=>iterations)))) + x)) + :schemas schemas + :schema schema}))))] + (fn [{:keys [explain]}] (nil? @explain))) + (check/quick-check all-iterations)) + smallest (-> shrunk :smallest first)] + (when-not (true? result) + @(:explain smallest)))) (m/-fail! ::invalid-function-schema {:type (m/-type schema)}))))) (defn check diff --git a/src/malli/json_schema.cljc b/src/malli/json_schema.cljc index 07c52b681..5db6badf2 100644 --- a/src/malli/json_schema.cljc +++ b/src/malli/json_schema.cljc @@ -176,6 +176,7 @@ (defmethod accept :=> [_ _ _ _] {}) (defmethod accept :function [_ _ _ _] {}) +(defmethod accept :all [_ schema _ {::keys [transform] :as options}] (transform (m/deref schema) options)) (defmethod accept :ref [_ schema _ options] (-ref schema options)) (defmethod accept :schema [_ schema _ options] (-schema schema options)) (defmethod accept ::m/schema [_ schema _ options] (-schema schema options)) diff --git a/test/malli/core_test.cljc b/test/malli/core_test.cljc index a7a326443..4c296c555 100644 --- a/test/malli/core_test.cljc +++ b/test/malli/core_test.cljc @@ -3224,3 +3224,42 @@ ::xymap [:merge ::xmap ::ymap]}} ::xymap] {:registry registry, ::m/ref-key :id})))))))) + +(deftest all-test + ;; no alpha-renaming needed + (is (= [:all [:x] [:=> [:cat :x] :x]] + (m/form (m/all [x] [:=> [:cat x] x])))) + ;; alpha-rename binder if clashing keyword in body form + (is (= [:all [:x0] [:=> [:x :x0] :x0]] + (m/form (m/all [x] [:=> [:x x] x])))) + (is (= [:all [:x] [:=> [:cat [:all [:y] :y]] :x]] + (m/form (m/all [x] [:=> [:cat (m/all [y] y)] x])))) + ;; alpha-rename outer binder if clashing :all inside (actually just + ;; a naive keyword occurrence check on the form of the body). + (is (= [:all [:x0] [:=> [:cat [:all [:x] :x]] :x0]] + (m/form (m/all [x] [:=> [:cat (m/all [x] x)] x])))) + (is (= [:=> [:cat [:schema :any]] [:schema :any]] + (m/form (m/inst (m/all [x] [:=> [:cat x] x]) [:any])))) + (is (= [:=> + [:cat + [:schema [:all [:x] [:=> [:cat :x] :x]]]] + [:schema [:all [:x] [:=> [:cat :x] :x]]]] + (m/form (m/inst (m/all [x] [:=> [:cat x] x]) + [(m/all [x] [:=> [:cat x] x])])))) ;;FIXME + (is (= [:all [:y0] [:schema [:all [:y] :y]]] + (m/form (m/inst (m/all [x] (m/all [y] x)) + [(m/all [y] y)])))) + ;;TODO could be smarter here since no substitution occurs + (is (= [:all [:x1] :x1] + (m/form (m/inst (m/all [x] (m/all [x] x)) + [(m/all [x] x)])))) + (is (= [:=> [:cat [:schema :any]] [:schema :any]] + (m/form (m/deref (m/all [a] [:=> [:cat a] a]))))) + (is (= [:=> [:cat [:schema [:maybe :map]] [:schema :any]] + [:merge [:schema [:maybe :map]] [:map [:x [:schema :any]]]]] + (m/form + (let [options {:registry (mr/composite-registry m/default-registry (mu/schemas))}] + (-> (m/all [[M [:maybe :map]] X] [:=> [:cat M X] [:merge M [:map [:x X]]]]) + (m/schema options) + m/deref))))) +) diff --git a/test/malli/experimental_test.clj b/test/malli/experimental_test.clj index a1fc3d63d..feb3c6989 100644 --- a/test/malli/experimental_test.clj +++ b/test/malli/experimental_test.clj @@ -1,6 +1,9 @@ (ns malli.experimental-test (:require [clojure.test :refer [deftest is testing]] [malli.dev] + [malli.core :as m] + [malli.util :as mu] + [malli.registry :as mr] [malli.experimental :as mx] [malli.instrument :as mi])) @@ -19,6 +22,29 @@ [x :- [:int {:min 0}], y :- :int] (+ x y)) +(mx/defn :all [A] + poly :- A [x :- A] x) + +(mx/defn :all [[A :int]] + poly-usage :- A [x :- A] + (if (= x 42) + (m/coerce A 'a) + (when (and (integer? x) (even? x)) + (m/coerce A x))) + x) + +(def options {:registry (mr/composite-registry m/default-registry (mu/schemas))}) + +(mx/defn :all [[M [:maybe :map]] X] + assoc-x + :- [:merge M [:map [:x X]]] + {::m/options options} + [m :- M, + x :- X] + (if (= :breaks x) + (dissoc m :x) + (assoc m :x x))) + (def AB [:map [:a [:int {:min 0}]] [:b :int]]) (def CD [:map [:c [:int {:min 0}]] [:d :int]]) @@ -124,7 +150,38 @@ [[{:outer {:not-inner 'foo}}] nil]] :instrumented [[[(list :outer [:not-inner])] ::throws] [[{:outer {:inner "here"}}] "here"] - [[{:outer {:not-inner 'foo}}] nil]]}]) + [[{:outer {:not-inner 'foo}}] nil]]} + {:var #'poly + :calls [[[1] 1] + [["kikka"] "kikka"] + [[] ::throws] + [[1 2] ::throws]] + :instrumented [[[1] 1] + [["kikka"] "kikka"] + [[] ::throws] + [[1 2] ::throws]]} + {:var #'poly-usage + :calls [[[1] 1] + [[2] 2] + [[3] 3] + [[42] ::throws] + [["kikka"] "kikka"] + [[] ::throws] + [[1 2] ::throws]] + :instrumented [[[1] 1] + [[2] 2] + [[3] 3] + [["kikka"] ::throws] + [[42] ::throws] + [[] ::throws] + [[1 2] ::throws]]} + {:var #'assoc-x + :calls [[[{} 1] {:x 1}] + [[{:x 2} 3] {:x 3}] + [[{:x 2 :y 42} :breaks] {:y 42}]] + :instrumented [[[{} 1] {:x 1}] + [[{:x 2} 3] {:x 3}] + [[{:x 2 :y 42} :breaks] ::throws]]}]) (defn -strument! [mode v] (with-out-str diff --git a/test/malli/generator_debug.cljc b/test/malli/generator_debug.cljc index 7614442d5..22fbb521a 100644 --- a/test/malli/generator_debug.cljc +++ b/test/malli/generator_debug.cljc @@ -9,6 +9,7 @@ (def any-printable {:op :any-printable}) (defn double* [& args] {:op :double* :args args}) (defmacro fmap [& args] (let [args (vec args)] `{:op :fmap :args-form '~args :args ~args})) +(defmacro bind [& args] (let [args (vec args)] `{:op :bind :args-form '~args :args ~args})) (defmacro vector ([generator] {:op :vector :generator generator}) ([generator num-elements] {:op :vector :generator generator :num-elements num-elements}) diff --git a/test/malli/generator_test.cljc b/test/malli/generator_test.cljc index 7e200711d..f31dac088 100644 --- a/test/malli/generator_test.cljc +++ b/test/malli/generator_test.cljc @@ -1034,3 +1034,36 @@ #?(:clj Exception, :cljs js/Error) #":malli\.generator/and-generator-failure" (mg/generate [:and pos? neg?])))) + +(deftest poly-generator-test + ;;TODO :P + (is (thrown-with-msg? + #?(:clj Exception, :cljs js/Error) + #":malli.generator/no-generator" + (mg/generate (m/all [X] [:=> [:cat X] X])))) + ;;via deref + (is (= {} ((mg/generate (m/deref (m/all [X] [:=> [:cat X] X])) {:seed 1 :size 2}) 1)))) + +(defn is-all-good [schema vs] + (testing "good" + (doseq [[i f] (map-indexed vector vs)] + (testing i + (is (nil? (mg/check schema f))))))) + +(defn is-all-bad [schema vs] + (testing "bad" + (doseq [[i f] (map-indexed vector vs)] + (testing i + (is (mg/check schema f {::mg/all-iterations 1000})))))) + +(def good-identities [identity + (fn [a] a) + (fn [a] (identity a))]) +(def bad-identities [(fn [_] nil) + (fn [a] (when (uuid? a) a))]) + +(def identity-spec (m/all [a] [:=> [:cat a] a])) + +(deftest identity-test + (is-all-good identity-spec good-identities) + (is-all-bad identity-spec bad-identities))