Merge pull request #1095 from metosin/multi-keyword-dispatch-gen

Multi keyword dispatch gen

CHANGELOG.md

@@ -18,6 +18,8 @@ Malli is in well matured [alpha](README.md#alpha).
 
 * Fix ClojureScript [arithmetic warning](https://github.com/metosin/malli/issues/1093)
 * Distribute `:merge` over `:multi` [#1086](https://github.com/metosin/malli/pull/1086), see [documentation](README.md#distributive-schemas)
+* allow `m/-proxy-schema` child to be a `delay` [#1090](https://github.com/metosin/malli/pull/1090)
+* `:multi` with keyword `:dispatch` accumulates data to generated values [#1095](https://github.com/metosin/malli/pull/1095)
 * allow `m/-proxy-schema` child to be a `delay`
 * Fix `malli.dev.pretty` throws when explaining errors in nested maps [#1094](https://github.com/metosin/malli/issues/1096)
 * `json-transformer` decodes 123.0 into 123 for schemas like `:int`, `pos-int?` etc. [#986](https://github.com/metosin/malli/issues/986)

src/malli/generator.cljc

@@ -9,6 +9,7 @@
             [clojure.test.check.rose-tree :as rose]
             [malli.core :as m]
             [malli.registry :as mr]
+            [malli.util :as mu]
             [malli.impl.util :refer [-last -merge]]
             #?(:clj [borkdude.dynaload :as dynaload])))
 
@@ -163,10 +164,21 @@
     (gen-one-of gs)
     (-never-gen options)))
 
+(defn- -merge-keyword-dispatch-map-into-entries [schema]
+  (let [dispatch (-> schema m/properties :dispatch)]
+    (cond-> schema
+      (keyword? dispatch)
+      (mu/transform-entries
+       #(map (fn [[k :as e]]
+               (cond-> e
+                 (not= ::m/default k)
+                 (update 2 mu/merge [:map [dispatch [:= nil k]]]))) %)
+       (m/options schema)))))
+
 (defn -multi-gen [schema options]
-  (if-some [gs (not-empty
-                (into [] (keep #(-not-unreachable (generator (last %) options)))
-                      (m/entries schema options)))]
+  (if-some [gs (->> (m/entries (-merge-keyword-dispatch-map-into-entries schema) options)
+                    (into [] (keep #(-not-unreachable (generator (last %) options))))
+                    (not-empty))]
     (gen-one-of gs)
     (-never-gen options)))
 

test/malli/generator_test.cljc

@@ -49,7 +49,7 @@
                     :symbol
                     :qualified-keyword
                     :qualified-symbol]]
-      (is (every? (partial m/validate schema) (mg/sample schema {:size 1000})))))
+      (is (every? (m/validator schema) (mg/sample schema {:size 1000})))))
 
   (testing "double properties"
     (let [infinity? #(or (= % ##Inf)
@@ -165,16 +165,16 @@
     (testing "recursion"
       (let [schema [:schema {:registry {::cons [:maybe [:tuple int? [:ref ::cons]]]}}
                     ::cons]]
-        (is (every? (partial m/validate schema) (mg/sample schema {:size 100})))))
+        (is (every? (m/validator schema) (mg/sample schema {:size 100})))))
     (testing "mutual recursion"
       (let [schema [:schema
                     {:registry {::ping [:maybe [:tuple [:= "ping"] [:ref ::pong]]]
                                 ::pong [:maybe [:tuple [:= "pong"] [:ref ::ping]]]}}
                     ::ping]]
-        (is (every? (partial m/validate schema) (mg/sample schema {:size 100})))))
+        (is (every? (m/validator schema) (mg/sample schema {:size 100})))))
     (testing "recursion limiting"
       (are [schema]
-        (every? (partial m/validate schema) (mg/sample schema {:size 100}))
+        (every? (m/validator schema) (mg/sample schema {:size 100}))
 
         [:schema {:registry {::rec [:maybe [:ref ::rec]]}} ::rec]
         [:schema {:registry {::rec [:map [:rec {:optional true} [:ref ::rec]]]}} ::rec]
@@ -369,7 +369,7 @@
                      [:map [:x int?] [:y int?]]
                      [:x]]]
             :let [schema (m/schema schema {:registry registry})]]
-      (is (every? (partial m/validate schema) (mg/sample schema {:size 1000}))))))
+      (is (every? (m/validator schema) (mg/sample schema {:size 1000}))))))
 
 #?(:clj
    (deftest function-schema-test
@@ -1098,3 +1098,32 @@
 (deftest double-with-long-min-test
   (is (m/validate :double (shrink [:double {:min 3}])))
   (is (= 3.0 (shrink [:double {:min 3}]))))
+
+(deftest multi-keyword-dispatch-test
+  (testing "keyword dispatch value accumulates to generated value"
+    (let [schema [:multi {:dispatch :type}
+                  ["duck" :map]
+                  ["boss" :map]]]
+      (is (every? #{{:type "duck"} {:type "boss"}} (mg/sample schema)))
+      (is (every? (m/validator schema) (mg/sample schema)))))
+
+  (testing "non keyword doesn't accumulate data"
+    (let [schema [:multi {:dispatch (fn [x] (:type x))}
+                  ["duck" :map]
+                  ["boss" :map]]]
+      (is (every? #{{}} (mg/sample schema)))
+      (is (not (every? (m/validator schema) (mg/sample schema))))))
+
+  (testing "::m/default works too"
+    (let [schema [:multi {:dispatch :type}
+                  ["duck" :map]
+                  [::m/default [:= "boss"]]]]
+      (is (every? #{{:type "duck"} "boss"} (mg/sample schema)))
+      (is (every? (m/validator schema) (mg/sample schema)))))
+
+  (testing "works with nil & {} too"
+    (let [schema [:multi {:dispatch :type}
+                  [nil :map]
+                  [{} :map]]]
+      (is (every? #{{:type nil} {:type {}}} (mg/sample schema)))
+      (is (every? (m/validator schema) (mg/sample schema))))))