diff --git a/src/malli/core.cljc b/src/malli/core.cljc index 3b8fa55f1..ab919ae74 100644 --- a/src/malli/core.cljc +++ b/src/malli/core.cljc @@ -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 inst) + parser unparser ast from-ast -instrument) ;; ;; protocols and records @@ -86,10 +86,6 @@ (-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]) @@ -2616,277 +2612,6 @@ :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) @@ -2905,7 +2630,6 @@ :fn (-fn-schema) :ref (-ref-schema) :=> (-=>-schema) - :all (-all-schema nil) :-> (-->-schema nil) :function (-function-schema nil) :schema (-schema-schema nil) diff --git a/src/malli/poly.cljc b/src/malli/poly.cljc new file mode 100644 index 000000000..04dd6dc87 --- /dev/null +++ b/src/malli/poly.cljc @@ -0,0 +1,289 @@ +(ns malli.poly + (:refer-clojure :exclude [eval type -deref deref -lookup -key assert]) + #?(:cljs (:require-macros malli.core)) + (:require [clojure.walk :as walk] + [clojure.core :as c] + [malli.core :as m] + [malli.impl.regex :as re] + [malli.impl.util :as miu] + [malli.registry :as mr] + [malli.sci :as ms])) + +(declare inst) + +(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")) + +(defn- -all-binder-bounds [binder] + (m/-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) + (m/-fail! ::invalid-all-binder {:binder binder}))))) + binder)) + +(defn- -visit-binder-names [binder f] + (m/-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) + (m/-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 (m/type s) + :all (-alpha-rename s vforbidden options) + (m/-walk s this path options))) + outer (fn [s path children options] + (case (m/type s) + ::m/val (first children) + (m/-set-children s children))) + walk (fn [s] + (inner + (reify m/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 + ::m/walk-refs false + ::m/walk-schema-refs false + ::m/walk-entry-vals true))) + [binder body] (m/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 (m/form + (m/-update-properties + (m/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)) + (m/schema options) + walk + (m/form options) + (->> (walk/postwalk-replace invert)))] + (m/schema [:all binder body] options))) + +(defn- -inst* [binder body insts options] + (when-not (= (count insts) + (count binder)) + (m/-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 (m/form s options) + upper (m/form upper options)] + (when (some? lower) + (m/-fail! ::nyi-lower-bounds)) + (m/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] + (m/schema options) + (-alpha-rename vforbidden-kws options) + m/children) + kws (-all-binder-names binder)] + (-> (walk/postwalk-replace (zipmap kws insts) body) + (m/schema options)))) + +(defn -all-binder-defaults [binder] + (mapv :default (-all-binder-bounds binder))) + +(defn -all-schema [_] + ^{:type ::m/into-schema} + (reify m/IntoSchema + (-type [_] :all) + (-type-properties [_]) + (-properties-schema [_ _]) + (-children-schema [_ _]) + (-into-schema [parent properties children {::m/keys [function-checker] :as options}] + (m/-check-children! :all properties children 2 2) + (let [[binder body] children + form (delay (m/-simple-form parent properties children identity options)) + cache (m/-create-cache options) + self-inst (delay (inst [:all binder body] options)) + ->checker (if function-checker #(function-checker % options) (constantly nil))] + ^{:type ::m/schema} + (reify + m/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 (m/-validator this)] + (fn explain [x in acc] + (if-not (validator x) (conj acc (miu/-error path in this x)) acc))))) + (-parser [this] + (let [validator (m/-validator this)] + (fn [x] (if (validator x) x ::m/invalid)))) + (-unparser [this] (m/-parser this)) + (-transformer [_ _ _ _]) + (-walk [this walker path options] (m/-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)) + m/FunctionSchema + (-function-schema? [this] (m/-function-schema? @self-inst)) + (-function-schema-arities [this] (m/-function-schema-arities @self-inst)) + (-function-info [this] (m/-function-info @self-inst)) + (-instrument-f [schema props f options] (m/-instrument-f @self-inst props f options)) + m/Cached + (-cache [_] cache) + m/LensSchema + (-keep [_]) + (-get [_ key default] (get children key default)) + (-set [this key value] (m/-set-assoc-children this key value)) + m/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) + (m/-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) + (m/-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 (m/schema ?all options) insts))) + +(defn schemas [] + {:all (-all-schema nil)}) diff --git a/test/malli/core_test.cljc b/test/malli/core_test.cljc index 942e5b55f..3cbec514a 100644 --- a/test/malli/core_test.cljc +++ b/test/malli/core_test.cljc @@ -3384,59 +3384,6 @@ ::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"}] diff --git a/test/malli/poly_test.cljc b/test/malli/poly_test.cljc new file mode 100644 index 000000000..bb9d92c70 --- /dev/null +++ b/test/malli/poly_test.cljc @@ -0,0 +1,74 @@ +(ns malli.poly-test + (:require [clojure.string :as str] + [clojure.test :refer [are deftest is testing]] + [clojure.test.check.generators :as gen] + [clojure.walk :as walk] + [malli.core :as m] + [malli.edn :as edn] + [malli.generator :as mg] + [malli.error :as me] + [malli.impl.util :as miu] + [malli.registry :as mr] + [malli.transform :as mt] + [malli.util :as mu] + [malli.poly :as poly] + #?(:clj [malli.test-macros :refer [when-env]])) + #?(:clj (:import (clojure.lang IFn PersistentArrayMap PersistentHashMap)) + :cljs (:require-macros [malli.test-macros :refer [when-env]]))) + +(def options {:registry (mr/composite-registry m/default-registry (poly/schemas) (mu/schemas))}) + +(deftest all-test + ;; no alpha-renaming needed + (is (= [:all [:x] [:=> [:cat :x] :x]] + (m/form (poly/all [x] [:=> [:cat x] x]) options))) + (is (= [:all [:x] [:-> :x :x]] + (m/form (poly/all [x] [:-> x x]) options))) + ;; alpha-rename binder if clashing keyword in body form + (is (= [:all [:x0] [:=> [:x :x0] :x0]] + (m/form (poly/all [x] [:=> [:x x] x]) options))) + (is (= [:all [:x] [:=> [:cat [:all [:y] :y]] :x]] + (m/form (poly/all [x] [:=> [:cat (poly/all [y] y)] x]) options))) + ;; 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 (poly/all [x] [:=> [:cat (poly/all [x] x)] x]) options))) + (is (= [:all [:x0] [:-> [:all [:x] :x] :x0]] + (m/form (poly/all [x] [:-> (poly/all [x] x) x]) options))) + (is (= [:=> [:cat [:schema :any]] [:schema :any]] + (m/form (poly/inst (poly/all [x] [:=> [:cat x] x]) [:any] options)))) + (is (= [:-> + [:schema [:all [:x] [:-> :x :x]]] + [:schema [:all [:x] [:-> :x :x]]]] + (m/form (poly/inst (poly/all [x] [:-> x x]) + [(poly/all [x] [:-> x x])] + options)))) ;;FIXME + (is (= [:all [:y0] [:schema [:all [:y] :y]]] + (m/form (poly/inst (poly/all [x] (poly/all [y] x)) + [(poly/all [y] y)] + options)))) + ;;TODO could be smarter here since no substitution occurs + (is (= [:all [:x1] :x1] + (m/form (poly/inst (poly/all [x] (poly/all [x] x)) + [(poly/all [x] x)] + options)))) + (is (= [:=> [:cat [:schema :any]] [:schema :any]] + (m/form (m/deref (poly/all [a] [:=> [:cat a] a]) options)))) + (is (= [:-> [:schema :any] [:schema :any]] + (m/form (m/deref (poly/all [a] [:-> a a]) options)))) + (is (= [:=> [:cat [:schema [:maybe :map]] [:schema :any]] + [:merge [:schema [:maybe :map]] [:map [:x [:schema :any]]]]] + (-> (poly/all [[M [:maybe :map]] X] [:=> [:cat M X] [:merge M [:map [:x X]]]]) + (m/schema options) + m/deref + m/form))) + (is (= [:-> + [:schema [:maybe :map]] + [:schema :any] + [:merge + [:schema [:maybe :map]] + [:map [:x [:schema :any]]]]] + (-> (poly/all [[M [:maybe :map]] X] [:-> M X [:merge M [:map [:x X]]]]) + (m/schema options) + m/deref + m/form))))