destr.clj

(refer-clojure :exclude [destructure])

(def ^:private reduce1 @#'clojure.core/reduce1)

(defn- emit-get
  [gmap bk local defaults]
  (if (contains? defaults local)
    (list `get gmap bk (defaults local))
    (list `get gmap bk)))

;;redefine let and loop  with destructuring
(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)
                                                           (if (next ~gmapseq)
                                                             (clojure.lang.PersistentArrayMap/createAsIfByAssoc (to-array ~gmapseq))
                                                             (if (seq ~gmapseq) (first ~gmapseq) clojure.lang.PersistentArrayMap/EMPTY))
                                                           ~gmap))
                                      ((fn [ret]
                                         (if (:as b)
                                           (conj ret (:as b) gmap)
                                           ret))))
                              state (let [transforms
                                            (reduce1
                                              (fn [transforms mk]
                                                (if (keyword? mk)
                                                  (let [mkns (namespace mk)
                                                        mkn (name mk)]
                                                    (cond (= mkn "keys") (assoc transforms mk {:xform            #(keyword (or mkns (namespace %)) (name %))
                                                                                               :emit             emit-get})
                                                          (= mkn "syms") (assoc transforms mk {:xform            #(list `quote (symbol (or mkns (namespace %)) (name %)))
                                                                                               :emit             emit-get})
                                                          (= mkn "strs") (assoc transforms mk {:xform            str
                                                                                               :emit             emit-get})
                                                          :else transforms))
                                                  transforms))
                                              {}
                                              (keys b))]
                                      (reduce1
                                          (fn [[bes emits] entry]
                                            (let [{:keys [xform emit]} (val entry)
                                                  names     ((key entry) bes)
                                                  new-bes   (reduce1 #(assoc %1 %2 (xform %2))
                                                                     (dissoc bes (key entry))
                                                                     names)
                                                  new-emits (reduce1 #(assoc %1 %2 emit) emits names)]
                                              [new-bes new-emits]))
                                          [(dissoc b :as :or) {}]
                                          transforms))]
                         (let [[bes emits] state]
                           (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)
                                   emit-fn (get emits bb emit-get)
                                   bv (emit-fn gmap bk local defaults)]
                               (recur (cond
                                        (nil? bv)   ret
                                        (ident? bb) (-> ret (conj local bv))
                                        :else       (pb ret bb bv))
                                      [(next bes) emits]))
                             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))))