diff --git a/CHANGELOG.md b/CHANGELOG.md index 812f46a0..5b6a37ac 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ - [#413](https://github.com/clojure-emacs/orchard/pull/413): Print: protect against StackOverflow when printing recursive collections. - [#416](https://github.com/clojure-emacs/orchard/pull/416): Inspector: add string analytics. - [#415](https://github.com/clojure-emacs/orchard/pull/415): Print: honor a custom `print-method` for records and collections instead of traversing them structurally. +- [#419](https://github.com/clojure-emacs/orchard/pull/419): Print: simplify custom `print-method` detection and add `orchard.print/*honor-print-method*` to control it. ## 0.44.0 (2026-07-04) diff --git a/src/orchard/print.clj b/src/orchard/print.clj index 8915fbb0..152f538b 100644 --- a/src/orchard/print.clj +++ b/src/orchard/print.clj @@ -16,70 +16,40 @@ RT Symbol TaggedLiteral Var) (java.io Writer) (java.util Iterator List Map Map$Entry) - (java.util.concurrent ConcurrentHashMap) (mx.cider.orchard TruncatingStringWriter TruncatingStringWriter$TotalLimitExceeded))) -(def ^:private structural-print-interfaces - "The generic collection interfaces that orchard prints structurally on its - own. A value whose `print-method` resolves to one of their implementations - has no custom representation (see `custom-print-method?`)." - [clojure.lang.IPersistentMap clojure.lang.IPersistentSet - clojure.lang.IPersistentVector clojure.lang.IRecord clojure.lang.ISeq - java.util.List java.util.Map java.util.RandomAccess java.util.Set]) - -(deftype PrintMethodCache [table prefers structural ^ConcurrentHashMap classes]) - -(def ^:private print-method-cache - "Caches per class whether it has a custom `print-method` (see - `custom-print-method?`). The whole cache is dropped whenever `print-method` - gains or loses implementations or preferences, so re-registering a method - - e.g. when reloading a namespace - can't leave stale results behind." - (atom nil)) - -(defn- current-print-method-cache - "Return the up-to-date cache, rebuilding it if `print-method`'s method or - preference tables have changed since it was built." - ^PrintMethodCache [] - (let [table (methods print-method) - prefs (prefers print-method) - ^PrintMethodCache cache @print-method-cache] - (if (and cache - (identical? table (.-table cache)) - (identical? prefs (.-prefers cache))) - cache - ;; A thread caching into a cache that is being replaced is harmless: it - ;; writes into an object that no one will look at again. - (reset! print-method-cache - (PrintMethodCache. table prefs - (into #{} - (keep #(get-method print-method %)) - structural-print-interfaces) - (ConcurrentHashMap.)))))) +(def ^:dynamic *honor-print-method* + "When true, records and collections whose type defines a custom + `print-method` are printed with it instead of orchard's structural printer. + Bind to false where structural output is preferable regardless of the type's + own representation." + true) + +(def ^:private generic-print-methods + "The collection interfaces whose `print-method` implementations orchard + replaces with its own structural printing. A value whose `print-method` is + more specific than these has a deliberate custom representation (see + `custom-print-method?`)." + [clojure.lang.IPersistentMap clojure.lang.ISeq clojure.lang.IPersistentVector + clojure.lang.IRecord clojure.lang.IPersistentSet java.util.Map + java.util.RandomAccess java.util.List java.util.Set]) (defn- custom-print-method? "True if `x` has a `print-method` more specific than the generic collection implementations - i.e. a deliberate custom textual representation that orchard - should use instead of traversing the value's structure. This keeps records - and collections that define their own `print-method` (e.g. `tech.ml.dataset` - datasets) rendered as intended, and avoids descending into - and potentially - looping on - such objects' internals." + should use instead of traversing the value's structure (e.g. `tech.ml.dataset` + datasets). Relies on the multimethod's own dispatch cache, so redefined + `print-method` implementations are always picked up." [x] - (let [c (class x) - cache (current-print-method-cache) - ^ConcurrentHashMap classes (.-classes cache) - cached (.get classes c)] - (if (some? cached) - cached - (let [v (if-let [m (try (get-method print-method c) - ;; get-method throws when several implementations - ;; match `c` and none is preferred. Print such - ;; values structurally. - (catch Exception _ nil))] - (not (contains? (.-structural cache) m)) - false)] - (.put classes c v) - v)))) + (when *honor-print-method* + (try + (when-let [m (get-method print-method (class x))] + (not (some #(identical? m (get-method print-method %)) + generic-print-methods))) + ;; get-method throws when several implementations match a class and none + ;; is preferred. Print such values structurally. + (catch Exception _ nil)))) (defn- structural-tag "Return the `print` dispatch value for the collection types that orchard diff --git a/test/orchard/print_test.clj b/test/orchard/print_test.clj index 42bb91ad..938c196b 100644 --- a/test/orchard/print_test.clj +++ b/test/orchard/print_test.clj @@ -288,6 +288,11 @@ (sut/print-str (AmbiguousPrintList. (java.util.ArrayList. [1 2 3]))))) (is (= "()" (sut/print-str (AmbiguousPrintList. (java.util.ArrayList.)))))) + (testing "binding *honor-print-method* to false forces structural printing" + (binding [sut/*honor-print-method* false] + (is (= "#PrintMethodRecord{:id 1, :peer nil}" + (sut/print-str (->PrintMethodRecord 1 nil)))))) + (testing "re-registering a generic print-method doesn't disable structural printing" (let [orig (get-method print-method java.util.Map)] (try