Skip to content

Instantly share code, notes, and snippets.

@luxbock luxbock/core.clj
Created Jan 14, 2015

What would you like to do?
(ns debug-walker.core
(:refer-clojure :exclude [read-string])
(:require [ :as io]
[clojure.repl :as repl]
[ :refer [read-string]]
[clojure.pprint :refer [pprint]]
[ :as z])
(:import [ LineNumberReader InputStreamReader PushbackReader]))
(defn file-source-fn
"Same as clojure.repl/source-fn but reads the path of :file as a
instead of loading it as a resource from the class path."
(when-let [v (resolve x)]
(when-let [filepath (:file (meta v))]
(when-let [strm (io/input-stream (io/file filepath))]
(with-open [rdr (LineNumberReader. (InputStreamReader. strm))]
(dotimes [_ (dec (:line (meta v)))] (.readLine rdr))
(let [text (StringBuilder.)
pbr (proxy [PushbackReader] [rdr]
(read []
(let [i (proxy-super read)]
(.append text (char i))
(if (= :unkown *read-eval*)
"Unable to read source while *read-eval* is :unknown."))
(read (PushbackReader. pbr)))
(str text)))))))
(defn source-from-symbol [x]
(when-let [v (resolve x)]
(when-let [filepath (:file (meta v))]
(if (.exists (io/file filepath))
(file-source-fn x)
(repl/source-fn x)))))
(defn read-source [x]
(when-let [source-str (source-from-symbol x)]
(read-string source-str)))
(defn destructure*
"Same as clojure.core/destructure except for the line:
ret (-> bvec (conj gvec) (conj (list `quote val)))
where we're returning a quoted form instead."
(let [bents (partition 2 bindings)
pb (fn pb [bvec b v]
(let [pvec
(fn [bvec b val]
(let [gvec (gensym "vec__")]
(loop [ret (-> bvec (conj gvec) (conj (list `quote val)))
n 0
bs b
seen-rest? false]
(if (seq bs)
(let [firstb (first bs)]
(= firstb '&) (recur (pb ret (second bs) (list `nthnext gvec n))
(nnext bs)
(= firstb :as) (pb ret (second bs) gvec)
:else (if seen-rest?
(throw (new Exception "Unsupported binding form, only :as can follow & parameter"))
(recur (pb ret firstb (list `nth gvec n nil))
(inc n)
(next bs)
(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]
(if (:as b)
(conj ret (:as b) gmap)
bes (reduce
(fn [bes entry]
(reduce #(assoc %1 %2 ((val entry) %2))
(dissoc bes (key entry))
((key entry) bes)))
(dissoc b :as :or)
{:keys #(if (keyword? %) % (keyword (str %))),
:strs str, :syms #(list `quote %)})]
(if (seq bes)
(let [bb (key (first bes))
bk (val (first bes))
has-default (contains? defaults bb)]
(recur (pb ret bb (if has-default
(list `get gmap bk (defaults bb))
(list `get gmap bk)))
(next bes)))
(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 (new Exception (str "Unsupported binding form: " b))))))
process-entry (fn [bvec b] (pb bvec (first b) (second b)))]
(if (every? symbol? (map first bents))
(if-let [kwbs (seq (filter #(keyword? (first %)) bents))]
(throw (new Exception (str "Unsupported binding key: " (ffirst kwbs))))
(reduce process-entry [] bents)))))
(defn match-arglist
"Takes a sorted-map of function signature -> body of function and returns the
pair that matches the arguments `as`."
[sign->body as]
(letfn [(match? [a b]
(let [var-arg? (contains? (set b) '&)
bfva (take-while #(not= '& %) b)]
(or (and var-arg? (>= (count a) (count bfva)))
(= (count a) (count b)))))]
(first (drop-while (comp not (partial match? as) first) sign->body))))
(defn destr-gensym? [x]
{:pre [(symbol? x)]}
(#{"vec__" "map__"} (apply str (take 5 (name x)))))
(defn destructure-fnargs [alist as]
(let [bs (destructure* (vector alist as))
syms (take-nth 2 (drop 2 bs))
vals (take-nth 2 (drop 3 bs))]
(into {}
(remove (fn [[k v]] (destr-gensym? k)))
(zipmap syms (eval `(let ~bs [~@vals]))))))
(defn map-args->expr [sexp arglists]
(let [[f & args] sexp
[sign _] (match-arglist arglists args)]
(destructure-fnargs sign args)))
(defn map-signature->body [ars]
(into (sorted-map) (map vec) ars))
(defn macro-call? [form]
(when-let [f (first form)]
(-> f resolve meta :macro)))
(defn fn-expandable? [form]
(when-let [f (first form)]
(when-let [[d n & rs] (read-source f)]
(and (#{'def 'defn} d) (= n f)))))
(defn mex-1-str [form-str]
(->> form-str
(defn handle-defn [[f :as src]]
(if (= f 'defn)
(macroexpand-1 src)
(defn arg-arities
"Expects the function body, already macroexpanded, as a list. Returns a
collection of [args], body tuples."
{:pre [(#{"fn" "fn*"} (name (first fn-body)))]}
(let [[fn args] fn-body]
;; named anonymous function - strip name and recurse
(symbol? args) (arg-arities (cons fn (rest (rest fn-body))))
;; single arity
(vector? args) (list (rest fn-body))
;; multiple arity
(seq? args) (rest fn-body))))
(defn replace-symbols [body sym->expr]
(let [target? (set (keys sym->expr))
root (z/of-string (str body))]
(z/prewalk root
#(target? (z/sexpr %))
#(z/replace % (sym->expr (z/sexpr %)))))))
(defn expand-fn [form-str]
(let [[f & args :as sexp] (read-string form-str)
src (handle-defn (read-source f))
fn-body (nth src 2)
arities (arg-arities fn-body)
sign->body (map-signature->body arities)
[sign body] (match-arglist sign->body args)
arg->expr (map-args->expr sexp sign->body)]
(replace-symbols body arg->expr)))))
(defn transform-fn [form]
(condp #(%1 %2) form
macro-call? mex-1-str
fn-expandable? expand-fn ; TODO
(defn expand-form [form-str]
((transform-fn (read-string form-str)) form-str))
(expand-form "(filter even? (range 20))")
;; =>
(when-let [s (seq (range 20))]
(if (chunked-seq? s)
(let [c (chunk-first s) size (count c) b (chunk-buffer size)]
(dotimes [i size]
(when (even? (.nth c i)) (chunk-append b (.nth c i))))
(chunk-cons (chunk b) (filter even? (chunk-rest s))))
(let [f (first s) r (rest s)]
(if (even? f) (cons f (filter even? r)) (filter even? r))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.