Merge pull request #1150 from metosin/tagged-record

Use custom Tag / Tags records (instead of MapEntry / Map) in parse output

Author: opqdonut

CHANGELOG.md

@@ -14,9 +14,11 @@ We use [Break Versioning][breakver]. The version numbers follow a `<major>.<mino
 
 Malli is in well matured [alpha](README.md#alpha).
 
-## 
+## UNRELEASED
 
 * Docs: elaborate optional-keys and required-keys [#1117](https://github.com/metosin/malli/pull/1117)
+* **BREAKING** Output of `parse` now uses new `malli.core.Tag` and `malli.core.Tags` records for `:orn`, `:multi`, `:altn`, `:catn` etc. [#1123](https://github.com/metosin/malli/issues/1123) [#1153](https://github.com/metosin/malli/issues/1153)
+  * See [Parsing](#parsing-values) and [Unparsing](#unparsing-values) for docs.
 
 ## 0.17.0 (2024-12-08)
 

README.md

@@ -2445,9 +2445,10 @@ Schemas can be used to parse values using `m/parse` and `m/parser`:
               [:s string?]
               [:b boolean?]]]]]
   ["-server" "foo" "-verbose" true "-user" "joe"])
-;[{:prop "-server", :val [:s "foo"]}
-; {:prop "-verbose", :val [:b true]}
-; {:prop "-user", :val [:s "joe"]}]
+;[#malli.core.Tags{:values {:prop "-server", :val #malli.core.Tag{:key :s, :value "foo"}}}
+; #malli.core.Tags{:values {:prop "-verbose", :val #malli.core.Tag{:key :b, :value true}}}
+; #malli.core.Tags{:values {:prop "-user", :val #malli.core.Tag{:key :s, :value "joe"}}}]
+
 ```
 
 `m/parser` to create an optimized parser:
@@ -2471,13 +2472,25 @@ Schemas can be used to parse values using `m/parse` and `m/parser`:
 (parse-hiccup
   [:div {:class [:foo :bar]}
    [:p "Hello, world of data"]])
-;[:node
-; {:name :div
-;  :props {:class [:foo :bar]}
-;  :children [[:node
-;              {:name :p
-;               :props nil
-;               :children [[:primitive [:text "Hello, world of data"]]]}]]}]
+
+;#malli.core.Tag
+;{:key :node,
+; :value
+; #malli.core.Tags
+; {:values {:name :div,
+;           :props {:class [:foo :bar]},
+;           :children [#malli.core.Tag
+;                      {:key :node,
+;                       :value
+;                       #malli.core.Tags
+;                       {:values {:name :p,
+;                                 :props nil,
+;                                 :children [#malli.core.Tag
+;                                            {:key :primitive,
+;                                             :value
+;                                             #malli.core.Tag
+;                                             {:key :text,
+;                                              :value "Hello, world of data"}}]}}}]}}}
 ```
 
 Parsing returns tagged values for `:orn`, `:catn`, `:altn` and `:multi`.
@@ -2489,10 +2502,10 @@ Parsing returns tagged values for `:orn`, `:catn`, `:altn` and `:multi`.
    [::m/default :any]])
 
 (m/parse Multi {:type :user, :size 1})
-; => [:user {:type :user, :size 1}]
+; => #malli.core.Tag{:key :user, :value {:type :user, :size 1}}
 
 (m/parse Multi {:type "sized", :size 1})
-; => [:malli.core/default {:type "sized", :size 1}]
+; => #malli.core.Tag{:key :malli.core/default, :value {:type "sized", :size 1}}
 ```
 
 ## Unparsing values
