146 lines
7.3 KiB
Clojure
146 lines
7.3 KiB
Clojure
(ns devtools.formatters.printing
|
|
(:require-macros [devtools.oops :refer [safe-call]])
|
|
(:require [devtools.prefs :refer [pref]]
|
|
[devtools.format :refer [IDevtoolsFormat]]
|
|
[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
|
|
update-current-state!]]
|
|
[devtools.formatters.helpers :refer [cljs-value? expandable? abbreviated? directly-printable? should-render?]]))
|
|
|
|
; -- helpers ----------------------------------------------------------------------------------------------------------------
|
|
|
|
(defn markup? [value]
|
|
(::markup (meta value)))
|
|
|
|
(defn mark-as-markup [value]
|
|
(with-meta value {::markup true}))
|
|
|
|
(defn build-markup [markup-db fn-key & args]
|
|
(let [f (get markup-db fn-key)]
|
|
(assert f (str "missing markup method in markup-db: " fn-key))
|
|
(mark-as-markup (apply f args))))
|
|
|
|
(defn wrap-value-as-reference-if-needed [markup-db value]
|
|
(if (or (directly-printable? value) (markup? value))
|
|
value
|
|
(build-markup markup-db :reference-surrogate value)))
|
|
|
|
; -- TemplateWriter ---------------------------------------------------------------------------------------------------------
|
|
|
|
(deftype TemplateWriter [^:mutable group markup-db]
|
|
Object
|
|
(merge [_ a] (set! group (concat group a)))
|
|
(get-group [_] group)
|
|
IWriter
|
|
(-write [_ o] (set! group (concat group [(wrap-value-as-reference-if-needed markup-db o)]))) ; issue #21
|
|
(-flush [_] nil))
|
|
|
|
(defn make-template-writer [markup-db]
|
|
(TemplateWriter. [] markup-db))
|
|
|
|
; -- post-processing --------------------------------------------------------------------------------------------------------
|
|
|
|
(defn already-reference? [group]
|
|
(if-let [tag (first (first group))]
|
|
(= tag "reference")))
|
|
|
|
(defn wrap-group-in-reference-if-needed [group obj markup-db]
|
|
(if (and (not (already-reference? group))
|
|
(or (expandable? obj) (abbreviated? group)))
|
|
(let [expandable-markup (apply build-markup markup-db :expandable group)
|
|
surrogate-markup (build-markup markup-db :raw-surrogate obj expandable-markup :target)
|
|
reference-markup (build-markup markup-db :reference surrogate-markup)]
|
|
[reference-markup])
|
|
group))
|
|
|
|
(defn wrap-group-in-circular-warning-if-needed [group markup-db circular?]
|
|
(if circular?
|
|
[(apply build-markup markup-db :circular-reference group)]
|
|
group))
|
|
|
|
(defn wrap-group-in-meta-if-needed [group value markup-db]
|
|
(if (should-render? :render-metas value #(some? (meta %)))
|
|
[(apply (partial (:meta-wrapper markup-db) (meta value)) group)]
|
|
group))
|
|
|
|
; default printer implementation can do this:
|
|
; :else (write-all writer "#<" (str obj) ">")
|
|
; we want to wrap stringified obj in a reference for further inspection
|
|
;
|
|
; this behaviour changed in https://github.com/clojure/clojurescript/commit/34c3b8985ed8197d90f441c46d168c4024a20eb8
|
|
; newly functions and :else branch print "#object [" ... "]"
|
|
;
|
|
; in some situations obj can still be a clojurescript value (e.g. deftypes)
|
|
; we have to implement a special flag to prevent infinite recursion
|
|
; see https://github.com/binaryage/cljs-devtools/issues/2
|
|
; https://github.com/binaryage/cljs-devtools/issues/8
|
|
(defn detect-edge-case-and-patch-it [group obj markup-db]
|
|
(cond
|
|
(or
|
|
(and (= (count group) 5) (= (nth group 0) "#object[") (= (nth group 4) "\"]")) ; function case
|
|
(and (= (count group) 5) (= (nth group 0) "#object[") (= (nth group 4) "]")) ; :else -constructor case
|
|
(and (= (count group) 3) (= (nth group 0) "#object[") (= (nth group 2) "]"))) ; :else -cljs$lang$ctorStr case
|
|
[(build-markup markup-db :native-reference obj)]
|
|
|
|
(and (= (count group) 3) (= (nth group 0) "#<") (= (str obj) (nth group 1)) (= (nth group 2) ">")) ; old code prior r1.7.28
|
|
[(nth group 0) (build-markup :native-reference obj) (nth group 2)]
|
|
|
|
:else group))
|
|
|
|
(defn post-process-printed-output [output-group obj markup-db circular?]
|
|
(-> 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)))
|
|
|
|
; -- alternative printer ----------------------------------------------------------------------------------------------------
|
|
|
|
(defn alt-printer-job [obj writer opts]
|
|
(let [{:keys [markup-db]} opts]
|
|
(if (or (safe-call satisfies? false IDevtoolsFormat obj)
|
|
(safe-call satisfies? false IFormat obj)) ; we have to wrap value in reference if detected IFormat
|
|
(-write writer (build-markup markup-db :reference obj))
|
|
(if-let [atomic-markup (build-markup markup-db :atomic obj)]
|
|
(-write writer atomic-markup)
|
|
(let [default-impl (:fallback-impl opts)
|
|
; we want to limit print-level, at max-print-level level use maximal abbreviation e.g. [...] or {...}
|
|
inner-opts (if (= *print-level* 1) (assoc opts :print-length 0) opts)]
|
|
(default-impl obj writer inner-opts))))))
|
|
|
|
(defn alt-printer-impl [obj writer opts]
|
|
(binding [*current-state* (get-current-state)]
|
|
(let [{:keys [markup-db]} opts
|
|
circular? (is-circular? obj)
|
|
inner-writer (make-template-writer (:markup-db opts))]
|
|
(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?)))))
|
|
|
|
; -- common code for managed printing ---------------------------------------------------------------------------------------
|
|
|
|
(defn managed-print [tag markup-db printer]
|
|
(let [writer (make-template-writer markup-db)
|
|
opts {:alt-impl alt-printer-impl
|
|
:markup-db markup-db
|
|
:print-length (pref :max-header-elements)
|
|
:more-marker (pref :more-marker)}
|
|
job-fn #(printer writer opts)]
|
|
(if-let [managed-print-level (get-managed-print-level)]
|
|
(binding [*print-level* managed-print-level]
|
|
(update-current-state! #(set-managed-print-level % nil)) ; reset managed-print-level so it does not propagate further down in expaded data
|
|
(job-fn))
|
|
(job-fn))
|
|
(concat [(pref tag)] (.get-group writer))))
|
|
|
|
; -- public printing API ----------------------------------------------------------------------------------------------------
|
|
|
|
(defn managed-print-via-writer [value tag markup-db]
|
|
(managed-print tag markup-db (fn [writer opts]
|
|
(pr-seq-writer [value] writer opts)))) ; note we use pr-seq-writer becasue pr-writer is private for some reason
|
|
|
|
(defn managed-print-via-protocol [value tag markup-db]
|
|
(managed-print tag markup-db (fn [writer opts]
|
|
(-pr-writer value writer opts))))
|