clojure.tools.trace with java-bits removed, take 1

gistfile1.txt

;;;
;;  trace.clj -- simple call-tracing macros for Clojure

;;  by Stuart Sierra, http://stuartsierra.com/
;;  December 3, 2008

;;  Copyright (c) Stuart Sierra, 2008. All rights reserved. The use
;;  and distribution terms for this software are covered by the Eclipse
;;  Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;;  which can be found in the file epl-v10.html at the root of this
;;  distribution. By using this software in any fashion, you are
;;  agreeing to be bound by the terms of this license. You must not
;;  remove this notice, or any other, from this software.
;;
;;  This file defines simple "tracing" macros to help you see what your
;;  code is doing.
;;
;;  CHANGE LOG
;;
;;  Aug 23thd, 2013: Luc Préfontaine
;;
;;  * Fixed crash of throwable tracing when no string based constructor exists
;;
;;  December 1st, 2012: Luc Préfontaine
;;
;;  * Fixed README and comments in source file
;;  * fixed changelog and readme
;;  * added traced? and traceable/ fns
;;  * removed reflection warnings
;;
;;  March 4, 2012: Luc Préfontaine
;;
;;  * added macro wrappers around fns allowing dynamic tracing.
;;
;;  Feb. 20, 2012: Luc Préfontaine
;;
;;  * added contribution from Michał Marczyk and Don jackson to allow dynamic tracing of fns in a namespace.
;;
;;  Sept 18, 2011: Luc Préfontaine
;;
;;  * moved it to new contrib modular struct
;;
;;  * made it 1.2/1.3 compliant
;;
;;  * supported doc strings
;;
;;  * added a trace-form macro, from Jonathan Fischer
;; 
;;  December 3, 2008:
;; 
;;  * replaced *trace-out* with tracer
;; 
;;  * made trace a function instead of a macro
;;  (suggestion from Stuart Halloway)
;; 
;;  * added trace-fn-call
;; 
;;  June 9, 2008: first version
;;;
(ns ^{:author "Stuart Sierra, Michel Salim, Luc Préfontaine, Jonathan Fischer Friberg, Michał Marczyk, Don Jackson"
      :doc "This file defines simple tracing macros to help you see what your code is doing."}
     clojure.tools.trace
  (:use [clojure.pprint]))

(def ^{:doc "Current stack depth of traced function calls." :private true :dynamic true}
      *trace-depth* 0)

