diff --git a/src/main/cljs/cljs/core/specs/alpha.cljc b/src/main/cljs/cljs/core/specs/alpha.cljc index d393951b0..76a73e5e4 100644 --- a/src/main/cljs/cljs/core/specs/alpha.cljc +++ b/src/main/cljs/cljs/core/specs/alpha.cljc @@ -45,10 +45,12 @@ (s/def ::as ::local-name) (s/def ::defaults ::local-name) (s/def ::select ::local-name) +(s/def ::excess ::local-name) +(s/def ::missing ::local-name) (s/def ::all ::local-name) (s/def ::map-special-binding - (s/keys :opt-un [::as ::or ::keys ::syms ::strs ::keys! ::syms! ::strs! ::select ::defaults ::all])) + (s/keys :opt-un [::as ::or ::keys ::syms ::strs ::keys! ::syms! ::strs! ::select ::excess ::missing ::defaults ::all])) (s/def ::map-binding (s/tuple ::binding-form any?)) @@ -60,7 +62,7 @@ (s/def ::map-bindings (s/every (s/or :map-binding ::map-binding :qualified-keys-or-syms ::ns-keys - :special-binding (s/tuple #{:as :or :keys :syms :strs :keys! :syms! :strs! :select :defaults :all} any?)) + :special-binding (s/tuple #{:as :or :keys :syms :strs :keys! :syms! :strs! :select :excess :missing :defaults :all} any?)) :kind map?)) (s/def ::map-binding-form (s/merge ::map-bindings ::map-special-binding)) diff --git a/src/main/clojure/cljs/core.cljc b/src/main/clojure/cljs/core.cljc index c735659bf..e8d4fe146 100644 --- a/src/main/clojure/cljs/core.cljc +++ b/src/main/clojure/cljs/core.cljc @@ -667,7 +667,7 @@ (core/defn ^:private destmap* [pb bvec b v] (core/let [gmap (gensym "map__") - gignore (gensym "ignore__") + gtemp (gensym "temp__") defaults (:or b) defaults-as (:defaults b) _ (core/when (core/and defaults-as (core/not defaults)) @@ -677,6 +677,10 @@ gdefaults (core/when defaults (zipmap (keys defaults) (repeatedly #(gensym "default__")))) select (:select b) all (:all b) + excess (:excess b) + missing (:missing b) + gnotfound (core/when missing (gensym "notfound__")) + gnotfound? (core/when missing (gensym "notfound?__")) xf (core/fn [mk] (core/let [mkns (namespace mk) mkn (name mk)] @@ -696,7 +700,12 @@ (if (:as b) (conj ret (:as b) gmap) ret)))) - bes (dissoc b :as :or :select :all) + ret (if missing + (conj ret + missing nil + gnotfound (core/list 'new 'js/Object)) + ret) + bes (dissoc b :as :or :select :all :excess :missing) localize (core/fn [bb] (if #?(:clj (core/instance? clojure.lang.Named bb) :cljs (cljs.core/implements? INamed bb)) @@ -718,12 +727,22 @@ :cljs (throw (new js/Error (core/str "Can't supply default value for required key: " bk)))) (core/list `cljs.core/get gmap bk (if local-default? (gdefaults local) (gdefaults bk))))) - (core/list getter gmap bk))] + (if req? + (if missing + (core/list `cljs.core/get gmap bk gnotfound) + (core/list `cljs.core/req! gmap bk)) + (core/list `cljs.core/get gmap bk)))] (if (ident? bb) - (core/-> ret (conj local bv)) + (if (core/and req? missing) + (conj ret + gtemp bv + gnotfound? `(identical? ~gtemp ~gnotfound) + missing `(if ~gnotfound? (assoc ~missing ~bk nil) ~missing) + local `(when-not ~gnotfound? ~gtemp)) + (core/-> ret (conj local bv))) (pb ret bb bv)))) retsel - (core/loop [ret ret, sel #{}, bes bes, b->k {}, subs nil, suba nil] + (core/loop [ret ret, sel #{}, bes bes, b->k {}, subs nil, suba nil, subexcess nil submissing nil] (if (seq bes) (core/let [be (first bes), bb (key be), bk (val be)] (if (core/keyword? bb) @@ -740,7 +759,7 @@ #?(:clj (throw (new IllegalArgumentException (core/str "& can only appear once in " dir))) :cljs (throw (new js/Error (core/str "& can only appear once in " dir))))) (core/let [_ - (core/when (core/and (not preamp?) (core/symbol? bb)) + (core/when (core/and (core/not preamp?) (core/symbol? bb)) #?(:clj (throw (new IllegalArgumentException (core/str "'" bb @@ -751,13 +770,13 @@ "' - binding symbols can only appear before '&', use keys after"))))) bk (if preamp? (tr bb) bb)] (recur (if (core/or preamp? req?) - (push1 ret (if preamp? bb gignore) bk req?) + (push1 ret (if preamp? bb gtemp) bk req?) ret) (conj sel bk) (next bbs) preamp? (if preamp? (assoc b->k (localize bb) bk) b->k))))) {:ret ret, :sel sel, :b->k b->k}))] - (recur (:ret retsel) (:sel retsel) (next bes) (:b->k retsel) subs suba)) + (recur (:ret retsel) (:sel retsel) (next bes) (:b->k retsel) subs suba subexcess submissing)) (core/let [subsel? (core/and select (map? bb)) bb (if (core/or (core/not subsel?) (:select bb)) bb @@ -768,10 +787,23 @@ bb (assoc bb :all (gensym "all__"))) suba (if suball? (assoc suba bk (:all bb)) suba) + + subexcess? (core/and excess (map? bb)) + bb (if (core/or (core/not subexcess?) (:excess bb)) + bb + (assoc bb :excess (gensym "excess__"))) + subexcess (if subexcess? (assoc subexcess bk (:excess bb)) subexcess) + + submissing? (core/and missing (map? bb)) + bb (if (core/or (core/not submissing?) (:missing bb)) + bb + (assoc bb :missing (gensym "missing__"))) + submissing (if submissing? (assoc submissing bk (:missing bb)) submissing) + b->k (if (core/symbol? bb) (assoc b->k bb bk) b->k)] - (recur (push1 ret bb bk false) (conj sel bk) (next bes) b->k subs suba)))) - {:ret ret, :sel sel, :b->k b->k :subs subs :suba suba})) - ret (:ret retsel), sel (:sel retsel), b->k (:b->k retsel) + (recur (push1 ret bb bk false) (conj sel bk) (next bes) b->k subs suba subexcess submissing)))) + {:ret ret, :sel sel, :b->k b->k :subs subs :suba suba :subexcess subexcess :submissing submissing})) + ret (:ret retsel), sel (vec (:sel retsel)), b->k (:b->k retsel) new-or-code (core/and defaults (core/or defaults-as select all)) bk #(if (core/symbol? %) (core/let [bk (b->k %)] @@ -780,7 +812,7 @@ :cljs (throw (new js/Error (core/str "symbol " % " in :or does not refer to a binding"))))) bk) %) - dm (core/when defaults (dissoc (zipmap (map bk (keys gdefaults)) (vals gdefaults)) nil)) + dm (core/when defaults (zipmap (map bk (keys gdefaults)) (vals gdefaults))) _ (core/and new-or-code (core/not= (count (select-keys dm sel)) (count defaults)) #?(:clj (throw (new IllegalArgumentException (core/str "keys " (apply disj (set (keys dm)) sel) @@ -788,13 +820,23 @@ :cljs (throw (new js/Error (core/str "keys " (apply disj (set (keys dm)) sel) " appear only in :or"))))) + dm (if (empty? dm) nil dm) ret (if select - (conj ret select `(when-let [mm# (merge (some-vals ~dm) ~gmap (some-vals ~(:subs retsel)))] + (conj ret select `(when-let [mm# (merge ~dm ~gmap (some-vals ~(:subs retsel)))] (select-keys mm# ~sel))) ret) ret (if all - (conj ret all `(merge (some-vals ~dm) ~gmap (some-vals ~(:suba retsel)))) + (conj ret all `(merge ~dm ~gmap (some-vals ~(:suba retsel)))) + ret) + + ret (if excess + (conj ret excess `(merge (not-empty (apply dissoc ~gmap ~sel)) (some-vals ~(:subexcess retsel)))) + ret) + + ret (if missing + (conj ret missing `(merge ~missing (some-vals ~(:submissing retsel)))) ret) + ret (if defaults-as (conj ret defaults-as dm) ret)] ret)) diff --git a/src/test/cljs/cljs/destructuring_test.cljs b/src/test/cljs/cljs/destructuring_test.cljs index 4dfcdd114..a38b4d17c 100644 --- a/src/test/cljs/cljs/destructuring_test.cljs +++ b/src/test/cljs/cljs/destructuring_test.cljs @@ -424,6 +424,140 @@ (is (= 1 (let [{:keys [a & 'b]} {:a 1}] a))) (is (= 1 (let [{:keys! [a & 'b "c"]} {:a 1, 'b 2, "c" 3}] a))))))) +(deftest excess + (let [sample-map {:a 1, :b 2, :c {:aa 10}, + 'd 4 'e 5 'f {'dd 40 'ee 50}, + "g" 6 "h" 7 "i" {"gg" 60 "hh" 70}}] + (testing "happy path" + (let [{:keys [a] :excess exa} (select-keys sample-map [:a :b :c]) + {:keys [a b c] :excess exnil} (select-keys sample-map [:a :b :c]) + {{:excess exnest} :c} sample-map + {:keys [a c] :excess exkws} (select-keys sample-map [:a :b :c]) + {:syms [d f] :excess exsyms} (select-keys sample-map '[d e f]) + {:strs [g i] :excess exstrs} (select-keys sample-map ["g" "h" "i"])] + (is (= {:b 2 :c {:aa 10}} exa)) + (is (= {:aa 10} exnest)) + (is (= {:b 2} exkws)) + (is (= '{e 5} exsyms)) + (is (= {"h" 7} exstrs)) + + (testing ":excess predicative use" + (is (nil? exnil)) + (is (nil? (let [{:excess ex} {}] ex))) + (is (nil? (let [{:keys [a] :excess ex} nil] ex))) + + (let [{:keys [a] :excess ex-some} (select-keys sample-map [:a :b :c]) + {:keys [a b c] :excess ex-none} (assoc (select-keys sample-map [:a :b :c]) :b nil)] + (is (some-vals ex-some)) + (is (not (some-vals ex-none))))))) + + (testing ":excess retains nil values" + (let [{:keys [a] :excess ex-nil1} (assoc (select-keys sample-map [:a :b :c]) :b nil) + {{:keys [aa] :excess ex-nil2} :c} (assoc-in sample-map [:c :bb] nil)] + (is (= {:b nil :c {:aa 10}} ex-nil1)) + (is (= {:bb nil} ex-nil2)))) + + (testing ":excess and :or to ensure that defaults do not show up" + (let [{:keys [a z] :or {z 99} :excess exor} (select-keys sample-map [:a :b :c])] + (is (= {:b 2 :c {:aa 10}} exor)))) + + (testing "nested :excess, also with &" + (let [{:keys [a] {:keys [aa] :excess exc} :c} sample-map + {:keys! [a & :b :c] + :syms! [& 'd 'e 'f] + :strs! [& "g" "h" "i"] + {:keys [zz] :or {:zz 999} :excess exinner1} :c + {:syms [yy] :or {'yy 999} :excess exinner2} 'f + {:strs [xx] :or {"xx" 999} :excess exinner3} "i" + :excess exouter} sample-map] + (is (nil? exc)) + (is (= {:aa 10} exinner1)) + (is (= {'dd 40 'ee 50} exinner2)) + (is (= {"gg" 60 "hh" 70} exinner3)) + (is (= '{:c {:aa 10}, f {dd 40, ee 50}, "i" {"gg" 60, "hh" 70}} exouter)))) + + (testing ":excess with namespace-qualification" + (let [nsmap {:foo/x 1000, :foo/y 2000, ::z 3000} + {:foo/keys [x] :excess exfoo} nsmap + {::keys [z] :excess exauto} nsmap + {:foo/keys [x] ::keys [z] :excess exmix} nsmap + {:foo/keys [x y] ::keys [z] :excess exall} nsmap] + (is (= {:foo/y 2000 ::z 3000} exfoo)) + (is (= {:foo/x 1000 :foo/y 2000} exauto)) + (is (= {:foo/y 2000} exmix)) + (is (nil? exall)))))) + +(deftest missing-directive + (let [keys-map {:a 1 :b 2 :nest {:aa 10}} + {:keys! [a b], :missing mkeys-nil} keys-map + {:keys! [a b c], :missing mkeys-c} keys-map + {:keys! [a b & :c], :missing mkeys-c&} keys-map + + syms-map '{a 1 b 2 nest {aa 10}} + {:syms! [a b], :missing msyms-nil} syms-map + {:syms! [a b c], :missing msyms-c} syms-map + {:syms! [a b & 'c], :missing msyms-c&} syms-map + + strs-map {"a" 1 "b" 2 "nest" {"aa" 10}} + {:strs! [a b], :missing mstrs-nil} strs-map + {:strs! [a b c], :missing mstrs-c} strs-map + {:strs! [a b & "c"], :missing mstrs-c&} strs-map + + q-map {:foo/a 1 :b 2 :foo/c 3 ::d 4} + {:keys! [foo/a :foo/c] :missing mq-nil} q-map + {:keys! [b & :foo/d] :missing mq-d} q-map + {:keys! [foo/a & :foo/d] :missing mq-d&} q-map + {:foo/keys! [a c] :missing q-nil} q-map + {:foo/keys! [a & :foo/d] :missing q-d} q-map + {:foo/keys! [a & :foo/d] :missing q-d&} q-map + {::keys! [d] :missing aq-nil} q-map] + + (testing "1-level :missing keys for keys/qkeys/syms/strs" + (is (nil? mkeys-nil)) + (is (= mkeys-c {:c nil})) + (is (= mkeys-c& {:c nil})) + + (is (nil? msyms-nil)) + (is (= msyms-c '{c nil})) + (is (= msyms-c& '{c nil})) + + (is (nil? mstrs-nil)) + (is (= mstrs-c {"c" nil})) + (is (= mstrs-c& {"c" nil})) + + (is (nil? mq-nil)) + (is (= mq-d #:foo{:d nil})) + (is (= mq-d& #:foo{:d nil})) + (is (nil? q-nil)) + (is (= q-d #:foo{:d nil})) + (is (= q-d& #:foo{:d nil})) + (is (nil? aq-nil))) + + (testing "required nested map that also has required keys, covering the following cases: + - :nest is missing + - :nest is nil + - :nest is a map missing :x and/or :y + - :nest is a map having everything that's required" + (let [sample-nest {:a 0 :b 0}] + (are [input-map expected] (= expected + (let [{:keys! [a b & :nest] + {:keys! [x y]} :nest + :missing mkeys-missing} + input-map] + mkeys-missing)) + + sample-nest {:nest {:x nil, :y nil}} + + (assoc sample-nest :nest nil) {:nest {:x nil, :y nil}} + + (assoc sample-nest :nest {:x 1}) {:nest {:y nil}} + + (assoc sample-nest :nest {:x 1 :y 2}) nil))) + + (testing "that a nested map required keys is captured with the outer :missing" + (let [{:keys! [a b], {:keys! [bb]} :nest :missing mkeys-outer} keys-map] + (is (= mkeys-outer {:nest {:bb nil}})))))) + (comment (cljs.test/run-tests)