From 700903ee7cfa4a68a80aca6281d20294b8f5f47b Mon Sep 17 00:00:00 2001
From: Oleksandr Yakushev <alex@bytopia.org>
Date: Wed, 14 Aug 2024 16:09:44 +0300
Subject: [PATCH 1/2] [trace] Add orchard.trace
---
src/orchard/trace.clj | 136 ++++++++++++++
test/orchard/trace_test.clj | 248 ++++++++++++++++++++++++++
test/orchard/trace_test/sample_ns.clj | 25 +++
3 files changed, 409 insertions(+)
create mode 100644 src/orchard/trace.clj
create mode 100644 test/orchard/trace_test.clj
create mode 100644 test/orchard/trace_test/sample_ns.clj
diff --git a/src/orchard/trace.clj b/src/orchard/trace.clj
new file mode 100644
index 00000000..a2d8fa3c
--- /dev/null
+++ b/src/orchard/trace.clj
@@ -0,0 +1,136 @@
+(ns orchard.trace
+ "Faster and prettier reimplementation of `clojure.tools.trace` with unnecessary
+ parts removed. Used for tracing function invocations and their results."
+ (:require [clojure.string :as string]
+ [orchard.print :as print]))
+
+;;;; Internals
+
+(defmacro ^:private appendn
+ "Add all strings in `args` to the given StringBuilder `sb`."
+ [sb & args]
+ (let [sbsym (with-meta (gensym "sb") {:tag 'StringBuilder})]
+ `(let [~sbsym ~sb]
+ ~@(map (fn [x] `(.append ~sbsym ~x)) args))))
+
+(defn- funcall-to-string
+ "Print the invokation of a function and arguments to a string."
+ ([fname args]
+ (funcall-to-string fname args ""))
+ ([fname, args, ^String outer-prefix]
+ (let [max-args 20 ;; Most args we want to display before truncating.
+ res (StringBuilder.)
+ argn (bounded-count (inc max-args) args)
+ more-than-max-args? (> argn max-args)
+ argn (min argn max-args)]
+ (appendn res outer-prefix "(" fname)
+ (dotimes [i argn]
+ (let [arg (nth args i)]
+ (appendn res " " arg)))
+ (when more-than-max-args?
+ (.append res " ..."))
+ (.append res ")")
+ (.toString res))))
+
+(def ^:private ^:dynamic *depth* 0)
+
+(defn- trace-indent []
+ (string/join (repeat *depth* "│ ")))
+
+(defn- trace-fn-call [name f args]
+ ;; Good defaults for orchard.print.
+ (binding [*print-length* 100
+ *print-level* 5
+ print/*max-atom-length* 150
+ print/*max-total-length* 10000]
+ (println (trace-indent))
+ (println
+ (funcall-to-string (str name) (map print/print-str args)
+ (trace-indent)))
+ (let [value (binding [*depth* (inc *depth*)]
+ (apply f args))
+ res-prefix "└─→ "
+ value-str (print/print-str value)]
+ (binding [*depth* (inc *depth*)]
+ (println (trace-indent)))
+ (println (str (trace-indent) res-prefix value-str))
+ value)))
+
+(defn- resolve-var ^clojure.lang.Var [v]
+ (if (var? v) v (resolve v)))
+
+;;;; Public API
+
+(def ^:private traced-vars (atom #{}))
+(def ^:private traced-nses (atom #{}))
+
+(defn traceable?
+ "Return true if the given var can be traced."
+ [v]
+ (let [v (resolve-var v)]
+ (and (ifn? @v) (not (:macro (meta v))))))
+
+(defn traced?
+ "Return true if the given var is currently traced."
+ [v]
+ (let [v (resolve-var v)]
+ (contains? (meta v) ::traced)))
+
+(defn 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*`."
+ [v]
+ (let [v (resolve-var v)
+ ns (.ns v)
+ s (.sym v)]
+ (when (and (traceable? v) (not (traced? v)))
+ (let [f @v
+ vname (symbol (str ns "/" s))]
+ (swap! traced-vars conj v)
+ (alter-var-root v #(fn tracing-wrapper [& args]
+ (trace-fn-call vname % args)))
+ (alter-meta! v assoc ::traced f)
+ v))))
+
+(defn untrace-var*
+ "Reverses the effect of `trace-var*` for the given Var, replacing the traced
+ function with the original, untraced version. No-op for non-traced Vars."
+ [v]
+ (let [v (resolve-var v)
+ f (::traced (meta v))]
+ (when f
+ (alter-var-root v (constantly (::traced (meta v))))
+ (alter-meta! v dissoc ::traced)
+ (swap! traced-vars disj v)
+ v)))
+
+(defn trace-ns*
+ "Trace all Vars in the given namespace. Can be undone with `untrace-ns*`. `ns`
+ should be a namespace object or a symbol.
+
+ No-op for clojure.core and orchard.trace."
+ [ns]
+ (let [ns (the-ns ns)]
+ (when-not ('#{clojure.core orchard.trace} (.name ns))
+ (->> (ns-interns ns)
+ vals
+ (filter (comp fn? var-get))
+ (run! trace-var*))
+ (swap! traced-nses conj ns))))
+
+(defn untrace-ns*
+ "Untrace all Vars in the given namespace."
+ [ns]
+ (let [ns (the-ns ns)]
+ (->> (ns-interns ns)
+ vals
+ (filter (comp fn? var-get))
+ (run! untrace-var*))
+ (swap! traced-nses disj ns)))
+
+(defn untrace-all
+ "Reverses the effect of tracing for all already traced vars and namespaces."
+ []
+ (run! untrace-ns* @traced-nses)
+ (run! untrace-var* @traced-vars))
diff --git a/test/orchard/trace_test.clj b/test/orchard/trace_test.clj
new file mode 100644
index 00000000..674e478a
--- /dev/null
+++ b/test/orchard/trace_test.clj
@@ -0,0 +1,248 @@
+(ns orchard.trace-test
+ (:require
+ [clojure.test :as t :refer [is are deftest]]
+ [orchard.trace :as sut]
+ [orchard.trace-test.sample-ns :as sample-ns]))
+
+(deftest funcall-to-string-test
+ (are [args expected] (= expected (#'sut/funcall-to-string "foo" args "||| "))
+ [] "||| (foo)"
+ (map str (range 10 20)) "||| (foo 10 11 12 13 14 15 16 17 18 19)"
+ (map str (range 10 30)) "||| (foo 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29)"
+ ["bar" "baz" (apply str (range 20))] "||| (foo bar baz 012345678910111213141516171819)"
+ ["bar" "baz" (apply str (range 25))] "||| (foo bar baz 0123456789101112131415161718192021222324)"
+ [(apply str (range 25)) "bar" "baz"] "||| (foo 0123456789101112131415161718192021222324 bar baz)"
+ [(apply str (range 50)) "bar" "baz"] "||| (foo 012345678910111213141516171819202122232425262728293031323334353637383940414243444546474849 bar baz)"))
+
+(def arg1 "dasdajlksjdalsjdlajasdasasdasdasdsdads")
+(def arg2 "28347029384-asdaasdassdasd128-08-asd2834209")
+(def expected-trace-result
+ "
+(orchard.trace-test.sample-ns/qux \"dasdajlksjdalsjdlajasdasasdasdasdsdads\" \"28347029384-asdaasdassdasd128-08-asd2834209\")
+│
+│ (orchard.trace-test.sample-ns/foo \"dasdajlksjdalsjdlajasdasasdasdasdsdads\" \"28347029384-asdaasdassdasd128-08-asd2834209\")
+│ │
+│ │ (orchard.trace-test.sample-ns/bar \"dasdajlksjdalsjdlajasdasasdasdasdsdads\")
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/baz 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ...)
+│ │ │ │
+│ │ │ └─→ nil
+│ │ │
+│ │ └─→ \"dasdajlksjdalsjdlajasdasasdasdasdsdadshello\"
+│ │
+│ └─→ \"dasdajlksjdalsjdlajasdasasdasdasdsdadshello9024382dsa-80-821dsadssadsaadsa-48392074382\"
+│
+└─→ \"dasdajlksjdalsjdlajasdasasdasdasdsdadshello9024382dsa-80-821dsadssadsaadsa-48392074382\"
+")
+(def expected-trace-result-no-foo
+ "
+(orchard.trace-test.sample-ns/qux \"dasdajlksjdalsjdlajasdasasdasdasdsdads\" \"28347029384-asdaasdassdasd128-08-asd2834209\")
+│
+│ (orchard.trace-test.sample-ns/bar \"dasdajlksjdalsjdlajasdasasdasdasdsdads\")
+│ │
+│ │ (orchard.trace-test.sample-ns/baz 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ...)
+│ │ │
+│ │ └─→ nil
+│ │
+│ └─→ \"dasdajlksjdalsjdlajasdasasdasdasdsdadshello\"
+│
+└─→ \"dasdajlksjdalsjdlajasdasasdasdasdsdadshello9024382dsa-80-821dsadssadsaadsa-48392074382\"
+")
+(def vars [#'sample-ns/baz #'sample-ns/bar #'sample-ns/foo #'sample-ns/qux])
+
+(deftest basic-test
+ (run! sut/trace-var* vars)
+ (is (= expected-trace-result (with-out-str (sample-ns/qux arg1 arg2))))
+
+ (run! sut/untrace-var* vars)
+ (is (= "" (with-out-str (sample-ns/qux arg1 arg2))))
+
+ (run! sut/trace-var* vars)
+ (sut/untrace-var* #'sample-ns/foo)
+ (is (= expected-trace-result-no-foo (with-out-str (sample-ns/qux arg1 arg2))))
+
+ (sut/trace-ns* 'orchard.trace-test.sample-ns)
+ (is (= expected-trace-result (with-out-str (sample-ns/qux arg1 arg2))))
+
+ (sut/untrace-ns* 'orchard.trace-test.sample-ns)
+ (is (= "" (with-out-str (sample-ns/qux arg1 arg2))))
+
+ (sut/trace-ns* 'orchard.trace-test.sample-ns)
+ (sut/untrace-all)
+ (is (= "" (with-out-str (sample-ns/qux arg1 arg2)))))
+
+(deftest fibo-test
+ (sut/trace-ns* 'orchard.trace-test.sample-ns)
+
+ (is (= "
+(orchard.trace-test.sample-ns/fibo 5)
+│
+│ (orchard.trace-test.sample-ns/fibo 3)
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │
+│ │ └─→ 1
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo 2)
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 0)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ └─→ 2
+│ │
+│ └─→ 3
+│
+│ (orchard.trace-test.sample-ns/fibo 4)
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo 2)
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 0)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ └─→ 2
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo 3)
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 2)
+│ │ │ │
+│ │ │ │ (orchard.trace-test.sample-ns/fibo 0)
+│ │ │ │ │
+│ │ │ │ └─→ 1
+│ │ │ │
+│ │ │ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │ │ │
+│ │ │ │ └─→ 1
+│ │ │ │
+│ │ │ └─→ 2
+│ │ │
+│ │ └─→ 3
+│ │
+│ └─→ 5
+│
+└─→ 8
+"
+ (with-out-str (sample-ns/fibo 5))))
+
+ (is (= "
+(orchard.trace-test.sample-ns/fibo 5)
+│
+│ (orchard.trace-test.sample-ns/fibo 3)
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │
+│ │ └─→ 1
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo 2)
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 0)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ └─→ 2
+│ │
+│ └─→ 3
+│
+│ (orchard.trace-test.sample-ns/fibo 4)
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo 2)
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 0)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ └─→ 2
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo 3)
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │ │
+│ │ │ └─→ 1
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo 2)
+│ │ │ │
+│ │ │ │ (orchard.trace-test.sample-ns/fibo 0)
+│ │ │ │ │
+│ │ │ │ └─→ 1
+│ │ │ │
+│ │ │ │ (orchard.trace-test.sample-ns/fibo 1)
+│ │ │ │ │
+│ │ │ │ └─→ 1
+│ │ │ │
+│ │ │ └─→ 2
+│ │ │
+│ │ └─→ 3
+│ │
+│ └─→ 5
+│
+└─→ 8
+"
+ (with-out-str (sample-ns/fibo 5))))
+
+ (is (= "
+(orchard.trace-test.sample-ns/fibo2 0 1 10)
+│
+│ (orchard.trace-test.sample-ns/fibo2 1 1 9)
+│ │
+│ │ (orchard.trace-test.sample-ns/fibo2 1 2 8)
+│ │ │
+│ │ │ (orchard.trace-test.sample-ns/fibo2 2 3 7)
+│ │ │ │
+│ │ │ │ (orchard.trace-test.sample-ns/fibo2 3 5 6)
+│ │ │ │ │
+│ │ │ │ │ (orchard.trace-test.sample-ns/fibo2 5 8 5)
+│ │ │ │ │ │
+│ │ │ │ │ │ (orchard.trace-test.sample-ns/fibo2 8 13 4)
+│ │ │ │ │ │ │
+│ │ │ │ │ │ │ (orchard.trace-test.sample-ns/fibo2 13 21 3)
+│ │ │ │ │ │ │ │
+│ │ │ │ │ │ │ │ (orchard.trace-test.sample-ns/fibo2 21 34 2)
+│ │ │ │ │ │ │ │ │
+│ │ │ │ │ │ │ │ │ (orchard.trace-test.sample-ns/fibo2 34 55 1)
+│ │ │ │ │ │ │ │ │ │
+│ │ │ │ │ │ │ │ │ │ (orchard.trace-test.sample-ns/fibo2 55 89 0)
+│ │ │ │ │ │ │ │ │ │ │
+│ │ │ │ │ │ │ │ │ │ └─→ 89
+│ │ │ │ │ │ │ │ │ │
+│ │ │ │ │ │ │ │ │ └─→ 89
+│ │ │ │ │ │ │ │ │
+│ │ │ │ │ │ │ │ └─→ 89
+│ │ │ │ │ │ │ │
+│ │ │ │ │ │ │ └─→ 89
+│ │ │ │ │ │ │
+│ │ │ │ │ │ └─→ 89
+│ │ │ │ │ │
+│ │ │ │ │ └─→ 89
+│ │ │ │ │
+│ │ │ │ └─→ 89
+│ │ │ │
+│ │ │ └─→ 89
+│ │ │
+│ │ └─→ 89
+│ │
+│ └─→ 89
+│
+└─→ 89
+"
+ (with-out-str (sample-ns/fibo2 0 1 10)))))
diff --git a/test/orchard/trace_test/sample_ns.clj b/test/orchard/trace_test/sample_ns.clj
new file mode 100644
index 00000000..82ab8b6e
--- /dev/null
+++ b/test/orchard/trace_test/sample_ns.clj
@@ -0,0 +1,25 @@
+(ns orchard.trace-test.sample-ns
+ (:require clojure.string))
+
+(defn baz [& _]
+ nil)
+
+(defn bar [a]
+ (apply baz (range))
+ (str a "hello"))
+
+(defn foo [a b]
+ (str (bar a) (clojure.string/reverse b)))
+
+(defn qux [a b]
+ (foo a b))
+
+(defn fibo [n]
+ (if (<= n 1)
+ 1
+ (+ (fibo (- n 2)) (fibo (- n 1)))))
+
+(defn fibo2 [a b n]
+ (if (= n 0)
+ b
+ (fibo2 b (+ a b) (dec n))))
From a0265da48bdede132793860b92aee74b7a4e291a Mon Sep 17 00:00:00 2001
From: Oleksandr Yakushev <alex@bytopia.org>
Date: Wed, 14 Aug 2024 16:21:53 +0300
Subject: [PATCH 2/2] Update CHANGELOG
---
CHANGELOG.md | 1 +
1 file changed, 1 insertion(+)
diff --git a/CHANGELOG.md b/CHANGELOG.md
index ad6cf8b8..f8d88305 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -3,6 +3,7 @@
## master (unreleased)
* [#282](https://github.com/clojure-emacs/orchard/issues/282): Inspector: don't crash when inspecting internal classes.
+* [#284](https://github.com/clojure-emacs/orchard/issues/284): Add orchard.trace.
## 0.26.2 (2024-07-19)