(def ^{:doc "Forms to ignore when tracing forms." :private true}
      ignored-form? '#{def quote var try monitor-enter monitor-exit assert})
    
(defn ^{:private true} tracer
  "This function is called by trace. Prints to standard output, but
may be rebound to do anything you like. 'name' is optional."
  [name value]
  (println (str "TRACE" (when name (str " " name)) ": " value)))

(defn trace
  "Sends name (optional) and value to the tracer function, then
returns value. May be wrapped around any expression without
affecting the result."
  ([value] (trace nil value))
  ([name value]
     (tracer name (pr-str value))
     value))

(defn ^{:private true} trace-indent
  "Returns an indentation string based on *trace-depth*"
  []
  (apply str (take *trace-depth* (repeat "| "))))

(defn ^{:skip-wiki true} trace-fn-call
  "Traces a single call to a function f with args. 'name' is the
symbol name of the function."
  [name f args]
  (let [id (gensym "t")]
    (tracer id (str (trace-indent) (pr-str (cons name args))))
    (let [value (binding [*trace-depth* (inc *trace-depth*)]
                  (apply f args))]
      (tracer id (str (trace-indent) "=> " (pr-str value)))
      value)))

(defmacro deftrace
  "Use in place of defn; traces each call/return of this fn, including
   arguments. Nested calls to deftrace'd functions will print a
   tree-like structure.
   The first argument of the form definition can be a doc string"
  [name & definition]
  (let [doc-string (if (string? (first definition)) (first definition) "")
        fn-form  (if (string? (first definition)) (rest definition) definition)]
    `(do
       (declare ~name)
       (let [f# (fn ~@fn-form)]
         (defn ~name ~doc-string [& args#]
           (trace-fn-call '~name f# args#))))))

(defmacro dotrace
  "Given a sequence of function identifiers, evaluate the body
expressions in an environment in which the identifiers are bound to
the traced functions. Does not work on inlined functions,
such as clojure.core/+"
  [fnames & exprs]
  `(binding [~@(interleave fnames
                           (for [fname fnames]
                             `(let [f# @(var ~fname)]
                                (fn [& args#]
                                  (trace-fn-call '~fname f# args#)))))]
     ~@exprs))

(defn ^{:skip-wiki true} trace-var*
  "If the specified Var holds an IFn and is not marked as a macro, its
  contents is replaced with a version wrapped in a tracing call;
  otherwise nothing happens. Can be undone with untrace-var.

  In the unary case, v should be a Var object or a symbol to be
  resolved in the current namespace.

  In the binary case, ns should be a namespace object or a symbol
  naming a namespace and s a symbol to be resolved in that namespace."
  ([ns s]
     (trace-var* (ns-resolve ns s)))
  ([v]
     (let [^clojure.lang.Var v (if (var? v) v (resolve v))
           ns (.ns v)
           s  (.sym v)]
       (if (and (ifn? @v) (-> v meta :macro not) (-> v meta ::traced not))
         (let [f @v
               vname (symbol (str ns "/" s))]
           (doto v
             (alter-var-root #(fn tracing-wrapper [& args]
                                (trace-fn-call vname % args)))
             (alter-meta! assoc ::traced f)))))))

(defn ^{:skip-wiki true} untrace-var*
  "Reverses the effect of trace-var / trace-vars / trace-ns for the
  given Var, replacing the traced function with the original, untraced
  version. No-op for non-traced Vars.

  Argument types are the same as those for trace-var."
  ([ns s]
     (untrace-var* (ns-resolve ns s)))
  ([v]
     (let [^clojure.lang.Var v (if (var? v) v (resolve v))
           ns (.ns v)
           s  (.sym v)
           f  ((meta v) ::traced)]
       (when f
         (doto v
           (alter-var-root (constantly ((meta v) ::traced)))
           (alter-meta! dissoc ::traced))))))

(defmacro trace-vars
  "Trace each of the specified Vars.
  The arguments may be Var objects or symbols to be resolved in the current
  namespace."
  [& vs]
  `(do ~@(for [x vs] 
           `(if (var? ~x)
              (trace-var* ~x)
              (trace-var* (quote ~x))))))

(defmacro untrace-vars
  "Untrace each of the specified Vars.
  Reverses the effect of trace-var / trace-vars / trace-ns for each
  of the arguments, replacing the traced functions with the original,
  untraced versions."
  [& vs]
  `(do ~@(for [x vs]
           `(if (var? ~x)
              (untrace-var* ~x)
              (untrace-var* (quote ~x))))))

(defn ^{:skip-wiki true} trace-ns*
  "Replaces each function from the given namespace with a version wrapped
  in a tracing call. Can be undone with untrace-ns. ns should be a namespace
  object or a symbol.

  No-op for clojure.core and clojure.tools.trace."
  [ns]
  (let [ns (the-ns ns)]
    (when-not ('#{clojure.core clojure.tools.trace} (.name ns))
      (let [ns-fns (->> ns ns-interns vals (filter (comp fn? var-get)))]
        (doseq [f ns-fns]
          (trace-var* f))))))

(defn ^{:private true} resolves-as-var?
  "Try to resolve the symbol in several ways to find out if it's a var or not."
  [n]
  (cond
    (coll? n) nil
    (try (find-ns n) (catch Exception _)) nil
    :else
    (if-let [v (try (ns-resolve *ns* n) (catch Exception _))] (var? v))))

(defmacro trace-ns
  "Trace all fns in the given name space. The given name space can be quoted, unquoted or stored in a var.
   We must try to resolve the expression passed to us partially to find out if it needs to be quoted or not
   when passed to trace-ns*"
  [n]
  (let [quote? (not (or (resolves-as-var? n) (and (coll? n) (= (first n) (quote quote)))))
        n (if quote? (list 'quote n) n)]
    `(trace-ns* ~n)))

(defn ^{:skip-wiki true} untrace-ns*
  "Reverses the effect of trace-var / trace-vars / trace-ns for the
  Vars in the given namespace, replacing each traced function from the
  given namespace with the original, untraced version."
  [ns]
  (let [ns-fns (->> ns the-ns ns-interns vals)]
    (doseq [f ns-fns]
          (untrace-var* f))))

(defmacro untrace-ns
  "Untrace all fns in the given name space. The given name space can be quoted, unquoted or stored in a var.
   We must try to resolve the expression passed to us partially to find out if it needs to be quoted or not
   when passed to untrace-ns*"
  [n]
  (let [quote? (not (or (resolves-as-var? n) (and (coll? n) (= (first n) (quote quote)))))
        n (if quote? (list 'quote n) n)]
     `(untrace-ns* ~n)))

(defn traced?
  "Returns true if the given var is currently traced, false otherwise"
  [v]
  (let [^clojure.lang.Var v (if (var? v) v (resolve v))]
    (-> v meta ::traced nil? not)))
 
(defn traceable?
  "Returns true if the given var can be traced, false otherwise"
  [v]
  (let [^clojure.lang.Var v (if (var? v) v (resolve v))]
    (and (ifn? @v) (-> v meta :macro not))))