Adds :pred option to m/-map-schema

src/malli/core.cljc

@@ -943,7 +943,7 @@
 (defn -map-schema
   ([]
    (-map-schema {:naked-keys true}))
-  ([opts] ;; :naked-keys, :lazy
+  ([opts] ;; :naked-keys, :lazy, :pred
    ^{:type ::into-schema}
    (reify
      AST
@@ -954,7 +954,8 @@
      (-properties-schema [_ _])
      (-children-schema [_ _])
      (-into-schema [parent {:keys [closed] :as properties} children options]
-       (let [entry-parser (-create-entry-parser children opts options)
+       (let [pred? (:pred opts map?)
+             entry-parser (-create-entry-parser children opts options)
              form (delay (-create-entry-form parent properties entry-parser options))
              cache (-create-cache options)
              ->parser (fn [this f]
@@ -975,7 +976,7 @@
                                                        (reduce
                                                         (fn [m k] (if (contains? keyset k) m (reduced (reduced ::invalid))))
                                                         m (keys m)))))]
-                          (fn [x] (if (map? x) (reduce (fn [m parser] (parser m)) x parsers) ::invalid))))]
+                          (fn [x] (if (pred? x) (reduce (fn [m parser] (parser m)) x parsers) ::invalid))))]
          ^{:type ::schema}
          (reify
            AST
@@ -993,7 +994,7 @@
                                        (-children this))
                                 closed (conj (fn [m] (reduce (fn [acc k] (if (contains? keyset k) acc (reduced false))) true (keys m)))))
                    validate (miu/-every-pred validators)]
-               (fn [m] (and (map? m) (validate m)))))
+               (fn [m] (and (pred? m) (validate m)))))
            (-explainer [this path]
              (let [keyset (-entry-keyset (-entry-parser this))
                    explainers (cond-> (-vmap
@@ -1014,7 +1015,7 @@
                                                     (conj acc (miu/-error (conj path k) (conj in k) this v ::extra-key))))
                                                 acc x))))]
                (fn [x in acc]
-                 (if-not (map? x)
+                 (if-not (pred? x)
                    (conj acc (miu/-error path in this x ::invalid-type))
                    (reduce
                     (fn [acc explainer]
@@ -1028,7 +1029,7 @@
                                         (let [t (-transformer s transformer method options)]
                                           (cond-> acc t (conj [k t])))) [] (-entries this))
                    apply->children (when (seq ->children) (-map-transformer ->children))
-                   apply->children (-guard map? apply->children)]
+                   apply->children (-guard pred? apply->children)]
                (-intercepting this-transformer apply->children)))
            (-walk [this walker path options] (-walk-entries this walker path options))
            (-properties [_] properties)

test/malli/core_test.cljc

@@ -10,7 +10,7 @@
             [malli.registry :as mr]
             [malli.transform :as mt]
             [malli.util :as mu])
-  #?(:clj (:import (clojure.lang IFn))))
+  #?(:clj (:import (clojure.lang IFn PersistentArrayMap PersistentHashMap))))
 
 (defn with-schema-forms [result]
   (some-> result
@@ -2691,3 +2691,36 @@
               (m/deref)
               (m/properties)
               :error/message))))))
+
+(deftest -map-schema-test
+  (let [test-data (array-map :id (random-uuid)
+                             :name "baz"
+                             :code (rand-int 100)
+                             :organization (hash-map :id (random-uuid)
+                                                     :code (rand-int 100)))]
+    (testing "returns map schema with map? as default :pred fn"
+      (let [DefaultMapSchema (m/-map-schema {:naked-keys true})
+            data-schema (m/schema [DefaultMapSchema
+                                   [:id uuid?]
+                                   [:name string?]
+                                   [:code {:optional true} int?]
+                                   [:organization [DefaultMapSchema
+                                                   [:id uuid?]
+                                                   [:name {:optional true} string?]
+                                                   [:code int?]]]])]
+        (is (m/validate data-schema test-data))))
+
+    (testing "returns map schema with custom :pred fn as provided in opts"
+      (let [persistent-array-map? #(instance? PersistentArrayMap %)
+            ArrayMapSchema (m/-map-schema {:pred persistent-array-map?})
+            persistent-hash-map? #(instance? PersistentHashMap %)
+            HashMapSchema (m/-map-schema {:pred persistent-hash-map?})
+            data-schema (m/schema [ArrayMapSchema
+                                   [:id uuid?]
+                                   [:name string?]
+                                   [:code {:optional true} int?]
+                                   [:organization [HashMapSchema
+                                                   [:id uuid?]
+                                                   [:name {:optional true} string?]
+                                                   [:code int?]]]])]
+        (is (m/validate data-schema test-data))))))