a proof of concept for issue #56

Author: darwin

src/lib/devtools/formatters/printing.cljs

@@ -5,6 +5,7 @@
             [devtools.protocols :refer [ITemplate IGroup ISurrogate IFormat]]
             [devtools.formatters.state :refer [push-object-to-current-history! *current-state* get-current-state
                                                is-circular? get-managed-print-level set-managed-print-level
+                                               add-object-to-current-path-info! get-current-path-info
                                                update-current-state!]]
             [devtools.formatters.helpers :refer [cljs-value? expandable? abbreviated? directly-printable? should-render?]]))
 
@@ -88,12 +89,19 @@
 
     :else group))
 
-(defn post-process-printed-output [output-group obj markup-db circular?]
+(defn wrap-group-with-path-annotation [group path-info]
+  (if (and (pref :render-path-annotations)
+           (some? path-info))
+    [(concat ["annotation" {"path" (into-array path-info)}] group)]
+    group))
+
+(defn post-process-printed-output [output-group obj markup-db circular? path-info]
   (-> output-group
       (detect-edge-case-and-patch-it obj markup-db)                                                                           ; an ugly hack
       (wrap-group-in-reference-if-needed obj markup-db)
       (wrap-group-in-circular-warning-if-needed markup-db circular?)
-      (wrap-group-in-meta-if-needed obj markup-db)))
+      (wrap-group-in-meta-if-needed obj markup-db)
+      (wrap-group-with-path-annotation path-info)))
 
 ; -- alternative printer ----------------------------------------------------------------------------------------------------
 
@@ -111,12 +119,14 @@
 
 (defn alt-printer-impl [obj writer opts]
   (binding [*current-state* (get-current-state)]
+    (add-object-to-current-path-info! obj)
     (let [{:keys [markup-db]} opts
           circular? (is-circular? obj)
-          inner-writer (make-template-writer (:markup-db opts))]
+          inner-writer (make-template-writer (:markup-db opts))
+          path-info (get-current-path-info)]
       (push-object-to-current-history! obj)
       (alt-printer-job obj inner-writer opts)
-      (.merge writer (post-process-printed-output (.get-group inner-writer) obj markup-db circular?)))))
+      (.merge writer (post-process-printed-output (.get-group inner-writer) obj markup-db circular? path-info)))))
 
 ; -- common code for managed printing ---------------------------------------------------------------------------------------
 

src/lib/devtools/formatters/state.cljs

@@ -43,6 +43,39 @@
   (let [history (get-current-history)]
     (some #(identical? % object) history)))
 
+(defn get-last-object-from-current-history []
+  (first (get-current-history)))                                                                                              ; note the list is reversed
+
+(defn present-path-segment [v]
+  (cond
+    (string? v) v
+    (keyword? v) (str v)
+    (number? v) v
+    :else "?"))
+
+(defn seek-path-segment [coll val]
+  (let [* (fn [[k v]]
+            (if (identical? v val)
+              (present-path-segment k)))]
+    (some * coll)))
+
+(defn build-path-segment [parent-object object]
+  (cond
+    (map? parent-object) (seek-path-segment (seq parent-object) object)
+    (sequential? parent-object) (seek-path-segment (map-indexed (fn [i x] [i x]) parent-object) object)))
+
+(defn extend-path-info [path-info object]
+  (let [parent-object (get-last-object-from-current-history)]
+    (if-some [path-segment (build-path-segment parent-object object)]
+      (conj (or path-info []) path-segment)
+      path-info)))
+
+(defn add-object-to-current-path-info! [object]
+  (update-current-state! update :path-info extend-path-info object))
+
+(defn get-current-path-info []
+  (:path-info (get-current-state)))
+
 (defn ^bool prevent-recursion? []
   (boolean (:prevent-recursion (get-current-state))))
 

src/lib/devtools/formatters/templating.cljs

@@ -106,6 +106,9 @@
       (make-group "object" #js {"object" object
                                 "config" sub-state}))))
 
+(defn make-annotation [data markups]
+  (apply make-group "annotation" (clj->js data) markups))
+
 ; -- JSON ML support --------------------------------------------------------------------------------------------------------
 
 ; a renderer from hiccup-like data markup to json-ml
@@ -162,6 +165,9 @@
     "reference" (let [obj (first args)
                       converted-obj (if (surrogate-markup? obj) (render-json-ml* obj) obj)]
                   (apply make-reference (concat [converted-obj] (rest args))))
+    "annotation" (let [data (first args)
+                       converted-args (map render-json-ml* (rest args))]
+                   (make-annotation data converted-args))
     (assert-markup-error (str "no matching special tag name: '" name "'"))))
 
 (defn emptyish? [v]

test/src/tests/devtools/tests/format.cljs

@@ -1089,3 +1089,55 @@
           [:float-infinity-tag "##-Inf"]
           "]"]])
       (has-body? wrapped-infs false))))
+
+(deftest test-issue-56
+  (testing "render path annotations"
+    (with-prefs {:render-path-annotations true}
+      (let [m {:k1 {:k2 "val"}}]
+        (is-header m
+          [:cljs-land-tag
+           [:header-tag
+            "{"
+            [:keyword-tag ":k1"]
+            :spacer
+            ["annotation"
+             {"path" #js [":k1"]}
+             "{"
+             ["annotation"
+              {"path" #js [":k1"]}
+              [:keyword-tag ":k2"]]
+             :spacer
+             ["annotation"
+              {"path" #js [":k1" ":k2"]}
+              [:string-tag "\"val\""]]
+             "}"]
+            "}"]]))
+      (let [m ['first ["val"]]]
+        (is-header m
+          [:cljs-land-tag
+           [:header-tag
+            "["
+            ["annotation"
+             {"path" #js [0]}
+             [:symbol-tag "first"]]
+            :spacer
+            ["annotation"
+             {"path" #js [1]}
+             "["
+             ["annotation"
+              {"path" #js [1 0]}
+              [:string-tag "\"val\""]]
+             "]"]
+            "]"]]))
+      (let [m {{} "val"}]
+        (is-header m
+          [:cljs-land-tag
+           [:header-tag
+            "{"
+            "{"
+            "}"
+            :spacer
+            ["annotation"
+             {"path" #js ["?"]}
+             [:string-tag "\"val\""]]
+            "}"]])))))