Skip to content

Commit

Permalink
feat: use a custom Tagged record instead of MapEntry in parse output
Browse files Browse the repository at this point in the history
Using a MapEntry was confusing users, because it printed like a
vector, but you couldn't give a vector to unparse.

The current method of using MapEntry was broken for weird schemas:

```
(def schema
  [:or
   [:tuple :string :keyword]
   [:orn ["any" :keyword]]])

(->> (m/parse schema :any) (m/unparse schema))
; => ["any" :any]
; should've been :any
```

Changes the parse behaviour for (at least) :orn, :altn and :multi

Some place (like the entry parsers) used miu/-tagged to generate
MapEntry values. These use sites now use the new miu/-entry. This
keeps the surface area of this change a lot smaller since we don't
need to touch all the map entry logic.

fixes #1123
replaces #1140
  • Loading branch information
opqdonut committed Dec 16, 2024
1 parent 440de1b commit d6ad000
Show file tree
Hide file tree
Showing 9 changed files with 37 additions and 29 deletions.
10 changes: 5 additions & 5 deletions src/malli/core.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -385,7 +385,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)
Expand Down Expand Up @@ -606,7 +606,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]
Expand Down Expand Up @@ -872,8 +872,8 @@
(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-some [unparse (get unparsers (:key x))]
(unparse (:value x))
::invalid)
::invalid))))
(-transformer [this transformer method options]
Expand Down Expand Up @@ -1650,7 +1650,7 @@
(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 (miu/-tagged? 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:
Expand Down
2 changes: 1 addition & 1 deletion src/malli/destructure.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -96,7 +96,7 @@
(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} options rest]
(cond (and schema rest) (let [s (-transform all options false)] (if (-any? s) schema s))
schema schema
(= :vec k) (-vector v options)
Expand Down
6 changes: 3 additions & 3 deletions src/malli/experimental.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -41,8 +41,8 @@
_ (when (= ::m/invalid parsed) (m/-fail! ::parse-error {:schema schema, :args args}))
parse (fn [{:keys [args] :as parsed}] (merge (md/parse args) 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 :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)
Expand All @@ -60,7 +60,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#)))

Expand Down
4 changes: 2 additions & 2 deletions src/malli/impl/regex.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -256,8 +256,8 @@
(let [unparsers (into {} unparsers)]
(fn [x]
(if (miu/-tagged? x)
(if-some [kv (find unparsers (key x))]
((val kv) (val x))
(if-some [kv (find unparsers (:key x))]
((val kv) (:value x))
:malli.core/invalid)
:malli.core/invalid))))

Expand Down
8 changes: 6 additions & 2 deletions src/malli/impl/util.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -5,8 +5,12 @@

(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)))

(defrecord Tagged [key value])

(defn -tagged [key value] (->Tagged key value))
(defn -tagged? [x] (instance? Tagged x))

(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)))
Expand Down
20 changes: 12 additions & 8 deletions test/malli/core_test.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -257,6 +257,7 @@
(is (= (miu/-tagged :pos 1) (m/parse schema* 1)))
(is (= ::m/invalid (m/parse schema* 0)))
(is (= 1 (m/unparse schema* (miu/-tagged :pos 1))))
(is (= ::m/invalid (m/unparse schema* [:pos 1])))
(is (= ::m/invalid (m/unparse schema* (miu/-tagged :pos 0))))

(doseq [schema [schema schema*]]
Expand Down Expand Up @@ -1169,8 +1170,11 @@
(is (= ::m/invalid (m/parse schema invalid5)))
(is (= ::m/invalid (m/parse schema invalid6)))
(is (= valid1 (m/unparse schema (m/parse schema valid1))))
(is (= valid1 (m/unparse schema (miu/-tagged :sized valid1))))
(is (= valid2 (m/unparse schema (m/parse schema valid2))))
(is (= valid2 (m/unparse schema (miu/-tagged :human valid2))))
(is (= valid3 (m/unparse schema (m/parse schema valid3))))
(is (= valid3 (m/unparse schema (miu/-tagged :sized valid3))))
(is (= ::m/invalid (m/unparse schema invalid1)))
(is (= ::m/invalid (m/unparse schema invalid2)))
(is (= ::m/invalid (m/unparse schema invalid3)))
Expand Down Expand Up @@ -3206,10 +3210,10 @@
["name" 'str]
[::m/default [:map-of 'str 'str]]]
valid {:id 1, "name" "tommi", "kikka" "kukka", "abba" "jabba"}]
(is (= {:id [::int 1],
"name" [::str "tommi"]
[::str "kikka"] [::str "kukka"]
[::str "abba"] [::str "jabba"]}
(is (= {:id (miu/-tagged ::int 1)
"name" (miu/-tagged ::str "tommi")
(miu/-tagged ::str "kikka") (miu/-tagged ::str "kukka")
(miu/-tagged ::str "abba") (miu/-tagged ::str "jabba")}
(m/parse schema valid)))
(is (= valid (->> valid (m/parse schema) (m/unparse schema))))
(is (= ::m/invalid (m/parse schema {"kukka" 42})))))
Expand Down Expand Up @@ -3310,7 +3314,7 @@
value [:a]]
(is (= true (m/validate schema value)))
(is (= nil (m/explain schema value)))
(is (= [[:a :a]] (m/parse schema value)))
(is (= [(miu/-tagged :a :a)] (m/parse schema value)))
(is (= value (m/unparse schema (m/parse schema value))))
(is (= value (m/decode schema value nil))))))

