Since I had most of the parts under my hand, here it is.
First some imports and tooling to deal with destructuring forms:
(def ^:private reduce1 @#'clojure.core/reduce1)
(use 'clojure.pprint)
(declare disentangle)
(defn- disentangle-sequential [binding-form]
(let [as (->> binding-form (drop-while #(not= % :as)) second)
more (->> binding-form (drop-while #(not= % '&)) second)
items (->> binding-form (remove (set (remove nil? [:as '& as more])))
vec)]
(->> {:items items :as as :more more}
(filter val)
(into {}))))
(defn- disentangle-associative [binding-form]
(let [as (binding-form :as)
or (binding-form :or)
ks (binding-form :keys)
others (dissoc binding-form :as :or :keys)
items (vec (distinct (concat ks (keys others))))
mapping (merge (zipmap ks (map keyword ks))
others)]
(->> {:items items :as as :or or :mapping mapping}
(filter val)
(into {}))))
(defn disentangle
"Parses one level of destructuring.
(disentangle '[a b & [c]])
=> '{:items [a b], :more [c]}
(disentangle '{:keys [a] b :b [c1 c2] :c :or {d 1} :as m})
=> '{:items [a b [c1 c2]],
:as m,
:or {d 1},
:mapping {a :a, b :b, [c1 c2] :c}}"
[binding-form]
(cond
(or (sequential? binding-form) (nil? binding-form))
( disentangle-sequential binding-form)
(map? binding-form)
( disentangle-associative binding-form)
:else (throw (Exception. (str "Cannot disentangle " binding-form)))))
Wait, wait, wait, I forgot to pop a song: https://www.youtube.com/watch?v=-JqFp6q8798
Ok, now, let’s rewrite clojure.core/destructure:
;; To highlight modifications ...
(defmacro ---HERE--------------------- [& body]
`(do ~@body))
;; ...to the source code of clojure.core/destructure
;; Note: Here the goal is to support a :& key in destructuring maps.
(defn destructure& [bindings]
(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 (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
(list `nth gvec n nil)))
(inc n)
(next bs)
seen-rest?))))
ret))))
pmap
(fn [bvec b v]
(let [gmap (gensym "map__")
gmapseq (with-meta gmap {:tag 'clojure.lang.ISeq})
defaults (:or b)]
(loop [ret (-> bvec (conj gmap) (conj v)
(conj gmap) (conj `(if (seq? ~gmap) (clojure.lang.PersistentHashMap/create (seq ~gmapseq)) ~gmap))
((fn [ret]
(let [ret (if (:as b)
(conj ret (:as b) gmap)
ret)
ret (---HERE---------------------
(if (:& b)
(conj ret
(:& b)
`(dissoc ~gmap ~@(-> (select-keys b [:keys :syms :strs])
(assoc :inline (-> b disentangle :mapping (dissoc :&) vals))
(->> (mapcat (fn [[k vs]]
(case k
(:inline :keys) (map keyword vs)
:sym (map #(do `(quote ~(symbol (name %)))) vs)
:strs (map name vs))))
vec))))
ret))]
ret))))
bes (let [transforms
(reduce1
(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))]
(reduce1
(fn [bes entry]
(reduce1 #(assoc %1 %2 ((val entry) %2))
(dissoc bes (key entry))
((key entry) bes)))
(dissoc b :as :or
(---HERE---------------------
:&))
transforms))]
(if (seq bes)
(let [bb (key (first bes))
bk (val (first bes))
local (if (instance? clojure.lang.Named 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 (ident? bb)
(-> ret (conj local bv))
(pb ret bb bv))
(next bes)))
ret))))]
(cond
(symbol? b) (-> bvec (conj b) (conj v))
(vector? b) (pvec bvec b v)
(map? b) (pmap bvec b v)
:else (throw (new Exception (str "Unsupported binding form: " b))))))
process-entry (fn [bvec b] (pb bvec (first b) (second b)))]
(if (every? symbol? (map first bents))
bindings
(reduce1 process-entry [] bents))))
Let’s test it out:
(let [destr (destructure& '[{:keys [a b] :& more} {:a 1 :b 2 :c 3 :d 4}])]
(pprint destr) (newline)
(comment
[map__7307
{:a 1, :b 2, :c 3, :d 4}
map__7307
(if
(clojure.core/seq? map__7307)
(clojure.lang.PersistentHashMap/create (clojure.core/seq map__7307))
map__7307)
more
(apply clojure.core/dissoc map__7307 [:a :b])
a
(clojure.core/get map__7307 :a)
b
(clojure.core/get map__7307 :b)]))
Seems to work.
Now let’s wrap this behavior into a let&
macro.
(defmacro let& [bindings & body]
`(let ~(destructure& bindings)
~@body))
But are we going to use this raw, like cavemen ? No. We’re sophisticated people, we’re going to cook it with a macro. What should this macro do ? Allow for various binding styles to cohabit in the same binding vector.
(xlet [ a 1
:binding *file* "."
:with-open r (clojure.java.io/input-stream "myfile.txt")]
body...)
should expand to
(let [a 1]
(binding [*file* "."]
(with-open [r (clojure.java.io/input-stream "myfile.txt")]
body...)))
Here is the code for this:
(require '[clojure.spec.alpha :as s])
(s/def ::xlet-bindings
(s/+ (s/cat
:style (s/? keyword?)
:binding-expr #(or (symbol? %) (map? %) (vector? %))
:bound-expr any?)))
(defn xlet* [[{:keys [:style :binding-expr :bound-expr]} & more-bindings] body]
`(~(or (some->> (some-> style str
(as-> $ (if (= (first $) \:)
(rest $)
$)))
(apply str) symbol)
'clojure.core/let)
[~binding-expr ~bound-expr]
~@(if (empty? more-bindings)
body
[(xlet* more-bindings body)])))
(defmacro xlet [bindings & body]
(let [bds (s/conform ::xlet-bindings bindings)]
(xlet* bds body)))
And to test the whole:
(xlet [ the-map {:a 1 :b 2 :c [3] :d 4}
:let& {:keys [a] bb :b [c] :c :& more} the-map]
(println "the-map" the-map) (newline)
(comment the-map {:a 1, :b 2, :c [3], :d 4})
(println "[a bb c]" [a bb c]) (newline)
(comment [1 2 3])
(println "more" more) (newline)
(comment more {:d 4}))
Gist: https://gist.github.com/TristeFigure/822965f159eb5c578fb958cc301f070b
She think she need me, girl you gon’ make it
Drink got me leaning, trap got me faded