Add :class-lookup option for local extensibility

Based off of the fressian API.

src/puget/class_lookup.clj

@@ -0,0 +1,32 @@
+(ns puget.class-lookup
+  "Class-based lookup, algorithm based on
+  https://github.com/Datomic/fressian/blob/32a833ba5adce9cd14365ff64b8b42a8569b7916/src/org/fressian/impl/InheritanceLookup.java")
+
+(defn check-base-classes
+  [m ^Class the-class]
+  (loop [c (.getSuperclass the-class)]
+    (when-not (= Object c)
+      (or (get m c)
+          (recur (.getSuperclass c))))))
+
+(defn check-base-interfaces
+  [m ^Class the-class]
+  (let [possibles (java.util.HashMap.)]
+    (loop [c the-class]
+      (when-not (= Object c)
+        (doseq [itf (.getInterfaces c)]
+          (when-let [impl (get m itf)]
+            (.put possibles itf impl)))
+        (recur (.getSuperclass c))))
+    (case (.size possibles)
+      0 nil
+      1 (first (vals possibles))
+      (throw (ex-info "More than one interface match for class"
+                      {:class the-class})))))
+
+(defn lookup-impl
+  [m the-class]
+  (or (get m the-class)
+      (check-base-classes m the-class)
+      (check-base-interfaces m the-class)
+      (get m Object)))

src/puget/printer.clj

@@ -4,6 +4,7 @@
     [clojure.string :as str]
     [fipp.printer :as fipp]
     (puget
+      [class-lookup :as class-lookup]
       [color :as color]
       [data :as data]
       [order :as order])
@@ -87,6 +88,7 @@
    :map-coll-separator " "
    :escape-types nil
    :print-fallback nil
+   :class-lookup nil
    :print-meta nil
    :print-color false
    :color-markup :ansi
@@ -109,6 +111,14 @@
     :class-delimiter [:blue]
     :class-name      [:bold :blue]}})
 
+(defn add-class-lookup-cache
+  [opts]
+  (if-let [class-lookup (:class-lookup opts)]
+    (assoc opts :cached-class-lookup (memoize
+                                      (fn [the-class]
+                                        (class-lookup/lookup-impl class-lookup
+                                                                  the-class))))
+    opts))
 
 (defn merge-options
   "Merges maps of printer options, taking care to combine the color scheme
@@ -122,7 +132,7 @@
   "Executes the given expressions with a set of options merged into the current
   option map."
   [opts & body]
-  `(binding [*options* (merge-options *options* ~opts)]
+  `(binding [*options* (add-class-lookup-cache (merge-options *options* ~opts))]
      ~@body))
 
 
@@ -192,11 +202,16 @@
   notation are rendered as tagged literals; others are dispatched on their
   `type`."
   [value]
-  (let [class-sym (some-> value class .getName symbol)]
+  (let [the-class (class value)
+        class-sym (some-> the-class .getName symbol)]
     (cond
       (contains? (:escape-types *options*) class-sym)
         :default
 
+      (let [f (:cached-class-lookup *options*)]
+        (and f (f the-class)))
+        ::class-lookup-tagged-literal
+
       (satisfies? data/ExtendedNotation value)
         ::tagged-literal
 
@@ -406,6 +421,14 @@
      (if (coll? form) :line " ")
      (format-doc form)]))
 
+(defmethod format-doc ::class-lookup-tagged-literal
+  [value]
+  (let [{:keys [tag form]} (((:cached-class-lookup *options*) (class value)) value)]
+    [:span
+     (color-doc :tag (str \# tag))
+     (if (coll? form) :line " ")
+     (format-doc form)]))
+
 
 (defmethod format-doc :default
   [value]