@@ -2508,6 +2521,17 @@ The inverse of parsing, using `m/unparse` and `m/unparser`:
 ; [:p "Hello, world of data"]]
 ```
 
+```clojure
+(m/unparse [:orn [:name :string] [:id :int]]
+           (m/tagged :name "x"))
+; => "x"
+
+(m/unparse [:* [:catn [:name :string] [:id :int]]]
+           [(m/tags {:name "x" :id 1})
+            (m/tags {:name "y" :id 2})])
+; => ["x" 1 "y" 2]
+```
+
 ## Serializable functions
 
 Enabling serializable function schemas requires [SCI](https://github.com/borkdude/sci) or [cherry](https://github.com/squint-cljs/cherry) (for client side) as external dependency. If

src/malli/core.cljc

@@ -148,6 +148,27 @@
 #?(:clj (defmethod print-method ::into-schema [v ^java.io.Writer w] (.write w (str "#IntoSchema{:type " (pr-str (-type ^IntoSchema v)) "}"))))
 #?(:clj (defmethod print-method ::schema [v ^java.io.Writer w] (.write w (pr-str (-form ^Schema v)))))
 
+(defrecord Tag [key value])
+
+(defn tag
+  "A tagged value, used eg. for results of `parse` for `:orn` schemas."
+  [key value] (->Tag key value))
+
+(defn tag?
+  "Is this a value constructed with `tag`?"
+  [x] (instance? Tag x))
+
+(defrecord Tags [values])
+
+(defn tags
+  "A collection of tagged values. `values` should be a map from tag to value.
+   Used eg. for results of `parse` for `:catn` schemas."
+  [values] (->Tags values))
+
+(defn tags?
+  "Is this a value constructed with `tags`?"
+  [x] (instance? Tags x))
+
 ;;
 ;; impl
 ;;
@@ -385,7 +406,7 @@
 ;;
 
 (defn -simple-entry-parser [keyset children forms]
-  (let [entries (map (fn [[k p s]] (miu/-tagged k (-val-schema s p))) children)]
+  (let [entries (map (fn [[k p s]] (miu/-entry k (-val-schema s p))) children)]
     (reify EntryParser
       (-entry-keyset [_] keyset)
       (-entry-children [_] children)
@@ -606,7 +627,7 @@
     (reify EntryParser
       (-entry-keyset [_] keyset)
       (-entry-children [_] @children)
-      (-entry-entries [_] (-vmap (fn [[k p s]] (miu/-tagged k (-val-schema s p))) @children))
+      (-entry-entries [_] (-vmap (fn [[k p s]] (miu/-entry k (-val-schema s p))) @children))
       (-entry-forms [_] (->> @children (-vmap (fn [[k p v]] (if p [k p (-form v)] [k (-form v)]))))))))
 
 (defn -from-entry-ast [parent ast options]
@@ -865,15 +886,15 @@
           (-parser [this]
             (let [parsers (-vmap (fn [[k _ c]]
                                    (let [c (-parser c)]
-                                     (fn [x] (miu/-map-valid #(reduced (miu/-tagged k %)) (c x)))))
+                                     (fn [x] (miu/-map-valid #(reduced (tag k %)) (c x)))))
                                  (-children this))]
               (fn [x] (reduce (fn [_ parser] (parser x)) x parsers))))
           (-unparser [this]
             (let [unparsers (into {} (map (fn [[k _ c]] [k (-unparser c)])) (-children this))]
               (fn [x]
-                (if (miu/-tagged? x)
-                  (if-some [unparse (get unparsers (key x))]
-                    (unparse (val x))
+                (if (tag? x)
+                  (if-some [unparse (get unparsers (:key x))]
+                    (unparse (:value x))
                     ::invalid)
                   ::invalid))))
           (-transformer [this transformer method options]
@@ -1011,6 +1032,8 @@
              ->parser (fn [this f]
                         (let [keyset (-entry-keyset (-entry-parser this))
                               default-parser (some-> @default-schema (f))
+                              ;; prevent unparsing :catn/:orn/etc parse results as maps
+                              ok? #(and (pred? %) (not (tag? %)) (not (tags? %)))
                               parsers (cond->> (-vmap
                                                 (fn [[key {:keys [optional]} schema]]
                                                   (let [parser (f schema)]
@@ -1035,7 +1058,7 @@
                                                 (reduce
                                                  (fn [m k] (if (contains? keyset k) m (reduced (reduced ::invalid))))
                                                  m (keys m)))))]
-                          (fn [x] (if (pred? x) (reduce (fn [m parser] (parser m)) x parsers) ::invalid))))]
+                          (fn [x] (if (ok? x) (reduce (fn [m parser] (parser m)) x parsers) ::invalid))))]
          ^{:type ::schema}
          (reify
            AST
@@ -1645,12 +1668,12 @@
                    (let [->path (if (and (map? x) (keyword? dispatch)) #(conj % dispatch) identity)]
                      (conj acc (miu/-error (->path path) (->path in) this x ::invalid-dispatch-value)))))))
            (-parser [_]
-             (let [parse (fn [k s] (let [p (-parser s)] (fn [x] (miu/-map-valid #(miu/-tagged k %) (p x)))))
+             (let [parse (fn [k s] (let [p (-parser s)] (fn [x] (miu/-map-valid #(tag k %) (p x)))))
                    find (finder (reduce-kv (fn [acc k s] (assoc acc k (parse k s))) {} @dispatch-map))]
                (fn [x] (if-some [parser (find (dispatch x))] (parser x) ::invalid))))
            (-unparser [_]
              (let [unparsers (reduce-kv (fn [acc k s] (assoc acc k (-unparser s))) {} @dispatch-map)]
-               (fn [x] (if (miu/-tagged? x) (if-some [f (unparsers (key x))] (f (val x)) ::invalid) ::invalid))))
+               (fn [x] (if (tag? x) (if-some [f (unparsers (:key x))] (f (:value x)) ::invalid) ::invalid))))
            (-transformer [this transformer method options]
             ;; FIXME: Probably should not use `dispatch`
             ;; Can't use `dispatch` as `x` might not be valid before it has been unparsed:
@@ -2683,15 +2706,15 @@
    :catn (-sequence-entry-schema {:type :catn, :child-bounds {}, :keep false
                                   :re-validator (fn [_ children] (apply re/cat-validator children))
                                   :re-explainer (fn [_ children] (apply re/cat-explainer children))
-                                  :re-parser (fn [_ children] (apply re/catn-parser children))
-                                  :re-unparser (fn [_ children] (apply re/catn-unparser children))
+                                  :re-parser (fn [_ children] (apply re/catn-parser tags children))
+                                  :re-unparser (fn [_ children] (apply re/catn-unparser tags? children))
                                   :re-transformer (fn [_ children] (apply re/cat-transformer children))
                                   :re-min-max (fn [_ children] (reduce (partial -re-min-max +) {:min 0, :max 0} (-vmap last children)))})
    :altn (-sequence-entry-schema {:type :altn, :child-bounds {:min 1}, :keep false
                                   :re-validator (fn [_ children] (apply re/alt-validator children))
                                   :re-explainer (fn [_ children] (apply re/alt-explainer children))
-                                  :re-parser (fn [_ children] (apply re/altn-parser children))
-                                  :re-unparser (fn [_ children] (apply re/altn-unparser children))
+                                  :re-parser (fn [_ children] (apply re/altn-parser tag children))
+                                  :re-unparser (fn [_ children] (apply re/altn-unparser tag? children))
                                   :re-transformer (fn [_ children] (apply re/alt-transformer children))
                                   :re-min-max (fn [_ children] (reduce -re-alt-min-max {:max 0} (-vmap last children)))})})
 

src/malli/destructure.cljc

@@ -1,7 +1,6 @@
 (ns malli.destructure
   (:require [clojure.walk :as walk]
-            [malli.core :as m]
-            [malli.impl.util :as miu]))
+            [malli.core :as m]))
 
 (defn -map-like? [x] (or (map? x) (and (seqable? x) (every? (fn [e] (and (vector? e) (= 2 (count e)))) x))))
 (defn -qualified-key? [k] (and (qualified-keyword? k) (-> k name #{"keys" "syms"})))
@@ -62,10 +61,10 @@
 (defn -any? [x] (= :any x))
 (defn -maybe? [x] (and (vector? x) (= :maybe (first x))))
 
-(defn -vector [{:keys [as elems rest]} options]
-  (or (some->> as :schema :schema (conj [:schema]))
+(defn -vector [{{:keys [as elems rest]} :values} options]
+  (or (some->> as :values :schema :values :schema (conj [:schema]))
       (let [ess (map #(let [s (-transform % options false)] (cond->> s (not (-maybe? s)) (conj [:?]))) elems)
-            rs (if rest (-transform (:arg rest) options true) [:* :any])]
+            rs (if rest (-transform (:arg (:values rest)) options true) [:* :any])]
         [:maybe (if (seq ess) (-> [:cat] (into ess) (conj rs)) [:cat rs])])))
 
 (defn -qualified-keys [m]
@@ -78,7 +77,7 @@
   (let [any (fn [f ks] (map (fn [k] [(f k) :any]) ks))]
     (->> (concat (any keyword keys) (any str strs) (any identity syms)
                  (map (fn [k] [k (if (and references (qualified-keyword? k)) k :any)]) (-qualified-keys arg))
-                 (map (fn [[k v]] [v (-transform {:arg k} options false)]) (filter #(miu/-tagged? (key %)) arg)))
+                 (map (fn [[k v]] [v (-transform (m/tags {:arg k}) options false)]) (filter #(m/tag? (key %)) arg)))
          (distinct))))
 
 (defn -map [arg {:keys [::references ::required-keys ::closed-maps ::sequential-maps]
@@ -96,19 +95,19 @@
                                      (cond->> :always (conj [:*]) (not rest) (conj [:schema])))]]
       schema)))
 
-(defn -transform [{[k v] :arg schema :schema :as all} options rest]
+(defn -transform [{{{k :key v :value} :arg schema :schema :as all} :values} options rest]
   (cond (and schema rest) (let [s (-transform all options false)] (if (-any? s) schema s))
         schema schema
         (= :vec k) (-vector v options)
         (= :map k) (-map v options rest)
         rest [:* :any]
         :else :any))
 
-(defn -schema [{:keys [elems rest]} options]
+(defn -schema [{{:keys [elems rest]} :values} options]
   (cond-> :cat
     (or (seq elems) rest) (vector)
     (seq elems) (into (map #(-transform % options false) elems))
-    rest (conj (-transform (:arg rest) options true))))
+    rest (conj (-transform (:arg (:values rest)) options true))))
 
 (defn -unschematize [x]
   (walk/prewalk #(cond-> % (and (map? %) (:- %)) (dissoc :- :schema)) x))

src/malli/experimental.cljc

@@ -36,13 +36,14 @@
 (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 return doc arities] body-meta :meta :as parsed} (:values (m/parse schema args))
+        return (:values return)
         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))
+        parse (fn [parsed] (merge (md/parse (-> parsed :values :args)) (:values parsed)))
         ->schema (fn [{:keys [schema]}] [:=> schema (:schema return :any)])
-        single (= :single (key arities))
-        parglists (if single (->> arities val parse vector) (->> arities val :arities (map parse)))
+        single (= :single (:key arities))
+        parglists (if single (->> arities :value parse vector) (->> arities :value :values :arities (map parse)))
         raw-arglists (map :raw-arglist parglists)
         schema (as-> (map ->schema parglists) $ (if single (first $) (into [:function] $)))
         bodies (map (fn [{:keys [arglist prepost body]}] `(~arglist ~prepost ~@body)) parglists)