Expand Down Expand Up @@ -3422,14 +3426,14 @@
parsed (m/parse [:seqable [:orn [:l :int] [:r :boolean]]] original)
unparsed (m/unparse [:seqable [:orn [:l :int] [:r :boolean]]] parsed)]
(is (= original unparsed))
(is (= [[:l 0] [:r true] [:l 1] [:r false] [:l 2] [:r true] [:l 3] [:r false] [:l 4] [:r true] [:l 5]
[:r false] [:l 6] [:r true] [:l 7] [:r false] [:l 8] [:r true] [:l 9] [:r false]]
(is (= [(miu/-tagged :l 0) (miu/-tagged :r true) (miu/-tagged :l 1) (miu/-tagged :r false) (miu/-tagged :l 2) (miu/-tagged :r true) (miu/-tagged :l 3) (miu/-tagged :r false) (miu/-tagged :l 4) (miu/-tagged :r true) (miu/-tagged :l 5)
(miu/-tagged :r false) (miu/-tagged :l 6) (miu/-tagged :r true) (miu/-tagged :l 7) (miu/-tagged :r false) (miu/-tagged :l 8) (miu/-tagged :r true) (miu/-tagged :l 9) (miu/-tagged :r false)]
parsed)))
(let [original (sorted-set 1 2 3)
parsed (m/parse [:seqable [:orn [:a :int]]] original)
unparsed (m/unparse [:seqable [:orn [:a :int]]] parsed)]
(is (= unparsed [1 2 3]))
(is (= parsed [[:a 1] [:a 2] [:a 3]]))))
(is (= parsed [(miu/-tagged :a 1) (miu/-tagged :a 2) (miu/-tagged :a 3)]))))

(deftest every-schema-test
(is (m/validate [:every :int] nil))
Expand Down
8 changes: 4 additions & 4 deletions test/malli/destructure_test.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -52,8 +52,8 @@
['d {:optional true} :any]
['demo/e {:optional true} :any]
[:demo/f {:optional true}]
[:demo/g {:optional true}]
[123 {:optional true} :any]]]
[123 {:optional true} :any]
[:demo/g {:optional true}]]]
[:args [:schema
[:*
[:alt
Expand All @@ -62,9 +62,9 @@
[:cat [:= 'd] :any]
[:cat [:= 'demo/e] :any]
[:cat [:= :demo/f] :demo/f]
[:cat [:= :demo/g] :demo/g]
[:cat [:= 123] :any]
[:cat [:not [:enum :b "c" 'd 'demo/e :demo/f :demo/g 123]] :any]]]]]]]
[:cat [:= :demo/g] :demo/g]
[:cat [:not [:enum :b "c" 'd 'demo/e :demo/f 123 :demo/g]] :any]]]]]]]
:errors '[[{::keysz [z]}]
[{:kikka/keyz [z]}]]}
{:name "map destructuring with required-keys"
Expand Down
2 changes: 1 addition & 1 deletion test/malli/distributive_test.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -139,7 +139,7 @@
[4 [:map [:y [:= 2]] [:z [:= 4]]]]]]])))

(deftest parse-distributive-multi-test
(is (= [1 [3 {:y 1, :z 3}]]
(is (= (miu/-tagged 1 (miu/-tagged 3 {:y 1, :z 3}))
(m/parse
[:merge
[:multi {:dispatch :y}
Expand Down
6 changes: 3 additions & 3 deletions test/malli/util_test.cljc
Original file line number Diff line number Diff line change
Expand Up @@ -878,7 +878,7 @@
[:z {:optional true} :boolean]] (m/form (m/deref s))))
(is (= true (m/validate s {:x "x", :y 1, :z true})))
(is (= false (m/validate s {:x "x", :y "y"})))
(is (= {:x [:str "x"], :y 1, :z true} (m/parse s {:x "x", :y 1, :z true})))))
(is (= {:x (miu/-tagged :str "x"), :y 1, :z true} (m/parse s {:x "x", :y 1, :z true})))))

(testing "union"
(let [s (->> [:union
Expand All @@ -891,7 +891,7 @@
(is (= [:map [:x [:or [:orn [:str :string]] :int]]] (m/form (m/deref s))))
(is (= true (m/validate s {:x "x"}) (m/validate s {:x 1})))
(is (= false (m/validate s {:x true})))
(is (= {:x [:str "x"]} (m/parse s {:x "x"})))
(is (= {:x (miu/-tagged :str "x")} (m/parse s {:x "x"})))
(is (= {:x 1} (m/parse s {:x 1})))))

(testing "merge vs union"
Expand Down Expand Up @@ -942,7 +942,7 @@
(m/form (m/deref s))))
(is (= true (m/validate s {:x "x", :z "z"})))
(is (= false (m/validate s {:x "x", :y "y" :z "z"})))
(is (= {:x [:str "x"], :z "z"} (m/parse s {:x "x", :z "z"})))))))
(is (= {:x (miu/-tagged :str "x"), :z "z"} (m/parse s {:x "x", :z "z"})))))))

(def Int (m/schema int?))

Expand Down

0 comments on commit d6ad000

Please sign in to comment.