wip

src/malli/experimental.cljc

@@ -18,13 +18,7 @@
                          [: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"]
@@ -42,7 +36,7 @@
 (def Params (-schema false))
 
 (c/defn -defn [schema args]
-  (let [{:keys [name poly return doc arities] body-meta :meta :as parsed} (m/parse schema args)
+  (let [{:keys [name 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))
@@ -51,37 +45,23 @@
         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))
-        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)
+        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)
        defn#)))
 
 ;;

src/malli/generator.cljc

@@ -12,6 +12,7 @@
             [malli.registry :as mr]
             [malli.impl.util :refer [-last -merge]]
             [malli.util :as u]
+            [malli.poly-protocols :as poly-prot]
             #?(:clj [borkdude.dynaload :as dynaload])))
 
 (declare generator generate -create)
@@ -614,7 +615,7 @@
                               (case kind
                                 :Schema (:upper m)
                                 (m/-fail! ::bounds-not-yet-implemented {:schema schema :bounds m})))
-                            (m/-bounds schema))
+                            (poly-prot/-bounds schema))
                examples (mapv (fn [s]
                                 (vec (sample s {:size all-iterations})))
                               bounds)
@@ -629,7 +630,7 @@
                                                                                          :nil))
                                                                                      (gen/elements %)) examples))
                                                                       (fn [schemas]
-                                                                        (let [schema (m/inst schema schemas options)]
+                                                                        (let [schema (poly-prot/-inst schema schemas)]
                                                                           (gen/return
                                                                             {:explain (delay
                                                                                         ((function-checker

src/malli/poly.cljc

@@ -7,14 +7,11 @@
             [malli.impl.regex :as re]
             [malli.impl.util :as miu]
             [malli.registry :as mr]
-            [malli.sci :as ms]))
+            [malli.sci :as ms]
+            [malli.poly-protocols :refer [AllSchema -bounds -inst]]))
 
 (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)

src/malli/poly_protocols.cljc

@@ -0,0 +1,5 @@
+(ns malli.poly-protocols)
+
+(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"))

test/malli/experimental_test.clj

@@ -1,9 +1,6 @@
 (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]))
 
@@ -22,29 +19,6 @@
   [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]])
 
@@ -150,38 +124,7 @@
             [[{:outer {:not-inner 'foo}}] nil]]
     :instrumented [[[(list :outer [:not-inner])] ::throws]
                    [[{:outer {:inner "here"}}] "here"]
-                   [[{: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]]}])
+                   [[{:outer {:not-inner 'foo}}] nil]]}])
 
 (defn -strument! [mode v]
   (with-out-str

test/malli/generator_test.cljc

@@ -1071,62 +1071,6 @@
         #":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}])))
   (is (= 3.0 (shrink [:double {:min 3}]))))

test/malli/poly_test.cljc

@@ -72,3 +72,59 @@
              (m/schema options)
              m/deref
              m/form))))
+
+(deftest poly-generator-test
+  ;;TODO :P
+  (is (thrown-with-msg?
+        #?(:clj Exception, :cljs js/Error)
+        #":malli.generator/no-generator"
+        (mg/generate (poly/all [X] [:=> [:cat X] X]) options)))
+  ;;via deref
+  (is (= {} ((mg/generate (m/deref (poly/all [X] [:=> [:cat X] X]) options) {: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 options)))))))
+
+(defn is-all-bad  [schema vs]
+  (testing "bad"
+    (doseq [[i f] (map-indexed vector vs)]
+      (testing i
+        (try (let [res (mg/check schema f (assoc options ::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 [(poly/all [a] [:=> [:cat a] a])
+                     (poly/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 [(poly/all [a b] [:=> [:cat [:=> [:cat a] b] [:sequential a]] [:sequential b]])
+                (poly/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))))