Skip to content

Instantly share code, notes, and snippets.

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

Embed
What would you like to do?
aaa
(ns debug-walker.core
(:refer-clojure :exclude [read-string])
(:require [clojure.java.io :as io]
[clojure.repl :as repl]
[clojure.tools.reader :refer [read-string]]
[clojure.pprint :refer [pprint]]
[rewrite-clj.zip :as z])
(:import [java.io LineNumberReader InputStreamReader PushbackReader]))
(defn file-source-fn
"Same as clojure.repl/source-fn but reads the path of :file as a java.io.File
instead of loading it as a resource from the class path."
[x]
(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))
i)))]
(if (= :unkown *read-eval*)
(throw
(IllegalStateException.
"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."
[bindings]
(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)]
(cond
(= firstb '&) (recur (pb ret (second bs) (list `nthnext gvec n))
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 ret firstb (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]
(if (:as b)
(conj ret (:as b) gmap)
ret))))
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)))
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 (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
(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
read-string
macroexpand-1
pprint
with-out-str))
(defn handle-defn [[f :as src]]
(if (= f 'defn)
(macroexpand-1 src)
src))
(defn arg-arities
"Expects the function body, already macroexpanded, as a list. Returns a
collection of [args], body tuples."
[fn-body]
{:pre [(#{"fn" "fn*"} (name (first fn-body)))]}
(let [[fn args] fn-body]
(cond
;; 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/sexpr
(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)]
(with-out-str
(pprint
(replace-symbols body arg->expr)))))
(defn transform-fn [form]
(condp #(%1 %2) form
macro-call? mex-1-str
fn-expandable? expand-fn ; TODO
identity))
(defn expand-form [form-str]
((transform-fn (read-string form-str)) form-str))
(comment
(expand-form "(filter even? (range 20))")
;; =>
(lazy-seq
(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.