Unify injected print-method implementations with orchard.print

CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## master (unreleased)
 
+* Bump `orchard` to [0.34.1](https://github.com/clojure-emacs/orchard/blob/master/CHANGELOG.md#0341-2025-04-23).
+* [#935](https://github.com/clojure-emacs/cider-nrepl/pull/935): Unify injected print-method implementations with orchard.print.
+
 ## 0.55.2 (2025-04-18)
 
 * Bump `orchard` to [0.34.0](https://github.com/clojure-emacs/orchard/blob/master/CHANGELOG.md#0340-2025-04-18).

project.clj

@@ -22,7 +22,7 @@
             :url "http://www.eclipse.org/legal/epl-v10.html"}
   :scm {:name "git" :url "https://github.com/clojure-emacs/cider-nrepl"}
   :dependencies [[nrepl/nrepl "1.3.1" :exclusions [org.clojure/clojure]]
-                 [cider/orchard "0.34.0" :exclusions [org.clojure/clojure]]
+                 [cider/orchard "0.34.1" :exclusions [org.clojure/clojure]]
                  ^:inline-dep [fipp ~fipp-version] ; can be removed in unresolved-tree mode
                  ^:inline-dep [compliment "0.7.0"]
                  ^:inline-dep [org.rksm/suitable "0.6.2" :exclusions [org.clojure/clojure

src/cider/nrepl/print_method.clj

@@ -4,10 +4,9 @@
   calls `print-method`, which includes return values, `pr`, `print`
   and the likes."
   (:require
-   [clojure.main :as main])
+   [orchard.print :as print])
   (:import
-   [clojure.lang AFunction Atom MultiFn Namespace]
-   [java.io Writer]))
+   (clojure.lang AFunction Atom IDeref MultiFn Namespace)))
 
 (def ^:dynamic *pretty-objects*
   "If true, cider prettifies some object descriptions.
@@ -20,76 +19,37 @@
       (alter-var-root #'cider.nrepl.print-method/*pretty-objects* not)"
   true)
 
-(defmacro def-print-method [dispatch-val arg & strings]
-  `(defmethod print-method ~dispatch-val [~arg ~'^Writer w]
-     (if *pretty-objects*
-       (do ~@(map #(list '.write
-                         (with-meta 'w {:tag `Writer})
-                         %)
-                  strings))
-       (#'clojure.core/print-object ~arg ~'w))))
-
-(defn- translate-class-name ^String [c]
-  (main/demunge (.getName (class c))))
-
-;;; Atoms
-;; Ex: #atom[{:foo :bar} 0x54274a2b]
-(def-print-method Atom c
-  "#atom["
-  (pr-str @c)
-  (format " 0x%x]" (System/identityHashCode c)))
-
-;;; Function objects
-;; Ex: #function[cider.nrepl.print-method/multifn-name]
-(def-print-method AFunction c
-  "#function["
-  (translate-class-name c)
-  "]")
-
-;;; Multimethods
-;; Ex: #multifn[print-method 0x3f0cd5b4]
-(defn multifn-name [^MultiFn mfn]
-  (let [field (.getDeclaredField MultiFn "name")
-        private (not (.isAccessible field))]
-    (when private
-      (.setAccessible field true))
-    (let [name (.get field mfn)]
-      (when private
-        (.setAccessible field false))
-      name)))
-
-(defn multifn-name-or-translated-name ^String [c]
-  (try (multifn-name c)
-       (catch SecurityException _
-         (translate-class-name c))))
-
-(def-print-method MultiFn c
-  "#multifn["
-  (multifn-name-or-translated-name c)
-  ;; MultiFn names are not unique so we keep the identity HashCode to
-  ;; make sure it's unique.
-  (format " 0x%x]" (System/identityHashCode c)))
-
-;;; Namespaces
-;; Ex: #namespace[clojure.core]
-(def-print-method Namespace c
-  "#namespace["
-  (format "%s" (ns-name c))
-  "]")
-
-;;; Agents, futures, delays, promises, etc
-(defn- deref-name ^String [c]
-  (let [class-name (translate-class-name c)]
-    (if-let [[_ ^String short-name] (re-find #"^clojure\.lang\.([^.]+)" class-name)]
-      (.toLowerCase short-name)
-      (case (second (re-find #"^clojure\.core/(.+)/reify" class-name))
-        "future-call" "future"
-        "promise"     "promise"
-        nil           class-name))))
-
-;; `deref-as-map` is a private function, so let's be careful.
-(when-let [f (resolve 'clojure.core/deref-as-map)]
-  (def-print-method clojure.lang.IDeref c
-    "#" (deref-name c) "["
-    (pr-str (f c))
-    (format " 0x%x]" (System/identityHashCode c))))
+(defn- replace-with-orchard-print
+  "Replace `clojure.core/print-method` for the given class with
+  `orchard.print/print` when `*pretty-objects*` is true, otherwise call the
+  default Clojure implementation."
+  [klass]
+  (defmethod print-method klass [x writer]
+    (if *pretty-objects*
+      (print/print x writer)
+      (#'clojure.core/print-object writer))))
+
+;; NB: we don't replace all clojure.core/print-method implementations with
+;; orchard.print/print because they arguably have different purpose. Orchard
+;; printer is more human-oriented whereas print-method is a bit more
+;; machine-oriented. So, we only replace it for those types where the visual
+;; improvement is substantial yet we are confident it won't break something.
+
+;;; Atoms: #atom[{:foo :bar}]
+(replace-with-orchard-print Atom)
+
+;;; Function objects: #function[clojure.core/str]
+(replace-with-orchard-print AFunction)
+
+;;; Multimethods: #multifn[print-method 0x3f0cd5b4]
+(replace-with-orchard-print MultiFn)
+
+;;; Namespaces: #namespace[clojure.core]
+(replace-with-orchard-print Namespace)
+
+;;; Various derefables
+;; #agent[1], #agent[<failed> #error[...]]
+;; #delay[<pending>], #delay[1], #delay[<failed> #error[...]]
+;; #future[<pending>], #future[1], #future[<failed> #error[...]]
+;; #promise[<pending>], #promise[1]
+(replace-with-orchard-print IDeref)

test/clj/cider/nrepl/middleware/inspect_test.clj

@@ -41,7 +41,7 @@
    "  " [:value ":column" 4] " = " [:value #"\d+" 5] [:newline]
    "  " [:value ":file" 6] " = " [:value #"\".*cider/nrepl/middleware/inspect_test.clj\"" 7] [:newline]
    "  " [:value ":name" 8] " = " [:value "any-var" 9] [:newline]
-   "  " [:value ":ns" 10] " = " [:value "cider.nrepl.middleware.inspect-test" 11] [:newline]
+   "  " [:value ":ns" 10] " = " [:value "#namespace[cider.nrepl.middleware.inspect-test]" 11] [:newline]
    [:newline]
    "--- Datafy:" [:newline]
    "  0. " [:value "true" 12] [:newline]])
@@ -696,41 +696,44 @@
     (session/message {:op "inspect-clear"})
     (session/message {:op      "eval"
                       :inspect "true"
-                      :code    "(repeat 5 {:a (repeat 5 {:b 2}) :c (repeat 5 {:d 2})})"})
+                      :max-coll-size 6
+                      :code    "(repeat 5 {:a (repeat 6 {:b 2}) :c (repeat 6 {:d 2})})"})
     (testing "toggle pretty printing and turn it on"
       (is+ ["--- Contents:" [:newline]
-            "  0. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 1]
+            "  0. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 1]
             [:newline]
-            "  1. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 2]
+            "  1. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 2]
             [:newline]
-            "  2. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 3]
+            "  2. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 3]
             [:newline]
-            "  3. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 4]
+            "  3. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 4]
             [:newline]
-            "  4. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 5]
-            [:newline]]
+            "  4. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 "\n      :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 5]
+            [:newline] [:newline]
+            "--- View mode:" [:newline]
+            "  :pretty"]
            (value-skip-header (session/message {:op "inspect-toggle-pretty-print"}))))
     (testing "toggle pretty printing and turn it off"
       (is+ ["--- Contents:" [:newline]
-            "  0. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 1]
+            "  0. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 1]
             [:newline]
-            "  1. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 2]
+            "  1. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 2]
             [:newline]
-            "  2. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 3]
+            "  2. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 3]
             [:newline]
-            "  3. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 4]
+            "  3. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 4]
             [:newline]
-            "  4. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
-                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 5]
+            "  4. " [:value (str "{:a ({:b 2} {:b 2} {:b 2} {:b 2} {:b 2} {:b 2}),"
+                                 " :c ({:d 2} {:d 2} {:d 2} {:d 2} {:d 2} {:d 2})}") 5]
             [:newline]]
            (value-skip-header (session/message {:op "inspect-toggle-pretty-print"}))))))
 

test/clj/cider/nrepl/print_method_test.clj

@@ -1,42 +1,39 @@
 (ns cider.nrepl.print-method-test
   (:require
    [cider.nrepl.print-method :refer :all]
-   [clojure.test :refer :all])
-  (:import
-   java.util.regex.Pattern))
+   [clojure.test :refer :all]))
 
 (defn dummy-fn [o])
 
 (deftest print-atoms-test
-  (is (re-find #"#atom\[\"\" 0x[a-z0-9]+\]" (pr-str (atom ""))))
-  (is (re-find #"#atom\[nil 0x[a-z0-9]+\]" (pr-str (atom nil))))
-  (is (re-find #"#atom\[\{:foo :bar\} 0x[a-z0-9]+\]" (pr-str (atom {:foo :bar}))))
-  (is (re-find #"#atom\[#function\[clojure.core/\+\] 0x[a-z0-9]+\]" (pr-str (atom +)))))
+  (is (= "#atom[\"\"]" (pr-str (atom ""))))
+  (is (= "#atom[nil]" (pr-str (atom nil))))
+  (is (= "#atom[{:foo :bar}]" (pr-str (atom {:foo :bar}))))
+  (is (= "#atom[#function[clojure.core/+]]" (pr-str (atom +)))))
 
 (deftest print-idrefs-test
   (let [f (future (Thread/sleep 200) 1)
         p (promise)
         d (delay 1)
         a (agent 1)]
-    (are [o r] (re-find r (pr-str o))
-      a #"#agent\[\{:status :ready, :val 1\} 0x[a-z0-9]+\]"
-      d #"#delay\[\{:status :pending, :val nil\} 0x[a-z0-9]+\]"
-      f #"#future\[\{:status :pending, :val nil\} 0x[a-z0-9]+\]"
-      p #"#promise\[\{:status :pending, :val nil\} 0x[a-z0-9]+\]")
+    (are [o r] (= r (pr-str o))
+      a "#agent[1]"
+      d "#delay[<pending>]"
+      f "#future[<pending>]"
+      p "#promise[<pending>]")
     (Thread/sleep 300)
     @d
     (deliver p 1)
     @f
-    (are [o r] (re-find r (pr-str o))
-      f #"#future\[\{:status :ready, :val 1\} 0x[a-z0-9]+\]"
-      d #"#delay\[\{:status :ready, :val 1\} 0x[a-z0-9]+\]"
-      p #"#promise\[\{:status :ready, :val 1\} 0x[a-z0-9]+\]")))
+    (are [o r] (= r (pr-str o))
+      f "#future[1]"
+      d "#delay[1]"
+      p "#promise[1]")))
 
 (deftest print-functions-test
   (are [f s] (= (pr-str f) s)
     print-functions-test "#function[cider.nrepl.print-method-test/print-functions-test]"
     dummy-fn "#function[cider.nrepl.print-method-test/dummy-fn]"
-    multifn-name "#function[cider.nrepl.print-method/multifn-name]"
     + "#function[clojure.core/+]"
     * "#function[clojure.core/*]"
     / "#function[clojure.core//]"
@@ -45,8 +42,8 @@
 (deftest print-multimethods-test
   (require 'cider.nrepl.middleware.track-state)
   (let [var (resolve 'print-method)]
-    (is (re-find (Pattern/compile (format "#multifn\\[%s 0x[a-z0-9]+\\]"
-                                          (:name (meta var))))
+    (is (re-find (re-pattern (format "#multifn\\[%s 0x[a-z0-9]+\\]"
+                                     (:name (meta var))))
                  (pr-str @var)))))
 
 (deftest print-namespaces-test