aaa

core.clj

(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))))))
  
  )