diff --git a/README.md b/README.md index aaee62722..a02942ca5 100644 --- a/README.md +++ b/README.md @@ -20,7 +20,7 @@ Data-driven Schemas for Clojure/Script and [babashka](#babashka). - [Inferring Schemas](#inferring-schemas) from sample values and [Destructuring](#destructuring). - Tools for [Programming with Schemas](#programming-with-schemas) - [Parsing](#parsing-values) and [Unparsing](#unparsing-values) values -- [Sequence](#sequence-schemas), [Vector](#vector-schemas), and [Set](#set-schemas) Schemas +- [Enumeration](#enumeration-schemas), [Sequence](#sequence-schemas), [Vector](#vector-schemas), and [Set](#set-schemas) Schemas - [Persisting schemas](#persisting-schemas), even [function schemas](#serializable-functions) - Immutable, Mutable, Dynamic, Lazy and Local [Schema Registries](#schema-registry) - [Schema Transformations](#schema-Transformation) to [JSON Schema](#json-schema), [Swagger2](#swagger2), and [descriptions in english](#description) @@ -329,6 +329,32 @@ Most core-predicates are mapped to Schemas: See [the full list of default schemas](#schema-registry). +## Enumeration schemas + +`:enum` schemas `[:enum V1 V2 ...]` represent an enumerated set of values `V1 V2 ...`. + +This mostly works as you'd expect, with values passing the schema if it is contained in the set and generators returning one of the values, +shrinking to the left-most value. + +There are some special cases to keep in mind around syntax. Since schema properties can be specified with a map or nil, enumerations starting with +a map or nil must use slightly different syntax. + +If your `:enum` does not have properties, you must provide `nil` as the properties. + +```clojure +[:enum nil {}] ;; singleton schema of {} +[:enum nil nil] ;; singleton schema of nil +``` + +If your `:enum` has properties, the leading map with be interpreted as properties, not an enumerated value. + +```clojure +[:enum {:foo :bar} {}] ;; singleton schema of {}, with properties {:foo :bar} +[:enum {:foo :bar} nil] ;; singleton schema of nil, with properties {:foo :bar} +``` + +In fact, these syntax rules apply to all schemas, but `:enum` is the most common schema where this is relevant so it deserves a special mention. + ## Qualified keys in a map You can also use [decomplected maps keys and values](https://clojure.org/about/spec#_decomplect_mapskeysvalues) using registry references. References must be either qualified keywords or strings. diff --git a/docs/function-schemas.md b/docs/function-schemas.md index a9a9371b1..337eef0dd 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) * [Flat Arrow Function Schemas](#flat-arrow-function-schemas) * [Defn Schemas](#defn-schemas) * [Defining Function Schemas](#defining-function-schemas) @@ -65,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: @@ -91,11 +93,18 @@ Examples of function definitions: [:function [:=> [:cat :int] :int] [:=> [:cat :int :int [:* :int]] :int]] + +;; polymorphic identity function +(m/all [a] [:-> a a]) + +;; polymorphic map function +(m/all [a b] + [:-> [:-> a b] [:sequential a] [:sequential b]]) ``` What is that `:cat` all about in the input schemas? Wouldn't it be simpler without it? Sure, check out [Flat Arrow Function Schema](#flat-arrow-function-schemas). -Function definition for the `plus` looks like this: +The schema for `plus` looks like this: ```clojure (def =>plus [:=> [:cat :int :int] :int]) @@ -319,11 +328,74 @@ Generating multi-arity functions: ; => -2326 ``` +### Polymorphic Functions + +A polymorphic function using `m/all` is generatively tested by instantiating schema variables with generated schemas +and then using the resulting schema for generative testing. + +In the same way as function arguments are chosen during generative testing, schema variable instantiations start +small and then grow after successful runs, and failures are shrunk for reporting purposes. + +For example, the polymorphic identity schema + +```clojure +(m/all [a] [:-> a a]) +``` + +is tested by choosing progressively largers schemas for `a`, +and then checking each instantiated schema against the function like usual +using generative testing. + +The current implementation for generating schemas for `a` is unsophisticated. +The upper bound of `a` (implicitly `:any`) is used to generate (successively larger) +values, and those values are wrapped in singleton schema. On failure, the `:any` +generator will be shrunk, and in turn the schemas will also shrink. + +A run might generate values `nil`, `50` and `5333344553` from `a`'s upper bound, +which are then converted to schemas like so: + +```clojure +:nil +[:enum 50] +[:enum 5333344553] +``` + +Then, the first three runs will use these schemas to instantiate the polymorphic schema, +resulting in: + +```clojure +;; first run +[:-> [:schema :nil] [:schema :nil]] + +;; second run +[:-> [:schema [:enum 50]] [:schema [:enum 50]]] + +;; third run +[:-> [:schema [:enum 5333344553]] [:schema [:enum 5333344553]]] +``` + +The extra `:schema` calls are added by `m/inst` to prevent regex schema splicing. + +If the third run fails, the value `5333344553` will be shrunk using `:any`'s generator, +perhaps resulting in the final shrunk failing schema + +```clojure +[:-> [:schema [:enum 51]] [:schema [:enum 51]]] +``` + +Note a gotcha with generated `:enum` schemas: if the first child is a map, it will print with `nil` properties. +For example, `[:enum nil {}]` validates `{}` but not `nil`. + +Shrinking is currently not supported for higher-order polymorphic functions. + +Generating schemas for other kinds of schema variables such as regexes is not yet implemented +and will throw an error. + ### 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 | | ----------|-------------| @@ -397,6 +469,25 @@ 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] [:-> a a]) m/deref) +;=> [:-> [:schema :any] [:schema :any]] + +(def options {:registry (mr/composite-registry m/default-registry (mu/schemas))}) + +(-> (m/all [[M [:maybe :map]] X] [:-> M X [:merge M [:map [:x X]]]]) + (m/schema options) + m/deref) +;=> [:-> [:schema [:maybe :map]] [:schema :any] +; [:merge [:schema [:maybe :map]] [:map [:x [:schema :any]]]]] + ### Flat Arrow Function Schemas Function schema `:=>` requires input arguments to be wrapped in `:cat` or `:catn`. Since `0.16.2` there is also flat arrow schema: `:->` that allows input schema to be defined as flat sequence: diff --git a/src/malli/core.cljc b/src/malli/core.cljc index 4ee585eea..3b8fa55f1 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 -instrument) + parser unparser ast from-ast -instrument 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, or their defaults if nil")) + (defprotocol FunctionSchema (-function-schema? [this]) (-function-schema-arities [this]) @@ -298,7 +302,12 @@ (let [has-children (seq children), has-properties (seq properties)] (cond (and has-properties has-children) (reduce conj [type properties] children) has-properties [type properties] - has-children (reduce conj [type] children) + has-children (let [fchild (nth children 0)] + (reduce conj + (cond-> [type] + (or (map? fchild) + (nil? fchild)) (conj nil)) + children)) :else type))) (defn -create-form [type properties children options] @@ -2212,7 +2221,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] @@ -2607,6 +2616,277 @@ :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] + (-vmap (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] + (-vmap (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)) + 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 (ifn? 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)) + FunctionSchema + (-function-schema? [this] (-function-schema? @self-inst)) + (-function-schema-arities [this] (-function-schema-arities @self-inst)) + (-function-info [this] (-function-info @self-inst)) + (-instrument-f [schema props f options] (-instrument-f @self-inst props f 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 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) @@ -2625,6 +2905,7 @@ :fn (-fn-schema) :ref (-ref-schema) :=> (-=>-schema) + :all (-all-schema nil) :-> (-->-schema nil) :function (-function-schema nil) :schema (-schema-schema nil) @@ -2683,24 +2964,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, 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 8caa77466..0191ed736 100644 --- a/src/malli/experimental/describe.cljc +++ b/src/malli/experimental/describe.cljc @@ -198,6 +198,7 @@ (defmethod accept :-> [_ s _ _] (-accept-=> s)) (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 50e680050..1727ad315 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -1,6 +1,7 @@ ;; See also `malli.generator-ast` for viewing generators as data (ns malli.generator (:require [clojure.spec.gen.alpha :as ga] + [clojure.set :as set] [clojure.string :as str] [clojure.test.check :as check] [clojure.test.check.generators :as gen] @@ -10,6 +11,7 @@ [malli.core :as m] [malli.registry :as mr] [malli.impl.util :refer [-last -merge]] + [malli.util :as u] #?(:clj [borkdude.dynaload :as dynaload]))) (declare generator generate -create) @@ -579,9 +581,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] @@ -604,12 +608,49 @@ 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)))))))))] - (if (m/-function-info schema) - (check schema) - (if (m/-function-schema? schema) - (let [checkers (map #(function-checker % options) (m/-function-schema-arities schema))] - (fn [x] (->> checkers (keep #(% x)) (seq)))) - (m/-fail! ::invalid-function-schema {:type (m/-type schema)})))))) + (if (= :all (m/type schema)) + (fn [x] + (let [bounds (mapv (fn [{:keys [kind] :as m}] + (case kind + :Schema (:upper m) + (m/-fail! ::bounds-not-yet-implemented {:schema schema :bounds 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] + (if (some? v) + (if (map? v) + ;; map enums require nil properties + [:enum nil v] + [:enum v]) + :nil)) + (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)))) + (if (m/-function-info schema) + (check schema) + (if (m/-function-schema? schema) + (let [checkers (map #(function-checker % options) (m/-function-schema-arities schema))] + (fn [x] (->> checkers (keep #(% x)) (seq)))) + (m/-fail! ::invalid-function-schema {:type (m/-type schema)}))))))) (defn check ([?schema f] (check ?schema f nil)) diff --git a/src/malli/json_schema.cljc b/src/malli/json_schema.cljc index 4fb1026fd..5d3eb426d 100644 --- a/src/malli/json_schema.cljc +++ b/src/malli/json_schema.cljc @@ -181,6 +181,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 1644c5e74..942e5b55f 100644 --- a/test/malli/core_test.cljc +++ b/test/malli/core_test.cljc @@ -545,10 +545,36 @@ #_(is (= 1 (m/decode schema "1" mt/string-transformer))) #_(is (= "1" (m/decode schema "1" mt/json-transformer))) - (testing "map enums require nil properties" - (let [schema [:enum nil {:a 1} {:b 2}]] - (is (= nil (m/properties schema))) - (is (= [{:a 1} {:b 2}] (m/children schema))))) + (testing "nil enums without properties require empty properties" + (let [schema [:enum nil nil]] + (testing (pr-str schema) + (is (= nil (m/properties schema))) + (is (= [nil] (m/children schema))) + (is (= schema (m/form schema))) + (is (= schema (-> schema m/form m/schema m/form)))))) + + (testing "nil nums support properties" + (let [schema [:enum {:foo :bar} nil]] + (is (= {:foo :bar} (m/properties schema))) + (is (= [nil] (m/children schema))) + (is (= schema (m/form schema))) + (is (= schema (-> schema m/form m/schema m/form))))) + + (testing "map enums without properties require empty properties" + (doseq [schema [[:enum nil {:a 1} {:b 2}] + [:enum {} {:a 1} {:b 2}]]] + (testing (pr-str schema) + (is (= nil (m/properties schema))) + (is (= [{:a 1} {:b 2}] (m/children schema))) + (is (= [:enum nil {:a 1} {:b 2}] (m/form schema))) + (is (= [:enum nil {:a 1} {:b 2}] (-> schema m/form m/schema m/form)))))) + + (testing "map enums support properties" + (let [schema [:enum {:foo :bar} {:a 1} {:b 2}]] + (is (= {:foo :bar} (m/properties schema))) + (is (= [{:a 1} {:b 2}] (m/children schema))) + (is (= schema (m/form schema))) + (is (= schema (-> schema m/form m/schema m/form))))) (is (true? (m/validate (over-the-wire schema) 1))) @@ -3358,6 +3384,60 @@ ::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])))) + (is (= [:all [:x] [:-> :x :x]] + (m/form (m/all [x] [:-> 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 (= [:all [:x0] [:-> [:all [:x] :x] :x0]] + (m/form (m/all [x] [:-> (m/all [x] x) x])))) + (is (= [:=> [:cat [:schema :any]] [:schema :any]] + (m/form (m/inst (m/all [x] [:=> [:cat x] x]) [:any])))) + (is (= [:-> + [:schema [:all [:x] [:-> :x :x]]] + [:schema [:all [:x] [:-> :x :x]]]] + (m/form (m/inst (m/all [x] [:-> x x]) + [(m/all [x] [:-> 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 (= [:-> [:schema :any] [:schema :any]] + (m/form (m/deref (m/all [a] [:-> 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))))) + (is (= [:-> + [: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] [:-> M X [:merge M [:map [:x X]]]]) + (m/schema options) + m/deref)))))) + (deftest proxy-schema-explain-path (let [y-schema [:int {:doc "int"}] schema (m/schema [(mu/-select-keys) 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 768ada924..ea71a7437 100644 --- a/test/malli/generator_test.cljc +++ b/test/malli/generator_test.cljc @@ -1067,9 +1067,65 @@ #":malli\.generator/distinct-generator-failure" (mg/generate [:map-of {:min 2} [:= 1] :any]))) (is (thrown-with-msg? - #?(:clj Exception, :cljs js/Error) - #":malli\.generator/and-generator-failure" - (mg/generate [:and pos? neg?])))) + #?(: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 + (try (let [res (mg/check schema f {::mg/all-iterations 1000})] + (is res)) + (catch #?(:clj Exception, :cljs js/Error) e + (is (= ::m/invalid-input (:type (ex-data e)))))))))) + +(def good-identities [identity + (fn [a] a) + (fn [a] (identity a))]) +(def bad-identities [(fn [_] nil) + (fn [a] (when (uuid? a) a))]) + +(def identity-specs [(m/all [a] [:=> [:cat a] a]) + (m/all [a] [:-> a a])]) + +(deftest identity-test + (doseq [identity-spec identity-specs] + (testing (pr-str identity-spec) + (is-all-good identity-spec good-identities) + (is-all-bad identity-spec bad-identities)))) + +(def good-maps [map + (fn [f c] (map f c)) + (fn [f c] (mapv f c))]) +(def bad-maps [(comp #(map str %) map) + (fn [f c] (map (comp f str) c)) + (fn [f c] (map (comp str f) c))]) + +(def map-specs [(m/all [a b] [:=> [:cat [:=> [:cat a] b] [:sequential a]] [:sequential b]]) + (m/all [a b] [:-> [:-> a b] [:sequential a] [:sequential b]])]) + +;; TODO catch higher-order failures and shrink them. +(deftest map-test + (doseq [map-spec map-specs] + (testing (pr-str map-spec) + (is-all-good map-spec good-maps) + (is-all-bad map-spec bad-maps)))) (deftest double-with-long-min-test (is (m/validate :double (shrink [:double {:min 3}])))