gistfile1.clj

(ns debugger-playground.wrap2
  (:use [clojure.pprint :only (pprint)])
  (:require [clojure.tools.trace :as trace]
            [clojure.set :as set])
)

;; Lists of functions which can all be wrapped the same way
(def treat-as-function-call
  "special forms which can be wrapped as if they were functions (all
  elements of the list get evaluated.)"
  #{'monitor-enter 'recur 'do 'monitor-exit 'try 'throw 'finally 'if 'def})

(def treat-as-let #{'let* 'letfn* 'loop*})
(def treat-as-deftype*  #{'deftype* 'reify*})

(def exclude-initial-elements
  "map from special forms to the number of initial elements in their
  lists which should not be wrapped."
  {'new 1, 'set! 1, 'catch 2})

(def do-not-wrap-constituents
  "Special forms whose elements should not be wrapped at all"
  #{'quote 'var 'clojure.core/import*})

(declare wrap-function-call wrap-let wrap-deftype*
         wrap-ignore-elements wrap-dot wrap-case* wrap-fn*
         walk-wrap)

(def general-wrap-dispatch
  "Special forms which need special logic"
  {'case* wrap-case*, 'fn* wrap-fn*, '. wrap-dot})

(def do-not-wrap-return-value
  "Forms which don't return anything interesting, or which return the
same value as the last executed form they contain, or the form
contained by them."
  #{'quote 'clojure.core/import* 'deftype* 'set! 'monitor-enter 'recur
    'fn* 'throw 'catch 'finally 'monitor-exit 'def 'var 'let* 'if})

(defn maybe-wrap-return-value [wrapper form]
  (if (or (not (seq? form))
          (do-not-wrap-return-value (first form)))
    form
    (wrapper form)))

(defn wrap-internals [wrapper form]
  (let [walker #(walk-wrap wrapper %)]
    (cond
     ;; Following deals sensibly with function calls, since
     ;; function symbol will not be wrapped
     (seq?    form) (map walker form)
     (map?    form) (into {} (map #(map walker)) form)
     (set?    form) (into #{} (map walker form))
     (vector? form) (into [] (map walker form))
     :else (throw (IllegalArgumentException.)
                  "Don't know this sequence"))))

(defn walk-wrap [wrapper form]
  (if (not (sequential? form))
    form ;; Can't walk into it, so not very interesting to trace
    (let [invocation (first form)
          wrapped-internals
          (cond
           (treat-as-let             invocation)
             (wrap-let wrapper form)
           (treat-as-deftype*        invocation)
             (wrap-deftype* wrapper form)
           (exclude-initial-elements invocation)
             (wrap-ignore-elements
              wrapper form (exclude-initial-elements invocation))
           (do-not-wrap-constituents invocation)
             form
           (general-wrap-dispatch    invocation)
             ((general-wrap-dispatch invocation) wrapper form)
           :else
           ;; At this stage if it starts with a special form, it's one we can
           ;; wrap as we would a function call.
           (wrap-internals wrapper form))]
      (maybe-wrap-return-value wrapper wrapped-internals))))

(defn wrap-let [wrapper [invocation bindings & body]]
  `(~invocation
    ~(->> bindings
          (partition-all 2)
          (mapcat (fn [[k v]] [k (walk-wrap wrapper v)]))
          vec)
    ~@(map (partial walk-wrap wrapper) body)))

(defn wrap-method [wrapper [methodname args & body]]
  "Wrap a method from a deftype*-style declaration"
  `(~ methodname ~args ~@(map (partial walk-wrap wrapper) body)))

(defn wrap-deftype* [wrapper
                     [invocation classname class fields
                      & remainder]]
  (let [kwargs (->> remainder
                    (partition 2)
                    (take-while (comp keyword? first))
                    (reduce into []))
        methods (drop (count kwargs) remainder)]
    `(~invocation ~classname ~class ~fields ~@(concat kwargs)
                  ~@(map (partial wrap-method wrapper) methods))))

(defn wrap-ignore-elements [wrapper form numignore]
  "Wrap everything but the first numignore elements of form"
  (let [notwrapped (+ 1 numignore)] ; Exclude special-form symbol
    (concat (take notwrapped form)
            (map (partial walk-wrap wrapper)
                 (drop notwrapped form)))))

(defn wrap-dot [wrapper [_ hostexpr mem-or-meth & remainder]]
  `(. ~hostexpr
      ~(if (sequential? mem-or-meth)
         ;; don't make an external wrap of a (method-symbol
         ;; args*), but walk into it.
         (map (partial walk-wrap wrapper) mem-or-meth)
         mem-or-meth)
      ~@(map (partial walk-wrap wrapper) remainder)))

(defn wrap-case*
  [wrapper
   [_ symb shift mask default casemap switch-type test-type skip-check]]
  `(case* ~symb ~shift ~mask ~(walk-wrap wrapper default)
          ;; casemap is a map from integers to forms.  case* expects
          ;; an actual map object here, though, so can't just wrap the
          ;; whole thing, and wouldn't want to anyway.
          ~(into {} (map (fn [[k v]] [k (walk-wrap wrapper v)]) casemap))
          ~switch-type ~test-type ~skip-check))

(defn wrap-fn* [wrapper form]
  (let [prelude (take-while (complement sequential?) form)
        sigs (drop (count prelude) form)
        wsigs (map (fn [[bindings & body]]
                     `(~bindings ~@(map (partial walk-wrap wrapper) body)))
                   sigs)]    
    (concat prelude wsigs)))

(defn wrap-if [wrapper [_ & remainder]]
  `(~_ ~@(map (partial walk-wrap wrapper) remainder)))

(defn wrapper [form] `(~'w ~form))

(doall (walk-wrap wrapper '(def a "a doc string" (inc b))))