|
| 1 | +(ns cherry.internal.destructure |
| 2 | + (:refer-clojure :exclude [destructure])) |
| 3 | + |
| 4 | +(defn destructure [bindings] |
| 5 | + (let [bents (partition 2 bindings) |
| 6 | + pb (fn pb [bvec b v] |
| 7 | + (let [pvec |
| 8 | + (fn [bvec b val] |
| 9 | + (let [gvec (gensym "vec__") |
| 10 | + gseq (gensym "seq__") |
| 11 | + gfirst (gensym "first__") |
| 12 | + has-rest (some #{'&} b)] |
| 13 | + (loop [ret (let [ret (conj bvec gvec val)] |
| 14 | + (if has-rest |
| 15 | + (conj ret gseq (list `seq gvec)) |
| 16 | + ret)) |
| 17 | + n 0 |
| 18 | + bs b |
| 19 | + seen-rest? false] |
| 20 | + (if (seq bs) |
| 21 | + (let [firstb (first bs)] |
| 22 | + (cond |
| 23 | + (= firstb '&) (recur (pb ret (second bs) gseq) |
| 24 | + n |
| 25 | + (nnext bs) |
| 26 | + true) |
| 27 | + (= firstb :as) (pb ret (second bs) gvec) |
| 28 | + :else (if seen-rest? |
| 29 | + (throw #?(:clj (new Exception "Unsupported binding form, only :as can follow & parameter") |
| 30 | + :cljs (new js/Error "Unsupported binding form, only :as can follow & parameter"))) |
| 31 | + (recur (pb (if has-rest |
| 32 | + (conj ret |
| 33 | + gfirst `(first ~gseq) |
| 34 | + gseq `(next ~gseq)) |
| 35 | + ret) |
| 36 | + firstb |
| 37 | + (if has-rest |
| 38 | + gfirst |
| 39 | + (list `nth gvec n nil))) |
| 40 | + (inc n) |
| 41 | + (next bs) |
| 42 | + seen-rest?)))) |
| 43 | + ret)))) |
| 44 | + pmap |
| 45 | + (fn [bvec b v] |
| 46 | + (let [gmap (gensym "map__") |
| 47 | + defaults (:or b)] |
| 48 | + (loop [ret (-> bvec (conj gmap) (conj v) |
| 49 | + (conj gmap) (conj (list 'cljs.core/--destructure-map gmap)) |
| 50 | + ((fn [ret] |
| 51 | + (if (:as b) |
| 52 | + (conj ret (:as b) gmap) |
| 53 | + ret)))) |
| 54 | + bes (let [transforms |
| 55 | + (reduce |
| 56 | + (fn [transforms mk] |
| 57 | + (if (keyword? mk) |
| 58 | + (let [mkns (namespace mk) |
| 59 | + mkn (name mk)] |
| 60 | + (cond (= mkn "keys") (assoc transforms mk #(keyword (or mkns (namespace %)) (name %))) |
| 61 | + (= mkn "syms") (assoc transforms mk #(list `quote (symbol (or mkns (namespace %)) (name %)))) |
| 62 | + (= mkn "strs") (assoc transforms mk str) |
| 63 | + :else transforms)) |
| 64 | + transforms)) |
| 65 | + {} |
| 66 | + (keys b))] |
| 67 | + (reduce |
| 68 | + (fn [bes entry] |
| 69 | + (reduce #(assoc %1 %2 ((val entry) %2)) |
| 70 | + (dissoc bes (key entry)) |
| 71 | + ((key entry) bes))) |
| 72 | + (dissoc b :as :or) |
| 73 | + transforms))] |
| 74 | + (if (seq bes) |
| 75 | + (let [bb (key (first bes)) |
| 76 | + bk (val (first bes)) |
| 77 | + local (if #?(:clj (instance? clojure.lang.Named bb) |
| 78 | + :cljs (cljs.core/implements? INamed bb)) |
| 79 | + (with-meta (symbol nil (name bb)) (meta bb)) |
| 80 | + bb) |
| 81 | + bv (if (contains? defaults local) |
| 82 | + (list 'cljs.get gmap bk (defaults local)) |
| 83 | + (list 'cljs.core/get gmap bk))] |
| 84 | + (recur |
| 85 | + (if (or (keyword? bb) (symbol? bb)) ;(ident? bb) |
| 86 | + (-> ret (conj local bv)) |
| 87 | + (pb ret bb bv)) |
| 88 | + (next bes))) |
| 89 | + ret))))] |
| 90 | + (cond |
| 91 | + (symbol? b) (-> bvec (conj (if (namespace b) (symbol (name b)) b)) (conj v)) |
| 92 | + (keyword? b) (-> bvec (conj (symbol (name b))) (conj v)) |
| 93 | + (vector? b) (pvec bvec b v) |
| 94 | + (map? b) (pmap bvec b v) |
| 95 | + :else (throw |
| 96 | + #?(:clj (new Exception (str "Unsupported binding form: " b)) |
| 97 | + :cljs (new js/Error (str "Unsupported binding form: " b))))))) |
| 98 | + process-entry (fn [bvec b] (pb bvec (first b) (second b)))] |
| 99 | + (if (every? symbol? (map first bents)) |
| 100 | + bindings |
| 101 | + (if-let [kwbs (seq (filter #(keyword? (first %)) bents))] |
| 102 | + (throw |
| 103 | + #?(:clj (new Exception (str "Unsupported binding key: " (ffirst kwbs))) |
| 104 | + :cljs (new js/Error (str "Unsupported binding key: " (ffirst kwbs))))) |
| 105 | + (reduce process-entry [] bents))))) |
| 106 | + |
| 107 | +(defn maybe-destructured |
| 108 | + [params body] |
| 109 | + (if (every? symbol? params) |
| 110 | + (cons params body) |
| 111 | + (loop [params params |
| 112 | + new-params (with-meta [] (meta params)) |
| 113 | + lets []] |
| 114 | + (if params |
| 115 | + (if (symbol? (first params)) |
| 116 | + (recur (next params) (conj new-params (first params)) lets) |
| 117 | + (let [gparam (gensym "p__")] |
| 118 | + (recur (next params) (conj new-params gparam) |
| 119 | + (-> lets (conj (first params)) (conj gparam))))) |
| 120 | + `(~new-params |
| 121 | + (let ~lets |
| 122 | + ~@body)))))) |
| 123 | + |
| 124 | +(defn core-let |
| 125 | + [bindings body] |
| 126 | + #_(assert-args let |
| 127 | + (vector? bindings) "a vector for its binding" |
| 128 | + (even? (count bindings)) "an even number of forms in binding vector") |
| 129 | + `(cljs.core/let* ~(destructure bindings) ~@body)) |
0 commit comments