From c27eb4dd09b7fa7f8923174d93463abf3c7af9c2 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Sat, 25 Jul 2026 17:54:46 +0200 Subject: [PATCH 1/2] Clojure 1.13 destructuring --- script/test/cljd | 2 +- src/sci/impl/destructure.cljc | 285 +++++++++++++++++++++------------ src/sci/impl/namespaces.cljc | 27 ++++ test/sci/destructure_test.cljc | 206 ++++++++++++++++++++++++ test/sci/test_runner.cljs | 2 + 5 files changed, 421 insertions(+), 101 deletions(-) create mode 100644 test/sci/destructure_test.cljc diff --git a/script/test/cljd b/script/test/cljd index 7cd9a5727..3484649bb 100755 --- a/script/test/cljd +++ b/script/test/cljd @@ -11,7 +11,7 @@ fi # Test namespaces that compile and pass on ClojureDart. Extend this list as # more of SCI is ported. -default_namespaces=(sci.core-test sci.error-test sci.vars-test sci.namespaces-test sci.io-test sci.repl-test sci.impl.analyzer-test sci.impl.binding-array-refactor-test sci.multimethods-test sci.protocols-test sci.core-protocols-test sci.defrecords-and-deftype-test sci.reify-test sci.cljd-interop-test sci.parse-test sci.impl.vars-test) +default_namespaces=(sci.core-test sci.destructure-test sci.error-test sci.vars-test sci.namespaces-test sci.io-test sci.repl-test sci.impl.analyzer-test sci.impl.binding-array-refactor-test sci.multimethods-test sci.protocols-test sci.core-protocols-test sci.defrecords-and-deftype-test sci.reify-test sci.cljd-interop-test sci.parse-test sci.impl.vars-test) if [ $# -gt 0 ]; then namespaces=("$@") diff --git a/src/sci/impl/destructure.cljc b/src/sci/impl/destructure.cljc index 3bd6ab3af..490a289f2 100644 --- a/src/sci/impl/destructure.cljc +++ b/src/sci/impl/destructure.cljc @@ -1,114 +1,199 @@ (ns sci.impl.destructure "Destructure function, adapted from Clojure and ClojureScript." {:no-doc true} - (:refer-clojure :exclude [destructure])) + (:refer-clojure :exclude [destructure]) + (:require [clojure.string :as str])) + +(defn- destructure-error [msg] + (throw #?(:cljs (new js/Error msg) + :default (new Exception msg)))) + +;; Emitted as symbols rather than as embedded values. clojure.core/req! and +;; clojure.core/some-vals only exist in sci's own clojure.core, not necessarily +;; in the host, and sci resolves a clojure.core/ prefix on every dialect. +(def ^:private req!-sym 'clojure.core/req!) +(def ^:private some-vals-sym 'clojure.core/some-vals) +(def ^:private merge-sym 'clojure.core/merge) +(def ^:private select-keys-sym 'clojure.core/select-keys) +(def ^:private when-let-sym 'clojure.core/when-let) + +(defn- destvec* + [pb bvec b val loc] + (let [gvec (gensym "vec__") + gseq (gensym "seq__") + gfirst (gensym "first__") + has-rest (some #{'&} b)] + (loop [ret (let [ret (conj bvec gvec val)] + (if has-rest + (conj ret gseq (list seq gvec)) + ret)) + n 0 + bs b + seen-rest? false] + (if (seq bs) + (let [firstb (first bs)] + (cond + (= firstb '&) (recur (pb ret (second bs) gseq) + n + (nnext bs) + true) + (= firstb :as) (pb ret (second bs) gvec) + :else (if seen-rest? + (destructure-error "Unsupported binding form, only :as can follow & parameter") + (recur (pb (if has-rest + (conj ret + gfirst `(~first ~gseq) + gseq `(~next ~gseq)) + ret) + firstb + (if has-rest + gfirst + (cond-> (list nth gvec n nil) + loc (with-meta loc)))) + (inc n) + (next bs) + seen-rest?)))) + ret)))) + +(defn- destmap* + [pb bvec b v] + (let [gmap (gensym "map__") + gignore (gensym "ignore__") + defaults (:or b) + defaults-as (:defaults b) + _ (when (and defaults-as (not defaults)) + (destructure-error "Can't specify :defaults without :or")) + b (dissoc b :defaults) + gdefaults (when defaults (zipmap (keys defaults) (repeatedly #(gensym "default__")))) + select (:select b) + all (:all b) + xf (fn [mk] + (let [mkns (namespace mk) + mkn (name mk)] + (cond (str/starts-with? mkn "keys") #(keyword (or mkns (namespace %)) (name %)) + (str/starts-with? mkn "syms") #(list 'quote (symbol (or mkns (namespace %)) (name %))) + (str/starts-with? mkn "strs") str + :else (destructure-error (str "Unsupported map directive: " mk))))) + ret (reduce (fn [ret e] + (conj ret (val e) (defaults (key e)))) + bvec gdefaults) + ret (-> ret (conj gmap) (conj v) + (conj gmap) + (conj (list 'if (list seq? gmap) + `(clojure.core/seq-to-map-for-destructuring ~gmap) + gmap)) + ((fn [ret] + (if (:as b) + (conj ret (:as b) gmap) + ret)))) + bes (dissoc b :as :or :select :all) + localize (fn [bb] (if #?(:cljd (satisfies? INamed bb) + :clj (instance? clojure.lang.Named bb) + :cljs (implements? INamed bb)) + (with-meta (symbol nil (name bb)) (meta bb)) + bb)) + push1 (fn [ret bb bk req?] + (let [getter (if req? req!-sym `get) + local (localize bb) + local-default? (contains? defaults local) + key-default? (contains? defaults bk) + bv (if (or local-default? key-default?) + (if (and local-default? key-default?) + (destructure-error + (str "Multiple :or defaults for same key: " bk " '" local "'")) + (if req? + (destructure-error + (str "Can't supply default value for required key: " bk)) + (list `get gmap bk (if local-default? + (gdefaults local) + (gdefaults bk))))) + (list getter gmap bk))] + (if (or (keyword? bb) (symbol? bb)) ;(ident? bb) + (-> ret (conj local bv)) + (pb ret bb bv)))) + retsel + (loop [ret ret, sel #{}, bes bes, b->k {}, subs nil, suba nil] + (if (seq bes) + (let [be (first bes), bb (key be), bk (val be)] + (if (keyword? bb) + (let [dir bb + tr (xf bb) + req? (str/ends-with? (name bb) "!") + retsel + (loop [ret ret, sel sel, bbs (seq bk), preamp? true, b->k b->k] + (if (seq bbs) + (let [bb (first bbs)] + (if (= bb '&) + (if preamp? + (recur ret sel (next bbs) false b->k) + (destructure-error (str "& can only appear once in " dir))) + (let [_ (when (and (not preamp?) (symbol? bb)) + (destructure-error + (str "'" bb "' - binding symbols can only appear before '&', use keys after"))) + bk (if preamp? (tr bb) bb)] + (recur (if (or preamp? req?) + (push1 ret (if preamp? bb gignore) 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)) + (let [subsel? (and select (map? bb)) + bb (if (or (not subsel?) (:select bb)) + bb + (assoc bb :select (gensym "select__"))) + subs (if subsel? (assoc subs bk (:select bb)) subs) + suball? (and all (map? bb)) + bb (if (or (not suball?) (:all bb)) + bb + (assoc bb :all (gensym "all__"))) + suba (if suball? (assoc suba bk (:all bb)) suba) + b->k (if (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) + new-or-code (and defaults (or defaults-as select all)) + bk #(if (symbol? %) + (let [bk (b->k %)] + (when (and new-or-code (not bk)) + (destructure-error (str "symbol " % " in :or does not refer to a binding"))) + bk) + %) + dm (when defaults (dissoc (zipmap (map bk (keys gdefaults)) (vals gdefaults)) nil)) + _ (and new-or-code (not= (count (select-keys dm sel)) (count defaults)) + (destructure-error (str "keys " + (apply disj (set (keys dm)) sel) + " appear only in :or"))) + merged (fn [subs] + (list merge-sym (list some-vals-sym dm) gmap (list some-vals-sym subs))) + ret (if select + (let [mm (gensym "mm__")] + (conj ret select + (list when-let-sym [mm (merged (:subs retsel))] + (list select-keys-sym mm sel)))) + ret) + ret (if all + (conj ret all (merged (:suba retsel))) + ret) + ret (if defaults-as (conj ret defaults-as dm) ret)] + ret)) (defn destructure* [bindings loc] (let [bents (partition 2 bindings) pb (fn pb [bvec b v] - (let [pvec - (fn [bvec b val] - (let [gvec (gensym "vec__") - gseq (gensym "seq__") - gfirst (gensym "first__") - has-rest (some #{'&} b)] - (loop [ret (let [ret (conj bvec gvec val)] - (if has-rest - (conj ret gseq (list seq gvec)) - ret)) - n 0 - bs b - seen-rest? false] - (if (seq bs) - (let [firstb (first bs)] - (cond - (= firstb '&) (recur (pb ret (second bs) gseq) - n - (nnext bs) - true) - (= firstb :as) (pb ret (second bs) gvec) - :else (if seen-rest? - (throw #?(:cljs (new js/Error "Unsupported binding form, only :as can follow & parameter") - :default (new Exception "Unsupported binding form, only :as can follow & parameter"))) - (recur (pb (if has-rest - (conj ret - gfirst `(~first ~gseq) - gseq `(~next ~gseq)) - ret) - firstb - (if has-rest - gfirst - (cond-> (list nth gvec n nil) - loc (with-meta loc)))) - (inc n) - (next bs) - seen-rest?)))) - ret)))) - pmap - (fn [bvec b v] - (let [gmap (gensym "map__") - defaults (:or b)] - (loop [ret (-> bvec (conj gmap) (conj v) - (conj gmap) (conj (list 'if (list seq? gmap) - `(clojure.core/seq-to-map-for-destructuring ~gmap) - gmap)) - ((fn [ret] - (if (:as b) - (conj ret (:as b) gmap) - ret)))) - bes (let [transforms - (reduce - (fn [transforms mk] - (if (keyword? mk) - (let [mkns (namespace mk) - mkn (name mk)] - (cond (= mkn "keys") (assoc transforms mk #(keyword (or mkns (namespace %)) (name %))) - (= mkn "syms") (assoc transforms mk #(list `quote (symbol (or mkns (namespace %)) (name %)))) - (= mkn "strs") (assoc transforms mk str) - :else transforms)) - transforms)) - {} - (keys b))] - (reduce - (fn [bes entry] - (reduce #(assoc %1 %2 ((val entry) %2)) - (dissoc bes (key entry)) - ((key entry) bes))) - (dissoc b :as :or) - transforms))] - (if (seq bes) - (let [bb (key (first bes)) - bk (val (first bes)) - local (if #?(:cljd (satisfies? INamed bb) - :clj (instance? clojure.lang.Named bb) - :cljs (implements? INamed bb)) - (with-meta (symbol nil (name bb)) (meta bb)) - bb) - bv (if (contains? defaults local) - (list `get gmap bk (defaults local)) - (list `get gmap bk))] - (recur - (if (or (keyword? bb) (symbol? bb)) ;(ident? bb) - (-> ret (conj local bv)) - (pb ret bb bv)) - (next bes))) - ret))))] - (cond - (symbol? b) (-> bvec (conj (if (namespace b) - (symbol (name b)) b)) (conj v)) - (keyword? b) (-> bvec (conj (symbol (name b))) (conj v)) - (vector? b) (pvec bvec b v) - (map? b) (pmap bvec b v) - :else (throw - #?(:cljs (new js/Error (str "Unsupported binding form: " b)) - :default (new Exception (str "Unsupported binding form: " b))))))) + (cond + (symbol? b) (-> bvec (conj (if (namespace b) + (symbol (name b)) b)) (conj v)) + (keyword? b) (-> bvec (conj (symbol (name b))) (conj v)) + (vector? b) (destvec* pb bvec b v loc) + (map? b) (destmap* pb bvec b v) + :else (destructure-error (str "Unsupported binding form: " b)))) process-entry (fn [bvec b] (pb bvec (first b) (second b)))] (if (every? symbol? (map first bents)) bindings (if-let [kwbs (seq (filter #(keyword? (first %)) bents))] - (throw - #?(:cljs (new js/Error (str "Unsupported binding key: " (ffirst kwbs))) - :default (new Exception (str "Unsupported binding key: " (ffirst kwbs))))) + (destructure-error (str "Unsupported binding key: " (ffirst kwbs))) (reduce process-entry [] bents))))) (defn destructure diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index d26c094c7..7ff6dcbad 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -993,6 +993,31 @@ (.createAsIfByAssoc PersistentArrayMap (to-array s)) (if (seq s) (first s) (.-EMPTY PersistentArrayMap)))))) +;;;; Clojure 1.13 destructuring + +(def ^:private req-not-found #?(:cljd ^:unique (Object.) + :clj (Object.) + :cljs (js/Object.))) + +(defn req!* + "Like arity-2 'get', but throws if key not present." + [m k] + (let [v (get m k req-not-found)] + (if (identical? v req-not-found) + (throw (new #?(:cljd ArgumentError + :clj IllegalArgumentException + :cljs js/Error) + (str "Missing required key: " (if (string? k) (pr-str k) k)))) + v))) + +(defn some-vals* + "Returns a map with only the non-nil values of map m. Returns nil if + m has no non-nil vals." + [m] + (reduce-kv + (fn [m k v] (if (some? v) (assoc m k v) m)) + nil m)) + #?(:clj (def clojure-version-var (sci.impl.utils/dynamic-var '*clojure-version* (update clojure.core/*clojure-version* @@ -1809,6 +1834,7 @@ 'reduce-kv (copy-core-var reduce-kv) 'reduced (copy-core-var reduced) 'reduced? (copy-core-var reduced?) + 'req! (copy-var req!* clojure-core-ns {:name 'req!}) 'reset! #?(:cljs (copy-core-var reset!) :default (copy-var core-protocols/reset!* clojure-core-ns {:name 'reset!})) 'reset-thread-binding-frame-impl (new-var 'reset-thread-binding-frame-impl sci.impl.vars/reset-thread-binding-frame) @@ -1830,6 +1856,7 @@ 'simple-keyword? (copy-core-var simple-keyword?) 'simple-symbol? (copy-core-var simple-symbol?) 'some? (copy-core-var some?) + 'some-vals (copy-var some-vals* clojure-core-ns {:name 'some-vals}) 'some-> (macrofy 'some-> some->*) 'some->> (macrofy 'some->> some->>*) 'string? (copy-core-var string?) diff --git a/test/sci/destructure_test.cljc b/test/sci/destructure_test.cljc new file mode 100644 index 000000000..12f1efcbd --- /dev/null +++ b/test/sci/destructure_test.cljc @@ -0,0 +1,206 @@ +(ns sci.destructure-test + (:require + [clojure.test :as t :refer [deftest is testing]] + [sci.core :as sci])) + +(defn eval* [form] + (sci/eval-string (pr-str form))) + +;; sci wraps both analysis and runtime errors in ex-info, which is not an +;; Exception on ClojureDart +(defn throws? [form] + (try (eval* form) + false + (catch #?(:cljd cljd.core/ExceptionInfo + :clj Exception + :cljs js/Error) _ true))) + +(deftest req!-test + (let [m {:a 1, :b 2, :f nil, :g false, nil "nil"}] + (is (throws? (list 'req! m :e))) + (is (= 1 (eval* (list 'req! m :a)))) + (is (= "nil" (eval* (list 'req! m nil)))) + (is (= 2 (eval* (list 'req! m :b)))) + (is (nil? (eval* (list 'req! m :f)))) + (is (= false (eval* (list 'req! m :g))))) + (testing "lookup follows get, not just maps" + (is (throws? '(req! nil :a))) + (is (= 2 (eval* '(req! [1 2] 1)))) + (is (throws? '(req! [1 2] 5))) + (is (= :a (eval* '(req! #{:a} :a)))) + (is (throws? '(req! #{:a} :b))))) + +(deftest some-vals-test + (is (= {:a 1} (eval* '(some-vals {:a 1 :b nil})))) + (is (nil? (eval* '(some-vals {:a nil})))) + (is (nil? (eval* '(some-vals nil)))) + (is (= {:a false} (eval* '(some-vals {:a false})))) + (is (= '{a 1} (eval* '(some-vals '{a 1 b nil}))))) + +(deftest keys-bang-test + (testing ":keys! binds and throws when key missing" + (is (= 1 (eval* '(let [{:keys! [a b]} {:a 1 :b 2}] a)))) + (is (throws? '(let [{:keys! [a b]} {:a 1}] a)))) + (testing ":keys! with & requires keys after & without binding them" + (is (= 1 (eval* '(let [{:keys! [a & :b]} {:a 1 :b 2}] a)))) + (is (throws? '(let [{:keys! [a & :b]} {:a 1}] a)))) + (testing "nested maps with :keys! &" + (let [m {:a 1 :b {:a 2 :b 3 :c 4 :d 42}}] + (is (= [(:b m) 1 2 3 4] + (eval* (list 'let ['{a :a {aa :a :as m :keys! [b c & :d]} :b} m] + '[m a aa b c])))) + (is (throws? (list 'let ['{a :a {:keys! [b c & :d :e]} :b} m] 'a))) + (is (throws? (list 'let ['{a :a {:keys! [b c & :d]} :b} (update m :b dissoc :c)] 'a))))) + (testing "qualified names and declarators with :keys! &" + (let [m {:foo/a 1 :b 2 :foo/c 3}] + (is (= 1 (eval* (list 'let ['{:keys! [foo/a & :b]} m] 'a)))) + (is (= 2 (eval* (list 'let ['{:keys! [b & :foo/c]} m] 'b)))) + (is (throws? (list 'let ['{:keys! [b & :foo/c]} (dissoc m :b)] 'b))) + (is (throws? (list 'let ['{:keys! [b & :foo/c]} (dissoc m :foo/c)] 'b))) + (is (= 1 (eval* (list 'let ['{:foo/keys! [aa & :bb]} {:foo/aa 1 :bb 2}] 'aa)))))) + (testing "keys after & are not bound" + (is (throws? '(let [{:keys! [a & :b]} {:a 1 :b 2}] b))) + (is (throws? '(let [{:keys! [foo/a & :foo/c]} {:foo/a 1 :foo/c 2}] c)))) + (testing "& may appear only once" + (is (throws? '(let [{:keys [a & :b & :c]} {:a 1}] a))))) + +(deftest syms-bang-test + (testing ":syms! binds and throws when key missing" + (is (= 1 (eval* '(let [{:syms! [a b]} '{a 1 b 2}] a)))) + (is (throws? '(let [{:syms! [a b]} {:a 1}] a)))) + (testing ":syms! with & requires keys after & without binding them" + (is (= 1 (eval* '(let [{:syms! [a & 'b]} '{a 1 b 2}] a)))) + (is (throws? '(let [{:syms! [a & 'b]} {:a 1}] a)))) + (testing "nested maps with :syms! &" + (let [m '{a 1 b {a 2 b 3 c 4 d 42}}] + (is (= [(get m 'b) 1 2 3 4] + (eval* (list 'let ['{a 'a {aa 'a :as m :syms! [b c & 'd]} 'b} (list 'quote m)] + '[m a aa b c])))) + (is (throws? (list 'let ['{:syms! [b c & 'd 'e]} (list 'quote (get m 'b))] 'b))))) + (testing "qualified names with :syms! &" + (let [m '{foo/a 1 b 2 foo/c 3}] + (is (= 1 (eval* (list 'let ['{:syms! [foo/a & 'b]} (list 'quote m)] 'a)))) + (is (= 2 (eval* (list 'let ['{:syms! [b & 'foo/c]} (list 'quote m)] 'b)))) + (is (throws? (list 'let ['{:syms! [b & 'foo/c]} (list 'quote (dissoc m 'b))] 'b))) + (is (= 1 (eval* (list 'let ['{:foo/syms! [aa & 'bb]} (list 'quote '{foo/aa 1 bb 2})] 'aa)))))) + (testing "keys after & are not bound" + (is (throws? '(let [{:syms! [a & 'b]} '{a 1 b 2}] b))))) + +(deftest strs-bang-test + (testing ":strs! binds and throws when key missing" + (is (= 1 (eval* '(let [{:strs! [a b]} {"a" 1 "b" 2}] a)))) + (is (throws? '(let [{:strs! [a b]} {:a 1}] a)))) + (testing ":strs! with & requires keys after & without binding them" + (is (= 1 (eval* '(let [{:strs! [a & "b"]} {"a" 1 "b" 2}] a)))) + (is (throws? '(let [{:strs! [a & "b"]} {:a 1}] a)))) + (testing "nested maps with :strs! &" + (let [m {"a" 1 "b" {"a" 2 "b" 3 "c" 4 "d" 42}}] + (is (= [(get m "b") 1 2 3 4] + (eval* (list 'let ['{a "a" {aa "a" :as m :strs! [b c & "d"]} "b"} m] + '[m a aa b c])))) + (is (throws? (list 'let ['{a "a" {:strs! [b c & "d" "e"]} "b"} m] 'a))) + (is (throws? (list 'let ['{a "a" {:strs! [b c & "d"]} "b"} (update m "b" dissoc "c")] 'a))))) + (testing "keys after & are not bound" + (is (throws? '(let [{:strs! [a & "b"]} {"a" 1 "b" 2}] b))))) + +(deftest mixed-keys-after-amp-test + (is (= 1 (eval* '(let [{:keys [a & 'b]} {:a 1}] a)))) + (is (= 1 (eval* '(let [{:keys! [a & 'b "c"]} {:a 1 (quote b) 2 "c" 3}] a)))) + (is (throws? '(let [{:keys! [a & 'b "c"]} {:a 1 (quote b) 2}] a)))) + +(deftest select-test + (let [m {:a 1 :b 2 :c 3 :d 4 + 'sa 10 'sb 20 'sc 30 'sd 40 + "stra" 100 "strb" 200 "strc" 300 "strd" 400 + :foo/x 1000 :foo/y 2000 :foo/z 3000 + :nested {:aa 1 'saa 10 "straa" 100}} + sel (fn [binding] (eval* (list 'let [binding (list 'quote m)] 'sel)))] + (testing "select picks up keys mentioned anywhere in the binding form" + (is (= {:a 1 :b 2 :c 3 :d 4} + (sel '{:keys [a b & :c] :keys! [d] :select sel}))) + (is (= '{sa 10 sb 20 sc 30 sd 40} + (sel '{:syms [sa sb & 'sc] :syms! [sd] :select sel}))) + (is (= {"stra" 100 "strb" 200 "strc" 300 "strd" 400} + (sel '{:strs [stra strb & "strc"] :strs! [strd] :select sel}))) + (is (= {:foo/x 1000 :foo/z 3000} + (sel '{:foo/keys [x & :zz] :foo/keys! [z] :select sel})))) + (testing "select descends into nested maps" + (is (= '{:aa 1 saa 10} + (sel '{{aa :aa saa 'saa :select sel} :nested}))) + (is (= '{:nested {:aa 1 saa 10}} + (sel '{{aa :aa saa 'saa} :nested :select sel})))) + (testing "select of everything equals :as" + (is (true? (eval* (list 'let ['{:keys [a b c d] + :syms [sa sb sc sd] + :strs [stra strb strc strd] + :foo/keys! [x y z] + nest :nested + :as mm + :select sel} (list 'quote m)] + '(= sel mm)))))) + (testing "select doesn't fabricate maps" + (is (nil? (eval* '(let [{{a :a} :n :select s} nil] s)))) + (is (= {} (eval* '(let [{{a :a} :n :select s} {}] s)))) + (is (= {:n nil} (eval* '(let [{{a :a} :n :select s} {:n nil}] s)))) + (is (= {:n {}} (eval* '(let [{{a :a} :n :select s} {:n {}}] s))))) + (testing "defaults fill in missing keys" + (is (= {:n {:a 42}} (eval* '(let [{{a :a :or {a 42}} :n :select s} nil] s)))) + (is (= {:n {:a 42}} (eval* '(let [{{a :a :or {a 42}} :n :select s} {:n nil}] s))))))) + +(deftest all-test + (is (= {:a 1 :b 2} (eval* '(let [{:keys [a] :all m} {:a 1 :b 2}] m)))) + (testing ":all keeps keys not mentioned in the binding form" + (is (= {:n {:aa 1 :bb 2} :c 3} + (eval* '(let [{{aa :aa} :n :all m} {:n {:aa 1 :bb 2} :c 3}] m))))) + (testing ":all is augmented by defaults" + (is (= {:a 42 :b 2} (eval* '(let [{:keys [a] :or {a 42} :all m} {:b 2}] m))))) + (testing ":select and :all in the same binding form" + (is (= [{:a 1} {:a 1 :b 2}] + (eval* '(let [{:keys [a] :select s :all m} {:a 1 :b 2}] [s m])))))) + +(deftest defaults-test + (testing ":defaults binds a map of key to default value" + (is (= {} (eval* '(let [{:defaults d :or {}} {}] d)))) + (is (= {:a 1} (eval* '(let [{:keys [a] :defaults d :or {:a 1}} {}] d)))) + (is (= {:a 1} (eval* '(let [{:keys [a] :defaults d :or {a 1}} {}] d))))) + (testing ":defaults without :or is an error" + (is (throws? '(let [{:defaults d} {}] d)))) + (testing "the same key can't have both a binding and a key default" + (is (throws? '(let [{:keys [a] :defaults d :or {:a 1 a 1}} {}] d))))) + +(deftest or-by-key-test + (testing ":or accepts key -> val in addition to binding -> val" + (is (= [1 42] (eval* '(let [{:keys [a b] :or {:b 42}} {:a 1}] [a b])))) + (is (= [1 42] (eval* '(let [{:syms [a b] :or {'b 42}} '{a 1}] [a b])))) + (is (= [1 42] (eval* '(let [{:strs [a b] :or {"b" 42}} {"a" 1}] [a b])))))) + +(deftest or-strictness-test + (testing "with :select, :all or :defaults every :or entry must be a bound key" + (is (throws? '(let [{:keys [a] :or {z 42} :select s} {:a 1}] s))) + (is (throws? '(let [{:keys [a & :b] :or {b 42} :select s} {:a 1}] s))) + (is (throws? '(let [{:keys [a] :or {:z 42} :all m} {:a 1}] m))) + (is (throws? '(let [{:defaults d :or {:a 1}} {}] d))) + (is (throws? '(let [{:keys [a] :or {:a 1 :z 2} :select s} {:a 1}] s)))) + (testing "without the new directives :or is unchecked" + (is (= 1 (eval* '(let [{:keys [a] :or {z 42}} {:a 1}] a)))))) + +(deftest required-key-default-test + (is (throws? '(let [{:keys! [a] :or {a 1}} {}] a)))) + +(deftest unsupported-map-directive-test + (is (throws? '(let [{:vals [a]} {:a 1}] a)))) + +(deftest binding-contexts-test + (testing "fn params" + (is (= [1 2] (eval* '((fn [{:keys! [a b]}] [a b]) {:a 1 :b 2})))) + (is (throws? '((fn [{:keys! [a b]}] [a b]) {:a 1}))) + (is (= {:a 1} (eval* '((fn [{:keys [a] :select s}] s) {:a 1 :b 2}))))) + (testing "kwargs" + (is (= 1 (eval* '((fn [& {:keys! [a]}] a) :a 1)))) + (is (throws? '((fn [& {:keys! [a]}] a) :b 1)))) + (testing "for" + (is (= [1 2] (eval* '(vec (for [{:keys! [a]} [{:a 1} {:a 2}]] a))))) + (is (throws? '(vec (for [{:keys! [a]} [{:a 1} {:b 2}]] a)))) + (is (= [{:a 1}] (eval* '(vec (for [{:keys [a] :select s} [{:a 1 :b 2}]] s)))))) + (testing "loop" + (is (= {:a 1 :b 2} (eval* '(loop [{:keys [a] :all m} {:a 1 :b 2}] m)))))) diff --git a/test/sci/test_runner.cljs b/test/sci/test_runner.cljs index 12e633b20..6ac66eefe 100644 --- a/test/sci/test_runner.cljs +++ b/test/sci/test_runner.cljs @@ -4,6 +4,7 @@ [sci.core-protocols-test] [sci.core-test] [sci.defrecords-and-deftype-test] + [sci.destructure-test] [sci.error-test] [sci.hierarchies-test] [sci.impl.analyzer-test] @@ -47,6 +48,7 @@ (cljs.test/run-tests 'sci.core-protocols-test 'sci.core-test + 'sci.destructure-test 'sci.error-test 'sci.hierarchies-test 'sci.interop-test From 7285f95a323d67b251eb7e6e1352e9ba28a91304 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Sat, 25 Jul 2026 18:11:12 +0200 Subject: [PATCH 2/2] Changelog and upstream sync note --- CHANGELOG.md | 4 ++++ src/sci/impl/destructure.cljc | 3 +++ 2 files changed, 7 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 54d893393..f4cf11acb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,10 @@ SCI is used in [babashka](https://github.com/babashka/babashka), [joyride](https://github.com/BetterThanTomorrow/joyride/) and many [other](https://github.com/babashka/sci#projects-using-sci) projects. +## Unreleased + +- Clojure 1.13 map destructuring: `:keys!`, `:syms!`, `:strs!`, `&` inside a directive, `:select`, `:all` and `:defaults`. Adds `req!` and `some-vals` to `clojure.core`. + ## 0.15.56 Highlight: diff --git a/src/sci/impl/destructure.cljc b/src/sci/impl/destructure.cljc index 490a289f2..622a47fd4 100644 --- a/src/sci/impl/destructure.cljc +++ b/src/sci/impl/destructure.cljc @@ -4,6 +4,9 @@ (:refer-clojure :exclude [destructure]) (:require [clojure.string :as str])) +;; destvec* and destmap* track clojure/clojure core.clj at dd006fb9 (2026-07-24), +;; the commit that added the :all directive. Diff against that when syncing. + (defn- destructure-error [msg] (throw #?(:cljs (new js/Error msg) :default (new Exception msg))))