@@ -60,7 +61,7 @@
                        ~@(some-> doc vector)
                        ~enriched-meta
                        ~@bodies
-                       ~@(when-not single (some->> arities val :meta vector))))]
+                       ~@(when-not single (some->> arities :value :meta vector))))]
        (m/=> ~name ~schema)
        defn#)))
 

src/malli/impl/regex.cljc

@@ -172,14 +172,15 @@
                     (reverse (cons r rs)))]
      (fn [driver regs pos coll k] (sp driver regs [] pos coll k)))))
 
+;; we need to pass in the malli.core/tags function as an arg to avoid a cyclic reference
 (defn catn-parser
-  ([] (fn [_ _ pos coll k] (k {} pos coll)))
-  ([kr & krs]
+  ([tags] (fn [_ _ pos coll k] (k (tags {}) pos coll)))
+  ([tags kr & krs]
    (let [sp (reduce (fn [acc [tag r]]
                       (fn [driver regs m pos coll k]
                         (r driver regs pos coll
                            (fn [v pos coll] (acc driver regs (assoc m tag v) pos coll k)))))
-                    (fn [_ _ m pos coll k] (k m pos coll))
+                    (fn [_ _ m pos coll k] (k (tags m) pos coll))
                     (reverse (cons kr krs)))]
      (fn [driver regs pos coll k] (sp driver regs {} pos coll k)))))
 
@@ -191,12 +192,13 @@
                               [] unparsers)
         :malli.core/invalid))))
 
