Make stacktrace/ns-common-prefix work in presence of user.clj files

Author: vemv

CHANGELOG.md

@@ -6,6 +6,10 @@
 
 * [#698](https://github.com/clojure-emacs/cider-nrepl/pull/698): Add `undef-all` op to undefine all symbols and aliases in namespace
 
+### Bugs fixed
+
+* Make `middleware.stacktrace` detect a given project's common ns prefix even in face of single-segment namespaces such as `user`.
+
 ## 0.26.0 (2021-04-22)
 
 ### New features

src/cider/nrepl/middleware/stacktrace.clj

@@ -119,43 +119,75 @@
                  %)]
     (map flag frames)))
 
-(def directory-namespaces
-  "This looks for all namespaces inside of directories on the class
-  path, ignoring jars."
+(defn directory-namespaces
+  "Looks for all namespaces inside of directories on the class
+  path, ignoring jars.
+
+  It's a defn because this set is always subject to change.
+
+  NOTE: depending on the use case, you might want to filter out
+  namespaces such as `user` which while belong to the project,
+  don't share a common naming scheme with the other namespaces."
+  []
   (into #{} (namespace/project-namespaces)))
 
-(def ns-common-prefix
-  "In order to match more namespaces, we look for a common namespace
-  prefix across the ones we have identified."
+(defn ns-common-prefix* [namespaces]
   (let [common
-        (try (reduce
-              (fn [common ns]
-                (let [ns (str/lower-case ns)
-                      matched (map vector common ns)
-                      coincident (take-while (fn [[a b]] (= a b)) matched)]
-                  (apply str (map first coincident))))
-              (str/lower-case (first directory-namespaces))
-              directory-namespaces)
-             (catch Throwable _e :error))]
+        (try
+          (->> namespaces
+               (pmap (fn [ns-sym]
+                       (let [segments (-> ns-sym
+                                          str
+                                          (str/split #"\."))]
+                         ;; remove single-segment namespaces
+                         ;; (such as `dev`, `test`, `test-runner`)
+                         ;; that would break the commonality:
+                         (when (-> segments count (> 1))
+                           segments))))
+               (filter identity)
+               (reduce (fn [prev curr]
+                         (if (= ::placeholder prev)
+                           curr
+                           (let [found-commonality
+                                 (reduce-kv (fn [result k v]
+                                              (if (= (get prev k)
+                                                     (get curr k))
+                                                (conj result v)
+                                                (reduced result)))
+                                            []
+                                            prev)]
+                             (if (seq found-commonality)
+                               found-commonality
+                               (reduced :missing)))))
+                       ::placeholder))
+          (catch Throwable _e :error))]
     (condp = common
-      ""
+      ::placeholder
+      {:valid false :common :missing}
+
+      :missing
       {:valid false :common :missing}
 
       :error
       {:valid false :common :error}
 
-      ;;default
-      {:valid true :common common})))
+      {:valid true :common (str/join "." common)})))
+
+(def ns-common-prefix
+  "In order to match more namespaces, we look for a common namespace
+  prefix across the ones we have identified."
+  (delay
+    (ns-common-prefix* (directory-namespaces))))
 
 (defn flag-project
   "Flag the frame if it is from the users project. From a users
   project means that the namespace is one we have identified or it
   begins with the identified common prefix."
   [{:keys [ns] :as frame}]
-  (if (and directory-namespaces ns
-           (or (contains? directory-namespaces (symbol ns))
-               (when (:valid ns-common-prefix)
-                 (.startsWith ^String ns (:common ns-common-prefix)))))
+  (if (and ns
+           (or (contains? (directory-namespaces) (symbol ns))
+               (when (:valid @ns-common-prefix)
+                 (.startsWith ^String ns (:common @ns-common-prefix)))))
     (flag-frame frame :project)
     frame))
 

test/clj/cider/nrepl/middleware/stacktrace_test.clj

@@ -1,6 +1,6 @@
 (ns cider.nrepl.middleware.stacktrace-test
   (:require
-   [cider.nrepl.middleware.stacktrace :refer :all]
+   [cider.nrepl.middleware.stacktrace :as sut :refer :all]
    [cider.nrepl.pprint :refer [pprint]]
    [clojure.test :refer :all]))
 
@@ -183,3 +183,25 @@
               :clojure.error/phase :macroexpand
               :clojure.error/symbol 'clojure.core/let}
              (:location cause))))))
+
+(deftest ns-common-prefix*-test
+  (are [input expected] (= expected
+                           (sut/ns-common-prefix* input))
+    []             {:valid false :common :missing}
+    '[a b]         {:valid false :common :missing}
+    '[a.c b.c]     {:valid false :common :missing}
+    ::not-a-coll   {:valid false :common :error}
+
+    ;; single-segment namespaces are considered to never have a common part:
+    '[user]        {:valid false :common :missing}
+    '[dev]         {:valid false :common :missing}
+    '[test-runner] {:valid false :common :missing}
+
+    '[a.a]         {:valid true :common "a.a"}
+    '[a.a a.b]     {:valid true :common "a"}
+    '[a.a.b a.a.c] {:valid true :common "a.a"}
+
+    ;; single-segment namespaces cannot foil the rest of the calculation:
+    '[dev user test-runner a.a]         {:valid true :common "a.a"}
+    '[dev user test-runner a.a a.b]     {:valid true :common "a"}
+    '[dev user test-runner a.a.b a.a.c] {:valid true :common "a.a"}))