Repository: clojure-emacs/orchard
Pull request #322: [stacktrace] Repatriate stacktrace analyzer from Haystack
Author: login: alexander-yakushev
Created: 2025-03-07T21:05:50Z | Merged: 2025-03-10T10:25:20Z

This PR brings `haystack.analyzer` back home to Orchard. This is not an exact copy; I also did a lot of work in rewriting it to make leaner and faster.

- Pre-1.10 support bits are removed.
- Complete rework of :project flag for frames. Previously, it was implemented by scanning the classpath for all loaded namespaces, and comparing frame's namespace against that set. Now, frame namespace tries to be resolved to classpath resource. If successful, and the path starts with project's workdir, the frame is considered :project. Ridiculously faster this way (< 1 ms vs ~100 ms in a big project).
- Many functions were refactored without changing the behavior. 
- Test namespace was ported almost without behavior changes (but was rewritten to matcher-combinators).

The next step will be to switch cider-nrepl to this. I suspect that as I start working on that, I'll have to make some fixes here too; but I think it's fine to review and merge the current state first.

---

- [x] You've updated the [changelog](../blob/master/CHANGELOG.md)


Diff:
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7cfca10d..3655476d 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -8,6 +8,7 @@
    - `orchard.inspect/set-page-size`, `orchard.inspect/set-max-atom-length`, `orchard.inspect/set-max-value-length`, `orchard.inspect/set-max-coll-size`, `orchard.inspect/set-max-nested-depth`
 * [#318](https://github.com/clojure-emacs/orchard/pull/318): **BREAKING:** Remove no longer used functions: `orchard.misc/lazy-seq?`, `orchard.misc/safe-count`, `orchard.misc/normalize-subclass`, `orchard.misc/remove-type-param`.
 * [#320](https://github.com/clojure-emacs/orchard/pull/320): Info: recognize printed Java classes/methods and munged Clojure functions in stacktrace outputs.
+* [#322](https://github.com/clojure-emacs/orchard/pull/322): Stacktrace: bring back `orchard.stacktrace` for stacktrace analysis (copied from `haystack.analyzer` and improved).
 
 ## 0.30.1 (2025-02-24)
 
diff --git a/src/orchard/stacktrace.clj b/src/orchard/stacktrace.clj
new file mode 100644
index 00000000..63953019
--- /dev/null
+++ b/src/orchard/stacktrace.clj
@@ -0,0 +1,317 @@
+(ns orchard.stacktrace
+  "Instruments for analyzing exceptions and stacktraces which process exception
+  objects and attach extra data to them."
+  {:added "0.31"
+   :author "Jeff Valk, Oleksandr Yakushev"}
+  (:require
+   [clojure.java.io :as io]
+   [clojure.pprint :as pp]
+   [clojure.repl :as repl]
+   [clojure.spec.alpha :as s]
+   [clojure.string :as str]
+   [orchard.info :as info]
+   [orchard.java.resource :as resource])
+  (:import
+   (java.io StringWriter)
+   (java.net URL)
+   (java.nio.file Path)))
+
+(def ^:private ^Path cwd-path (.toAbsolutePath (.toPath (io/file ""))))
+
+(defn- pprint-write
+  "We don't use `clojure.pprint/pprint` directly because it appends a newline at
+  the end which we don't want."
+  [value writer]
+  (pp/write value :stream writer))
+
+;;; ## Stacktraces
+
+(defn- Throwable->map-with-traces
+  "Like `Throwable->map` but attaches `:trace` key to all causes in `:via`."
+  [^Throwable o]
+  (let [m (Throwable->map o)
+        causes (take-while some? (iterate #(.getCause ^Throwable %) o))]
+    (update m :via
+            (fn [via]
+              (mapv (fn [v, ^Throwable t]
+                      (let [st (.getStackTrace t)]
+                        (if (pos? (alength st))
+                          (assoc v :trace (mapv StackTraceElement->vec st))
+                          v)))
+                    via causes)))))
+
+;; Java stacktraces don't expose column number.
+(defn- frame-tuple->map
+  "Return a map describing the stack frame."
+  [frame]
+  (let [[class method file line] frame]
+    (when (and class method file line)
+      {:name   (str (name class) "/" (name method))
+       :file   file
+       :line   line
+       :class  (name class)
+       :method (name method)})))
+
+(defn- flag-frame
+  "Update frame's flags vector to include the new flag."
+  [frame flag]
+  (update frame :flags (comp set conj) flag))
+
+(defn- path->url
+  "Return a url for the path, either relative to classpath, or absolute."
+  [path]
+  (or (info/file-path path) (second (resource/resource-path-tuple path))))
+
+(defn- infer-clojure-source-file [munged-class-name]
+  (let [path-wo-ext (-> munged-class-name
+                        (str/replace #"\$.*" "")
+                        (str/replace "." "/"))]
+    (or (io/resource (str path-wo-ext ".clj"))
+        (io/resource (str path-wo-ext ".cljc")))))
+
+(defn- analyze-class
+  "Add namespace, fn, and var to the frame map when the source is a Clojure
+  function."
+  [{:keys [type class method] :as frame}]
+  (if (or (= :clj type)
+          (= :cljc type))
+    (let [[ns fn & anons] (-> (repl/demunge class)
+                              (str/replace #"--\d+" "")
+                              (str/split #"/"))
+          fn (or fn method)]            ; protocol functions are not munged
+      (assoc frame
+             :ns ns
+             :fn (str/join "/" (cons fn anons))
+             :var (str ns "/" fn)
+             ;; File URL on the classpath
+             :file-url (infer-clojure-source-file class)))
+    frame))
+
+(defn- analyze-file
+  "Associate the file type (extension) of the source file to the frame map, and
+  add it as a flag. If the name is `NO_SOURCE_FILE`, type `clj` is assumed."
+  [{:keys [file] :as frame}]
+  (let [[_ ext] (some->> file (re-find #"\.([^\.]+)$"))
+        type (cond (nil? file)               :unknown
+                   (= file "NO_SOURCE_FILE") :clj
+                   (str/blank? ext)          :unknown
+                   :else                     (keyword ext))]
+    (-> frame
+        (assoc :type type)
+        (flag-frame type))))
+
+(defn- flag-repl
+  "Flag the frame if its source is a REPL eval."
+  [{:keys [file] :as frame}]
+  (if (and file
+           (or (= file "NO_SOURCE_FILE")
+               (.startsWith ^String file "form-init")))
+    (flag-frame frame :repl)
+    frame))
+
+(defn- flag-project
+  "Flag the frame if it is from the user project. The heuristic is this: if we
+  found the source file, it is a file on the filesystem (not in the JAR), and it
+  resides in CWD — it is a project frame, otherwise it's a dependency frame."
+  [{:keys [^URL file-url] :as frame}]
+  (if file-url
+    (-> frame
+        (flag-frame (if (and (= (.getProtocol file-url) "file")
+                             (-> file-url .getFile io/file .toPath
+                                 (.startsWith cwd-path)))
+                      :project :dependency))
+        (update :file-url str)) ;; Stringify file-url for bencode transfer.
+    ;; If file-url is absent, we can't flag it as neither.
+    frame))
+
+(defn- analyze-frame
+  "Return the stacktrace as a sequence of maps, each describing a stack frame."
+  [frame]
+  (-> frame
+      (frame-tuple->map)
+      (analyze-file)
+      (analyze-class)
+      (flag-project)
+      (flag-repl)))
+
+(defn- flag-duplicates
+  "Where a parent and child frame represent substantially the same source
+  location, flag the parent as a duplicate."
+  [frames]
+  (->> frames
+       (partition 2 1)
+       (map (fn [[frame parent]]
+              (if (or (= (:name frame) (:name parent))
+                      (and (= (:file frame) (:file parent))
+                           (= (:line frame) (:line parent))))
+                (flag-frame parent :dup)
+                parent)))
+       (into [(first frames)])))
+
+(def ^:private tooling-frame-re
+  #"^clojure\.lang\.LazySeq|^clojure\.lang\.Var|^clojure\.lang\.MultiFn|^clojure\.lang\.AFn|^clojure\.lang\.RestFn|^clojure\.lang\.RT|clojure\.lang\.Compiler|^nrepl\.|^cider\.|^refactor-nrepl\.|^shadow.cljs\.|^clojure\.core/eval|^clojure\.core/apply|^clojure\.core/with-bindings|^clojure\.core\.protocols|^clojure\.core\.map/fn|^clojure\.core/binding-conveyor-fn|^clojure\.main/repl")
+
+(defn- tooling-frame-name? [frame-name]
+  (let [demunged (repl/demunge frame-name)]
+    (boolean (re-find tooling-frame-re demunged))))
+
+(defn- flag-tooling
+  "Given a collection of stack `frames`, marks the 'tooling' ones as such.
+  A 'tooling' frame is one that generally represents Clojure, JVM, nREPL or CIDER
+  internals, and that is therefore not relevant to application-level code."
+  [frames]
+  ;; Iterate frames from the end. Mark all consecutive Thread-like frames as
+  ;; tooling, and also all frames that match `tooling-frame-name?`.
+  (loop [frames (vec frames), i (dec (count frames)), all-tooling-so-far? true]
+    (if (< i 0)
+      frames
+      (let [frame-name (:name (get frames i))
+            tooling? (or (tooling-frame-name? frame-name)
+                         ;; Everything runs from a Thread, so this frame, if at
+                         ;; the end, is irrelevant. However one can invoke this
+                         ;; method 'by hand', which is why we only skip
+                         ;; consecutive frames that match this.
+                         (and all-tooling-so-far?
+                              (re-find #"^java\.lang\.Thread/run|^java\.util\.concurrent"
+                                       frame-name)))]
+        (recur (cond-> frames
+                 tooling? (update i flag-frame :tooling))
+               (dec i) (and all-tooling-so-far? tooling?))))))
+
+;;; ## Causes
+
+(defn- relative-path
+  "If the path is under the project root, return the relative path; otherwise
+  return the original path."
+  [path]
+  (let [child-path (.toPath (io/file path))]
+    (if (.startsWith child-path cwd-path)
+      (str (.relativize cwd-path child-path))
+      path)))
+
+(defn- extract-location
+  "If the cause is a compiler exception, extract the useful location information
+  from `:location`. Include relative path for simpler reporting."
+  [{:keys [class location] :as cause}]
+  (if (and (= class "clojure.lang.Compiler$CompilerException") location)
+    ;; Post-1.9, CompilerExceptions always carry location data.
+    (assoc cause
+           :file (:clojure.error/source location)
+           :file-url (some-> (:clojure.error/source location)
+                             path->url
+                             str)
+           :path (relative-path (:clojure.error/source location))
+           :line (:clojure.error/line location)
+           :column (:clojure.error/column location))
+    cause))
+
+;; CLJS REPLs use :repl-env to store huge amounts of analyzer/compiler state
+(def ^:private ex-data-blocklist
+  #{:repl-env})
+
+(defn- filter-ex-data
+  "Filter keys from the exception `data` which are blocklisted (generally for
+  containing data not intended for reading by a human)."
+  [data]
+  (when data
+    (into {} (remove #(ex-data-blocklist (key %))) data)))
+
+(defn- prepare-spec-data
+  "Prepare spec problems for display in user stacktraces. Take in a map `ed` as
+  returned by `clojure.spec.alpha/explain-data` and return a map of pretty
+  printed problems. The content of the returned map is modeled after
+  `clojure.spec.alpha/explain-printer`."
+  [ed pprint-str]
+  (let [problems (sort-by #(count (:path %)) (::s/problems ed))]
+    {:spec (pr-str (::s/spec ed))
+     :value (pprint-str (::s/value ed))
+     :problems
+     (mapv
+      (fn [{:keys [in val pred reason via path] :as prob}]
+        (->> {:in (some-> in not-empty pr-str)
+              :val (pprint-str val)
+              :predicate (pr-str (s/abbrev pred))
+              :reason reason
+              :spec (some-> via not-empty last pr-str)
+              :at (some-> path not-empty pr-str)
+              :extra
+              (let [extras (into {}
+                                 (remove #(#{:in :val :pred :reason :via :path
+                                             ::s/failure} (key %)))
+                                 prob)]
+                (when (seq extras)
+                  (pprint-str extras)))}
+             (filter clojure.core/val)
+             (into {})))
+      problems)}))
+
+(defn- analyze-stacktrace-data
+  "Return the stacktrace as a sequence of maps, each describing a stack frame."
+  [trace]
+  (when (seq trace)
+    (-> (pmap analyze-frame trace)
+        (flag-duplicates)
+        (flag-tooling))))
+
+(defn- compile-like-exception?
+  "'Compile-like' exceptions are those that happen at runtime (and therefore never
+  include a `:phase`) which however, represent code that cannot possibly work,
+  and thus are a compile-like exception (i.e. a linter could have caught them)."
+  [{:keys [phase type message]}]
+  (boolean
+   (and (nil? phase)
+        (= type 'java.lang.IllegalArgumentException)
+        (some->> message (re-find #"^No matching (field|method)")))))
+
+(defn- analyze-cause
+  "Analyze the `cause-data` of an exception, in `Throwable->map` format."
+  [cause-data print-fn]
+  (let [pprint-str #(let [writer (StringWriter.)]
+                      (print-fn % writer)
+                      (str writer))
+        phase (-> cause-data :data :clojure.error/phase)
+        m {:class (name (:type cause-data))
+           :phase phase
+           :compile-like (str (compile-like-exception? cause-data))
+           :message (:message cause-data)
+           :stacktrace (analyze-stacktrace-data
+                        (cond (seq (:trace cause-data)) (:trace cause-data)
+                              (:at cause-data) [(:at cause-data)]))}]
+    (if-let [data (filter-ex-data (:data cause-data))]
+      (if (::s/failure data)
+        (assoc m
+               :message "Spec assertion failed."
+               :spec (prepare-spec-data data pprint-str))
+        (assoc m
+               :data (pprint-str data)
+               :location (select-keys data [:clojure.error/line
+                                            :clojure.error/column
+                                            :clojure.error/phase
+                                            :clojure.error/source
+                                            :clojure.error/symbol])))
+      m)))
+
+(defn- analyze-causes
+  "Analyze the cause chain of the `exception-data` in `Throwable->map` format."
+  [exception-data print-fn]
+  (let [causes (vec (:via exception-data))
+        ;; If the first cause lacks :trace, add :trace of the exception there.
+        causes (if (:trace (first causes))
+                 causes
+                 (assoc-in causes [0 :trace] (:trace exception-data)))]
+    (mapv #(extract-location (analyze-cause % print-fn)) causes)))
+
+(defn analyze
+  "Return the analyzed cause chain for `exception` beginning with the
+  thrown exception. `exception` can be an instance of `Throwable` or a
+  map in the same format as `Throwable->map`. For `ex-info`
+   exceptions, the response contains a `:data` slot with the pretty
+  printed data. For clojure.spec asserts, the `:spec` slot contains a
+  map of pretty printed components describing spec failures."
+  ([exception]
+   (analyze exception pprint-write))
+  ([exception print-fn]
+   (cond (instance? Throwable exception)
+         (analyze-causes (Throwable->map-with-traces exception) print-fn)
+         (and (map? exception) (:trace exception))
+         (analyze-causes exception print-fn))))
diff --git a/test/orchard/stacktrace_test.clj b/test/orchard/stacktrace_test.clj
new file mode 100644
index 00000000..93ddfaac
--- /dev/null
+++ b/test/orchard/stacktrace_test.clj
@@ -0,0 +1,344 @@
+(ns orchard.stacktrace-test
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.test :refer [are deftest is testing]]
+   [matcher-combinators.matchers :as matchers]
+   [orchard.stacktrace :as sut]))
+
+(require 'matcher-combinators.test) ;; for `match?`
+
+;; # Utils
+
+(defmacro catch-and-analyze [form]
+  `(try ~form (catch Exception e# (sut/analyze e#))))
+
+(defn causes
+  [form]
+  (catch-and-analyze (eval form)))
+
+(defn stack-frames
+  [form]
+  (-> (catch-and-analyze (eval form))
+      first :stacktrace))
+
+;; ## Test fixtures
+
+(def form1 '(throw (ex-info "oops" {:x 1} (ex-info "cause" {:y 2}))))
+(def form2 '(let [^long num "2"] ;; Type hint to make eastwood happy
+              (defn oops [] (+ 1 num))
+              (oops)))
+(def form3 '(not-defined))
+(def form4 '(divi 1 0))
+
+(def frames1 (stack-frames form1))
+(def frames2 (stack-frames form2))
+(def frames4 (stack-frames form4))
+(def causes1 (causes form1))
+(def causes2 (causes form2))
+(def causes3 (causes form3))
+
+(def email-regex
+  #"^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,63}$")
+
+(s/check-asserts true)
+(s/def ::email-type
+  (s/and string? #(re-matches email-regex %)))
+
+(s/def ::first-name string?)
+(s/def ::last-name string?)
+(s/def ::email ::email-type)
+
+(s/def ::person
+  (s/keys :req [::first-name ::last-name ::email]
+          :opt [::phone]))
+
+(def steven {::first-name "Steven"
+             ::last-name  "Hawking"
+             ::email      "n/a"})
+
+(def spec-causes (causes `(s/assert ::person steven)))
+
+(deftest spec-assert-stacktrace-test
+  (testing "Spec assert components"
+    (is (match? [{:stacktrace some?
+                  :message some?
+                  :spec {:spec some?
+                         :value string?
+                         :problems [{:in some?
+                                     :val some?
+                                     :predicate some?
+                                     :spec some?
+                                     :at some?}]}}]
+                spec-causes))))
+
+(deftest stacktrace-frames-test
+  (testing "File types"
+    ;; Should be clj and java only.
+    (is (= #{:clj :java} (set (map :type frames1))))
+    (is (= #{:clj :java} (set (map :type frames2)))))
+
+  (testing "Full file mappings"
+    (is (match?
+         (matchers/seq-of {:file-url #".+!/clojure/core.clj$"})
+         (filter #(= "clojure.core" (:ns %)) frames1)))
+    (is (match?
+         (matchers/seq-of {:file-url #"^file:/.+"})
+         (filter #(some->> (:ns %) (re-find #"^orchard")) frames1))))
+
+  (testing "Clojure ns, fn, and var"
+    ;; All Clojure frames should have non-nil :ns :fn and :var attributes.
+    (is (match? (matchers/seq-of {:ns some?, :fn some?, :var some?})
+                (filter #(= :clj (:type %)) frames1)))
+    (is (match? (matchers/seq-of {:ns some?, :fn some?, :var some?})
+                (filter #(= :clj (:type %)) frames2))))
+
+  (testing "Clojure name demunging"
+    ;; Clojure fn names should be free of munging characters.
+    (is (match? (matchers/seq-of {:fn (matchers/mismatch #"[_$]|(--\d+)")})
+                (filter :fn frames1)))
+    (is (match? (matchers/seq-of {:fn (matchers/mismatch #"[_$]|(--\d+)")})
+                (filter :fn frames2)))))
+
+(deftest stacktrace-frame-flags-test
+  (testing "Flags"
+    (testing "for file type"
+      ;; Every frame should have its file type added as a flag.
+      (is (every? #(contains? (:flags %) (:type %)) frames1))
+      (is (every? #(contains? (:flags %) (:type %)) frames2)))
+
+    (testing "for tooling"
+      ;; Tooling frames are classes named with 'clojure' or 'nrepl',
+      ;; or are java thread runners...or calls made from these.
+      (is (some #(re-find #"(clojure|nrepl|run)" (:name %))
+                (filter (comp :tooling :flags) frames1)))
+      (is (some #(re-find #"(clojure|nrepl|run)" (:name %))
+                (filter (comp :tooling :flags) frames2))))
+
+    (testing "for project"
+      (is (seq (filter (comp :project :flags) frames4))))
+
+    (testing "for duplicate frames"
+      ;; Index frames. For all frames flagged as :dup, the frame above it in
+      ;; the stack (index i - 1) should be substantially the same source info.
+      (let [ixd1 (zipmap (iterate inc 0) frames1)
+            ixd2 (zipmap (iterate inc 0) frames2)
+            dup? #(or (= (:name %1) (:name %2))
+                      (and (= (:file %1) (:file %2))
+                           (= (:line %1) (:line %2))))]
+        (is (every? (fn [[i v]] (dup? v (get ixd1 (dec ^long i))))
+                    (filter (comp :dup :flags val) ixd1)))
+        (is (every? (fn [[i v]] (dup? v (get ixd2 (dec ^long i))))
+                    (filter (comp :dup :flags val) ixd2)))))))
+
+(deftest exception-causes-test
+  (testing "Exception cause unrolling"
+    (is (= 2 (count causes1)))
+    (is (= 1 (count causes2))))
+  (testing "Exception data"
+    ;; If ex-data is present, the cause should have a :data attribute.
+    (is (:data (first causes1)))
+    (is (not (:data (first causes2))))))
+
+(deftest compilation-errors-test
+  (testing "first cause of compiler exception looks like this"
+    (is (match? #"Syntax error compiling at \(.*orchard/stacktrace_test\.clj:"
+                (:message (first causes3)))))
+
+  (testing "extract-location with location-data already present"
+    (is (= {:class    "clojure.lang.Compiler$CompilerException"
+            :location {:clojure.error/line 1
+                       :clojure.error/column 42
+                       :clojure.error/source "/foo/bar/baz.clj"
+                       :clojure.error/phase :macroexpand
+                       :clojure.error/symbol 'clojure.core/let},
+            :message  "Syntax error macroexpanding clojure.core/let at (1:1)."
+            :file     "/foo/bar/baz.clj"
+            :file-url nil
+            :path     "/foo/bar/baz.clj"
+            :line     1
+            :column   42}
+           (#'sut/extract-location {:class    "clojure.lang.Compiler$CompilerException"
+                                    :location {:clojure.error/line   1
+                                               :clojure.error/column 42
+                                               :clojure.error/source "/foo/bar/baz.clj"
+                                               :clojure.error/phase  :macroexpand
+                                               :clojure.error/symbol 'clojure.core/let}
+                                    :message  "Syntax error macroexpanding clojure.core/let at (1:1)."})))))
+
+(deftest analyze-cause-test
+  (testing "check that location-data is returned"
+    (let [e (ex-info "wat?" {:clojure.error/line 1
+                             :clojure.error/column 42
+                             :clojure.error/source "/foo/bar/baz.clj"
+                             :clojure.error/phase :macroexpand
+                             :clojure.error/symbol 'clojure.core/let})
+          cause (first (sut/analyze e))]
+      (is (= {:clojure.error/line 1
+              :clojure.error/column 42
+              :clojure.error/source "/foo/bar/baz.clj"
+              :clojure.error/phase :macroexpand
+              :clojure.error/symbol 'clojure.core/let}
+             (:location cause))))))
+
+(deftest test-analyze-throwable
+  (testing "shape of analyzed throwable"
+    (is (match?
+         [;; first cause
+          {:class "clojure.lang.ExceptionInfo"
+           :message "BOOM-1"
+           :data "{:boom \"1\"}"
+           :stacktrace [{:name "clojure.lang.AFn/applyToHelper"
+                         :file "AFn.java"
+                         :line 156
+                         :class "clojure.lang.AFn"
+                         :method "applyToHelper"
+                         :type :java
+                         :flags #{:java :tooling}}
+                        {:class "clojure.lang.AFn"
+                         :file "AFn.java"
+                         :flags #{:java :tooling}
+                         :line 144
+                         :method "applyTo"
+                         :name "clojure.lang.AFn/applyTo"
+                         :type :java}
+                        ;; 5 frames in total
+                        some? some? some?]}
+          ;; second cause
+          {:class "clojure.lang.ExceptionInfo"
+           :message "BOOM-2"
+           :data "{:boom \"2\"}"
+           :stacktrace [{:name "clojure.lang.AFn/applyToHelper"
+                         :file "AFn.java"
+                         :class "clojure.lang.AFn"
+                         :line 160
+                         :method "applyToHelper"
+                         :type :java
+                         :flags #{:java :tooling}}]}
+          ;; third cause
+          {:class "clojure.lang.ExceptionInfo"
+           :message "BOOM-3"
+           :data "{:boom \"3\"}"
+           :stacktrace [{:name "clojure.lang.AFn/applyToHelper"
+                         :file "AFn.java"
+                         :class "clojure.lang.AFn"
+                         :line 156
+                         :method "applyToHelper"
+                         :type :java
+                         :flags #{:java :tooling}}]}]
+         (sut/analyze
+          '{:via
+            [{:type clojure.lang.ExceptionInfo
+              :message "BOOM-1"
+              :data {:boom "1"}
+              :at [clojure.lang.AFn applyToHelper "AFn.java" 160]}
+             {:type clojure.lang.ExceptionInfo
+              :message "BOOM-2"
+              :data {:boom "2"}
+              :at [clojure.lang.AFn applyToHelper "AFn.java" 160]}
+             {:type clojure.lang.ExceptionInfo
+              :message "BOOM-3"
+              :data {:boom "3"}
+              :at [clojure.lang.AFn applyToHelper "AFn.java" 156]}]
+            :trace
+            [[clojure.lang.AFn applyToHelper "AFn.java" 156]
+             [clojure.lang.AFn applyTo "AFn.java" 144]
+             [clojure.lang.Compiler$InvokeExpr eval "Compiler.java" 3706]
+             [clojure.lang.Compiler$InvokeExpr eval "Compiler.java" 3705]
+             [clojure.lang.Compiler$InvokeExpr eval "Compiler.java" 3705]]
+            :cause "BOOM-3"
+            :data {:boom "3"}
+            :stacktrace-type :throwable}))))
+
+  (testing "Includes a `:phase` for the causes that include it"
+    (is (match? [{:phase :macro-syntax-check}
+                 {:phase nil}]
+                (catch-and-analyze (eval '(let [1]))))))
+
+  (testing "Does not include `:phase` for vanilla runtime exceptions"
+    (is (match? [{:phase nil}]
+                (catch-and-analyze (throw (ex-info "" {}))))))
+
+  (testing "`:compile-like`"
+    (testing "For non-existing fields"
+      (is (match? [{:compile-like "true"}]
+                  (catch-and-analyze (eval '(.-foo ""))))))
+    (testing "For non-existing methods"
+      (is (match? [{:compile-like "true"}]
+                  (catch-and-analyze (eval '(-> "" (.foo 1 2)))))))
+    (testing "For vanilla exceptions"
+      (is (match? [{:compile-like "false"}]
+                  (catch-and-analyze (throw (ex-info "." {}))))))
+    (testing "For vanilla `IllegalArgumentException`s"
+      (is (match? [{:compile-like "false"}]
+                  (catch-and-analyze (throw (IllegalArgumentException. "foo"))))))
+    (testing "For exceptions with a `:phase`"
+      (is (match? [{:compile-like "false"} {:compile-like "false"}]
+                  (catch-and-analyze (eval '(let [1]))))))))
+
+(deftest tooling-frame-name?
+  (are [frame-name] (true? (#'sut/tooling-frame-name? frame-name))
+    "cider.foo"
+    "refactor-nrepl.middleware/wrap-refactor"
+    "shadow.cljs.devtools.server.nrepl/shadow-inint"
+    ;; `apply` typically is internal, should be hidden:
+    "clojure.core/apply"
+    "clojure.core/binding-conveyor-fn/fn"
+    "clojure.core.protocols/iter-reduce"
+    "clojure.core/eval"
+    "clojure.core/with-bindings*"
+    "clojure.lang.MultiFn/invoke"
+    "clojure.lang.LazySeq/sval"
+    "clojure.lang.Var/invoke"
+    "clojure.lang.AFn/applyTo"
+    "clojure.lang.AFn/applyToHelper"
+    "clojure.lang.RestFn/invoke"
+    "clojure.main/repl"
+    "clojure.main$repl$read_eval_print__9234$fn__9235/invoke"
+    "nrepl.foo"
+    "nrepl.middleware.interruptible_eval$evaluate/invokeStatic")
+
+  (are [frame-name] (false? (#'sut/tooling-frame-name? frame-name))
+    "acider.foo"
+    "anrepl.foo"
+    ;; `+` is "application" level, should not be hidden:
+    "clojure.core/+"
+    ;; important case - `Numbers` is relevant, should not be hidden:
+    "clojure.lang.Numbers/divide"
+    ;; Important unless it is at the root of the stack
+    "java.lang.Thread/run"))
+
+(deftest flag-tooling
+  (is (= [{:name "cider.foo", :flags #{:tooling}}
+          {:name "java.lang.Thread/run"} ;; does not get the flag because it's not the root frame
+          {:name "don't touch me 1"}
+          {:name "nrepl.foo", :flags #{:tooling}}
+          {:name "clojure.lang.RestFn/invoke", :flags #{:tooling}}
+          {:name "don't touch me 2"}
+          ;; gets the flag because it's the root frame:
+          {:name "java.lang.Thread/run", :flags #{:tooling}}]
+         (#'sut/flag-tooling [{:name "cider.foo"}
+                              {:name "java.lang.Thread/run"}
+                              {:name "don't touch me 1"}
+                              {:name "nrepl.foo"}
+                              {:name "clojure.lang.RestFn/invoke"}
+                              {:name "don't touch me 2"}
+                              {:name "java.lang.Thread/run"}]))
+      "Adds the flag when appropiate, leaving other entries untouched")
+
+  (let [frames [{:name "don't touch me"}
+                {:name "java.util.concurrent.FutureTask/run"}
+                {:name "java.util.concurrent.ThreadPoolExecutor/runWorker"}
+                {:name "java.util.concurrent.ThreadPoolExecutor$Worker/run"}]]
+    (is (= [{:name "don't touch me"}
+            {:name "java.util.concurrent.FutureTask/run", :flags #{:tooling}}
+            {:name "java.util.concurrent.ThreadPoolExecutor/runWorker", :flags #{:tooling}}
+            {:name "java.util.concurrent.ThreadPoolExecutor$Worker/run", :flags #{:tooling}}]
+           (#'sut/flag-tooling frames))
+        "Three j.u.concurrent frames get the flag if they're at the bottom")
+    (is (= [{:name "don't touch me"}
+            {:name "java.util.concurrent.FutureTask/run"}
+            {:name "java.util.concurrent.ThreadPoolExecutor/runWorker"}
+            {:name "java.util.concurrent.ThreadPoolExecutor$Worker/run"}
+            {:name "x"}]
+           (#'sut/flag-tooling (conj frames {:name "x"})))
+        "The j.u.concurrent frames don't get the flag if they're not at the bottom")))


Reviews:
user: login: bbatsov
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-03-08T09:52:43Z
user: login: bbatsov
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-03-08T10:44:42Z

Review comments:
diff_hunk: @@ -0,0 +1,318 @@
+(ns orchard.stacktrace
+  "Cause and stacktrace analysis for exceptions"
+  {:added "0.31"
path: src/orchard/stacktrace.clj
user: login: bbatsov
body: Maybe you can expand this a bit, to be more in line with the level of high-level descriptions that most other namespaces have. 
created_at: 2025-03-08T09:52:43Z
author_association: MEMBER
diff_hunk: @@ -0,0 +1,342 @@
+(ns orchard.stacktrace-test
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.test :refer [are deftest is testing]]
+   [matcher-combinators.matchers :as matchers]
+   [orchard.stacktrace :as sut]))
+
+(require 'matcher-combinators.test) ;; for `match?`
+
+;; # Utils
+
+(defmacro catch-and-analyze [form]
+  `(try ~form (catch Exception e# (sut/analyze e#))))
+
+(defn causes
+  [form]
+  (catch-and-analyze (eval form)))
+
+(defn stack-frames
+  [form]
+  (-> (catch-and-analyze (eval form))
+      first :stacktrace))
+
+;; ## Test fixtures
+
+(def form1 '(throw (ex-info "oops" {:x 1} (ex-info "cause" {:y 2}))))
+(def form2 '(let [^long num "2"] ;; Type hint to make eastwood happy
+              (defn oops [] (+ 1 num))
+              (oops)))
+(def form3 '(not-defined))
+(def form4 '(divi 1 0))
+
+(def frames1 (stack-frames form1))
+(def frames2 (stack-frames form2))
+(def frames4 (stack-frames form4))
+(def causes1 (causes form1))
+(def causes2 (causes form2))
+(def causes3 (causes form3))
+
+(def email-regex
+  #"^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,63}$")
+
+(s/check-asserts true)
+(s/def ::email-type
+  (s/and string? #(re-matches email-regex %)))
+
+(s/def ::first-name string?)
+(s/def ::last-name string?)
+(s/def ::email ::email-type)
+
+(s/def ::person
+  (s/keys :req [::first-name ::last-name ::email]
+          :opt [::phone]))
+
+(def steven {::first-name "Steven"
+             ::last-name  "Hawking"
+             ::email      "n/a"})
+
+(def spec-causes (causes `(s/assert ::person steven)))
+
+(deftest spec-assert-stacktrace-test
+  (testing "Spec assert components"
+    (is (match? [{:stacktrace some?
+                  :message some?
+                  :spec {:spec some?
+                         :value string?
+                         :problems [{:in some?
+                                     :val some?
+                                     :predicate some?
+                                     :spec some?
+                                     :at some?}]}}]
+                spec-causes))))
+
+(deftest stacktrace-frames-test
+  (testing "File types"
+    ;; Should be clj and java only.
+    (is (= #{:clj :java} (set (map :type frames1))))
+    (is (= #{:clj :java} (set (map :type frames2)))))
+
+  (testing "Full file mappings"
+    (is (match?
+         (matchers/seq-of {:file-url #".+!/clojure/core.clj$"})
+         (filter #(= "clojure.core" (:ns %)) frames1)))
+    (is (match?
+         (matchers/seq-of {:file-url #"^file:/.+"})
+         (filter #(some->> (:ns %) (re-find #"^orchard")) frames1))))
+
+  (testing "Clojure ns, fn, and var"
+    ;; All Clojure frames should have non-nil :ns :fn and :var attributes.
+    (is (match? (matchers/seq-of {:ns some?, :fn some?, :var some?})
+                (filter #(= :clj (:type %)) frames1)))
+    (is (match? (matchers/seq-of {:ns some?, :fn some?, :var some?})
+                (filter #(= :clj (:type %)) frames2))))
+
+  (testing "Clojure name demunging"
+    ;; Clojure fn names should be free of munging characters.
+    (is (match? (matchers/seq-of {:fn (matchers/mismatch #"[_$]|(--\d+)")})
+                (filter :fn frames1)))
+    (is (match? (matchers/seq-of {:fn (matchers/mismatch #"[_$]|(--\d+)")})
+                (filter :fn frames2)))))
+
+(deftest stacktrace-frame-flags-test
+  (testing "Flags"
+    (testing "for file type"
+      ;; Every frame should have its file type added as a flag.
+      (is (every? #(contains? (:flags %) (:type %)) frames1))
+      (is (every? #(contains? (:flags %) (:type %)) frames2)))
+
+    (testing "for tooling"
+      ;; Tooling frames are classes named with 'clojure' or 'nrepl',
+      ;; or are java thread runners...or calls made from these.
+      (is (some #(re-find #"(clojure|nrepl|run)" (:name %))
+                (filter (comp :tooling :flags) frames1)))
+      (is (some #(re-find #"(clojure|nrepl|run)" (:name %))
+                (filter (comp :tooling :flags) frames2))))
+
+    (testing "for project"
+      (is (seq (filter (comp :project :flags) frames4))))
+
+    (testing "for duplicate frames"
+      ;; Index frames. For all frames flagged as :dup, the frame above it in
+      ;; the stack (index i - 1) should be substantially the same source info.
+      (let [ixd1 (zipmap (iterate inc 0) frames1)
+            ixd2 (zipmap (iterate inc 0) frames2)
+            dup? #(or (= (:name %1) (:name %2))
+                      (and (= (:file %1) (:file %2))
+                           (= (:line %1) (:line %2))))]
+        (is (every? (fn [[i v]] (dup? v (get ixd1 (dec ^long i))))
+                    (filter (comp :dup :flags val) ixd1)))
+        (is (every? (fn [[i v]] (dup? v (get ixd2 (dec ^long i))))
+                    (filter (comp :dup :flags val) ixd2)))))))
+
+(deftest exception-causes-test
+  (testing "Exception cause unrolling"
+    (is (= 2 (count causes1)))
+    (is (= 1 (count causes2))))
+  (testing "Exception data"
+    ;; If ex-data is present, the cause should have a :data attribute.
+    (is (:data (first causes1)))
+    (is (not (:data (first causes2))))))
+
+(deftest compilation-errors-test
+  (is (match? #"Syntax error compiling at \(.*orchard/stacktrace_test\.clj:"
path: test/orchard/stacktrace_test.clj
user: login: bbatsov
body: I prefer to have all assertions in `testing`, so that the output is a bit more descriptive, but it's not a big deal. 
created_at: 2025-03-08T10:44:41Z
author_association: MEMBER

PR comments:
user: login: bbatsov
created_at: 2025-03-08T10:45:46Z
body: Looks pretty good to me overall. 
author_association: MEMBER
user: login: alexander-yakushev
created_at: 2025-03-08T13:22:49Z
body: Done.
author_association: MEMBER
user: login: bbatsov
created_at: 2025-03-10T10:25:35Z
body: Great work!
author_association: MEMBER