-(defn catn-unparser [& unparsers]
+;; cyclic ref avoidance here as well for malli.core/tags?
+(defn catn-unparser [tags? & unparsers]
   (let [unparsers (apply array-map (mapcat identity unparsers))]
     (fn [m]
-      (if (and (map? m) (= (count m) (count unparsers)))
+      (if (and (tags? m) (= (count (:values m)) (count unparsers)))
         (miu/-reduce-kv-valid (fn [coll tag unparser]
-                                (if-some [kv (find m tag)]
+                                (if-some [kv (find (:values m) tag)]
                                   (miu/-map-valid #(into coll %) (unparser (val kv)))
                                   :malli.core/invalid))
                               ;; `m` is in hash order, so have to iterate over `unparsers` to restore seq order:
@@ -237,27 +239,29 @@
               (park-validator! driver r regs pos coll k)))
           rs))
 
-(defn altn-parser [kr & krs]
-  (reduce (fn [r [tag r*]]
-            (let [r* (fmap-parser (fn [v] (miu/-tagged tag v)) r*)]
+;; cyclic ref avoidance for malli.core/tag
+(defn altn-parser [tag kr & krs]
+  (reduce (fn [r [t r*]]
+            (let [r* (fmap-parser (fn [v] (tag t v)) r*)]
               (fn [driver regs pos coll k]
                 (park-validator! driver r* regs pos coll k) ; remember fallback
                 (park-validator! driver r regs pos coll k))))
-          (let [[tag r] kr]
-            (fmap-parser (fn [v] (miu/-tagged tag v)) r))
+          (let [[t r] kr]
+            (fmap-parser (fn [v] (tag t v)) r))
           krs))
 
 (defn alt-unparser [& unparsers]
   (fn [x]
     (reduce (fn [_ unparse] (miu/-map-valid reduced (unparse x)))
             :malli.core/invalid unparsers)))
 
-(defn altn-unparser [& unparsers]
+;; cyclic ref avoidance for malli.core/tag?
+(defn altn-unparser [tag? & unparsers]
   (let [unparsers (into {} unparsers)]
     (fn [x]
-      (if (miu/-tagged? x)
-        (if-some [kv (find unparsers (key x))]
-          ((val kv) (val x))
+      (if (tag? x)
+        (if-some [kv (find unparsers (:key x))]
+          ((val kv) (:value x))
           :malli.core/invalid)
         :malli.core/invalid))))
 

src/malli/impl/util.cljc

@@ -5,8 +5,7 @@
 
 (def ^:const +max-size+ #?(:clj Long/MAX_VALUE, :cljs (.-MAX_VALUE js/Number)))
 
-(defn -tagged [k v] #?(:clj (MapEntry. k v), :cljs (MapEntry. k v nil)))
-(defn -tagged? [v] (instance? MapEntry v))
+(defn -entry [k v] #?(:clj (MapEntry. k v), :cljs (MapEntry. k v nil)))
 
 (defn -invalid? [x] #?(:clj (identical? x :malli.core/invalid), :cljs (keyword-identical? x :malli.core/invalid)))
 (defn -map-valid [f v] (if (-invalid? v) v (f v)))