Port CLJ-2979: Implement the selector macro in terms of destructuring and its directives

Co-authored-by: Fogus <mefogus@gmail.com>

Author: swannodette

src/main/clojure/cljs/core.cljc

@@ -855,6 +855,45 @@
       bindings
       (reduce process-entry [] bents))))
 
+(defn- selector-impl [m]
+  (core/let [dirs [:select :excess :missing :all]
+             names (zipmap (filter m dirs) (repeatedly gensym))]
+    (if (empty? names)
+      #?(:clj  (throw (IllegalArgumentException.
+                       "form must contain at least one of :select :excess :missing :all"))
+         :cljs (throw (js/Error. "form must contain at least one of :select :excess :missing :all")))
+      `(fn ~(gensym "selector")
+         [map#]
+         (let [~(merge m names) map#]
+           ~(if (= 1 (count names))
+              (-> names first val)
+              (core/list `some-vals names)))))))
+
+(defmacro selector
+  "Builds a selecting-fn from m, a map destructuring form that must
+  include one or more of the :select, :all, :missing, and :excess
+  directives. The return function takes a collection, destructures it
+  per m, and returns a map of the result(s).
+
+  If m has exactly one directive, the result is the value that
+  directive would yield. If m has more than one directive, then it
+  returns a map of directives to values.
+
+  As in destructuring, :missing controls whether missing required keys
+  throw or are collected.
+
+  While a map destructuring form may and sometimes must include
+  bindings, selector doesn't produce bindings, thus ignoring the
+  associated directive names.
+
+  Throws an exception if the argument is not a map."
+  {:added "1.13"}
+  [m]
+  (when (not (map? m))
+    #?(:clj  (throw (IllegalArgumentException. "expected a map"))
+       :cljs (throw (js/Error. "expected a map"))))
+  (selector-impl m))
+
 (core/defmacro ^:private return-first
   [& body]
   `(let [ret# ~(first body)]

src/test/cljs/cljs/core_test.cljs

@@ -2028,3 +2028,109 @@
     (select-keys {:a 1 :b 2 :c nil} [:a :c :d]) {:a 1 :c nil}
     (select-keys nil [:a]) {}
     (select-keys #{:a :b} [:a :c]) {:a :a}))
+
+(deftest selector-test
+  (let [sample-map {:a 1 :b 2 :c 3 :d 4
+                    :e 5
+                    ::x 10000
+                    :nested {:aa 1 'saa 10}}]
+    (testing "error cases"
+      (is (thrown? Exception (eval '(selector {:keys [a b]}))))
+      (is (thrown? Exception (eval '(selector sample-map))))
+      (is (thrown? Exception (eval '(selector nil))))
+      (is (thrown? Exception (eval '(selector {})))))
+
+    (testing "single directives return their values directly"
+      (let [ex1 (selector {:keys [a b & :c :z]
+                           :keys! [d]
+                           :select keys-sel})]
+        (is (= {:a 1 :b 2 :c 3 :d 4}
+               (ex1 sample-map)))
+
+        (testing "checked keys without :missing should throw"
+          (is (thrown? Exception (ex1 (dissoc sample-map :d)))))
+
+        (testing ":select with :or"
+          (let [ex1 (selector {:keys [a b & :c :z]
+                               :keys! [d]
+                               :select keys-sel
+                               :or {:z 42}})]
+            (is (= {:a 1 :b 2 :c 3 :d 4 :z 42}
+                   (ex1 sample-map))))))
+
+      (let [ex1 (selector {:keys [a b & :c :z]
+                           :keys! [d]
+                           :all keys-all})]
+        (is (= sample-map (ex1 sample-map))))
+
+      (let [ex1 (selector {:keys [a b & :c :z]
+                           :keys! [d]
+                           :missing keys-missing})]
+        (is (nil? (ex1 sample-map)))
+        (is (= {:d nil} (ex1 (dissoc sample-map :d)))))
+
+      (let [ex1 (selector {:keys [a b & :c :z]
+                           :keys! [d]
+                           :excess keys-excess})]
+        (is (= (dissoc sample-map :a :b :c :d) (ex1 sample-map)))))
+
+    (testing ":select plus :missing, but nothing missing"
+      (let [ex2 (selector {:keys [a b & :c :z]
+                           :keys! [d]
+                           :select keys-sel
+                           :missing keys-missing})]
+        (is (= {:select {:a 1 :b 2 :c 3 :d 4}}
+               (ex2 sample-map)))))
+
+    (testing ":select plus :all"
+      (let [ex3 (selector {:keys [a b & :c :z]
+                           :keys! [d]
+                           :select keys-sel
+                           :missing keys-missing
+                           :all keys-all})]
+        (is (= {:select {:a 1 :b 2 :c 3 :d 4}
+                :all sample-map}
+               (ex3 sample-map)))))
+
+    (testing ":select, :all, and :excess"
+      (let [ex4 (selector {:keys [a b & :c :z]
+                           :keys! [d]
+                           :select keys-sel
+                           :missing keys-missing
+                           :all keys-all
+                           :excess keys-excess})]
+        (is (= {:select {:a 1 :b 2 :c 3 :d 4}
+                :excess (dissoc sample-map :a :b :c :d)
+                :all sample-map}
+               (ex4 sample-map)))
+        (testing "plus :missing"
+          (is (= {:d nil}
+                 (:missing (ex4 (dissoc sample-map :d))))))))
+
+    (testing "directive names bound to _"
+      (let [ex_ (selector {:keys [a b & :c :z]
+                           :keys! [d]
+                           :select _
+                           :missing _
+                           :all _
+                           :excess _})]
+        (is (= {:select {:a 1 :b 2 :c 3 :d 4}
+                :excess (dissoc sample-map :a :b :c :d)
+                :all sample-map}
+               (ex_ sample-map)))))
+
+    (testing "nested :select"
+      (let [exnest (selector {{aa :aa saa 'saa
+                               :select nest-sel} :nested
+                              aqx ::x
+                              :select tl-sel})]
+        (is (= {::x 10000 :nested {:aa 1 'saa 10}}
+               (exnest sample-map)))))
+
+    (testing "nested selection behavior with _ bindings"
+      (let [exnest_ (selector {{aa :aa saa 'saa
+                                :select _} :nested
+                               aqx ::x
+                               :select _})]
+        (is (= {::x 10000 :nested {:aa 1 'saa 10}}
+               (exnest_ sample-map)))))))