Merge pull request #247 from cichli/pprint-fn

Custom pretty printing

project.clj

@@ -8,14 +8,16 @@
 
   :dependencies [[org.clojure/tools.nrepl "0.2.12"]
                  [org.tcrawley/dynapath "0.2.3"]
+                 ^:source-dep [mvxcvi/puget "1.0.0"]
+                 ^:source-dep [fipp "0.6.3"]
                  ^:source-dep [compliment "0.2.5"]
                  ^:source-dep [cljs-tooling "0.1.9"]
                  ^:source-dep [cljfmt "0.3.0"]
                  ^:source-dep [org.clojure/java.classpath "0.2.3"]
                  ^:source-dep [org.clojure/tools.namespace "0.2.11"]
                  ^:source-dep [org.clojure/tools.trace "0.7.9"]
                  ^:source-dep [org.clojure/tools.reader "0.10.0"]]
-  :plugins [[thomasa/mranderson "0.4.5"]]
+  :plugins [[thomasa/mranderson "0.4.6"]]
   :exclusions [org.clojure/clojure]
 
   :filespecs [{:type :bytes :path "cider/cider-nrepl/project.clj" :bytes ~(slurp "project.clj")}]

src/cider/nrepl/middleware/debug.clj

@@ -2,6 +2,7 @@
   "Expression-based debugger for clojure code"
   {:author "Artur Malabarba"}
   (:require [cider.nrepl.middleware.inspect :refer [swap-inspector!]]
+            [cider.nrepl.middleware.pprint :as pprint]
             [cider.nrepl.middleware.stacktrace :as stacktrace]
             [cider.nrepl.middleware.util.cljs :as cljs]
             [cider.nrepl.middleware.util.inspect :as inspect]
@@ -123,6 +124,11 @@
   "Bound by the `breakpoint` macro to the local &env."
   {})
 
+(def ^:dynamic *pprint-fn*
+  "Bound by the `breakpoint` macro to the pretty-printing function determined by
+  the `wrap-pprint-fn` middleware."
+  nil)
+
 (def print-length (atom nil))
 (def print-level (atom nil))
 
@@ -177,7 +183,7 @@
         (when-not (instance? ThreadDeath root-ex)
           (debugger-send
            {:status :eval-error
-            :causes [(let [causes (stacktrace/analyze-causes e 50 50)]
+            :causes [(let [causes (stacktrace/analyze-causes e *pprint-fn*)]
                        (when (coll? causes) (last causes)))]})))
       nil)))
 
@@ -245,7 +251,8 @@
   Sends a response to the message stored in debugger-message."
   [value coor]
   `(binding [*skip-breaks* (or *skip-breaks* (atom nil))
-             *locals* ~(sanitize-env &env)]
+             *locals* ~(sanitize-env &env)
+             *pprint-fn* (:pprint-fn *msg*)]
      (let [val# ~value]
        (cond
          (skip-breaks? ~coor) val#
@@ -341,6 +348,7 @@
  #'wrap-debug
  (cljs/requires-piggieback
   {:expects #{"eval"}
+   :requires #{#'pprint/wrap-pprint-fn}
    :handles
    {"debug-input"
     {:doc "Read client input on debug action."

src/cider/nrepl/middleware/pprint.clj

@@ -1,31 +1,87 @@
 (ns cider.nrepl.middleware.pprint
   (:require [cider.nrepl.middleware.util.cljs :as cljs]
+            [cider.nrepl.middleware.util.misc :as u]
             [clojure.pprint :refer [pprint *print-right-margin*]]
-            [clojure.tools.nrepl.middleware :refer [set-descriptor!]]
             [clojure.tools.nrepl.middleware.interruptible-eval :refer [*msg*]]
             [clojure.tools.nrepl.middleware.pr-values :refer [pr-values]]
+            [clojure.tools.nrepl.middleware :refer [set-descriptor!]]
             [clojure.tools.nrepl.middleware.session :as session]
             [clojure.tools.nrepl.misc :refer [response-for]]
-            [clojure.tools.nrepl.transport :as transport])
+            [clojure.tools.nrepl.transport :as transport]
+            [fipp.edn :as fipp]
+            [puget.printer :as puget])
   (:import clojure.tools.nrepl.transport.Transport))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn fipp-pprint [object]
+  (fipp/pprint object {:width (or *print-right-margin* 72)}))
+
+(defn puget-pprint [object]
+  (puget/pprint object {:width (or *print-right-margin* 72)}))
+
+(defn- resolve-pprint-fn
+  [sym]
+  (let [var (some-> sym u/as-sym resolve)]
+
+    (when (or (nil? var) (not (var? var)))
+      (throw (IllegalArgumentException. (format "%s is not resolvable as a var" sym))))
+
+    @var))
+
+(defn wrap-pprint-fn
+  "Middleware that provides a common interface for other middlewares that need
+  to perform customisable pretty-printing.
+
+  A namespace-qualified name of the function to be used for printing can be
+  optionally passed in the `:pprint-fn` slot, the default value being
+  `clojure.pprint/pprint`.
+
+  The `:pprint-fn` slot will be replaced with a closure that calls the given
+  printing function with `*print-length*`, `*print-level*`, `*print-meta*`, and
+  `clojure.pprint/*print-right-margin*` bound to the values of the
+  `:print-length`, `:print-level`, `:print-meta`, and `:print-right-margin`
+  slots respectively.
+
+  Middlewares further down the stack can then look up the `:pprint-fn` slot and
+  call it where necessary."
+  [handler]
+  (fn [{:keys [pprint-fn print-length print-level print-meta print-right-margin session]
+        :or {pprint-fn 'clojure.pprint/pprint}
+        :as msg}]
+    (handler (assoc msg :pprint-fn (fn [object]
+                                     (binding [*print-length* (or print-length (get @session #'*print-length*))
+                                               *print-level* (or print-level (get @session #'*print-level*))
+                                               *print-meta* (or print-meta (get @session #'*print-meta*))
+                                               *print-right-margin* (or print-right-margin (get @session #'*print-right-margin*))]
+                                       ((resolve-pprint-fn pprint-fn) object)))))))
+
+(def wrap-pprint-fn-optional-arguments
+  {"pprint-fn" "The namespace-qualified name of a single-arity function to use for pretty-printing. Defaults to `clojure.pprint/pprint`."
+   "print-length" "Value to bind to `*print-length*` when pretty-printing. Defaults to the value bound in the current REPL session."
+   "print-level" "Value to bind to `*print-level*` when pretty-printing. Defaults to the value bound in the current REPL session."
+   "print-meta" "Value to bind to `*print-meta*` when pretty-printing. Defaults to the value bound in the current REPL session."
+   "print-right-margin" "Value to bind to `clojure.pprint/*print-right-margin*` when pretty-printing. Defaults to the value bound in the current REPL session."})
+
+(set-descriptor!
+ #'wrap-pprint-fn
+ {:requires #{#'session/session}})
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (defn- pprint-writer
   [{:keys [session transport] :as msg}]
   (#'session/session-out :pprint-out (:id (meta session)) transport))
 
 (defn pprint-reply
-  [{:keys [right-margin session transport] :as msg} response]
+  [{:keys [pprint-fn session transport] :as msg} response]
   (with-open [writer (pprint-writer msg)]
     ;; Binding `*msg*` sets the `:id` slot when printing to an nREPL session
     ;; PrintWriter (as created by `pprint-writer`), which the client requires to
     ;; handle the response correctly.
-    (binding [*msg* msg
-              *out* writer
-              *print-length* (get @session #'*print-length*)
-              *print-level* (get @session #'*print-level*)
-              *print-right-margin* right-margin]
+    (binding [*msg* msg *out* writer]
       (let [value (cljs/response-value msg response)
-            print-fn (if (string? value) println pprint)]
+            print-fn (if (string? value) println pprint-fn)]
         (print-fn value))))
   (transport/send transport (response-for msg :pprint-sentinel {})))
 
@@ -40,21 +96,23 @@
       (.send transport (dissoc response :value)))))
 
 (defn wrap-pprint
-  "Middleware that adds a pretty printing option to the eval op.
+  "Middleware that adds a pretty-printing option to the eval op.
   Passing a non-nil value in the `:pprint` slot will cause eval to call
   clojure.pprint/pprint on its result. The `:right-margin` slot can be used to
   bind `*clojure.pprint/*print-right-margin*` during the evaluation."
   [handler]
-  (fn [{:keys [op pprint right-margin] :as msg}]
-    (if (and pprint (= op "eval"))
-      (handler (merge msg {:transport (pprint-transport msg)}))
-      (handler msg))))
+  (fn [{:keys [op pprint] :as msg}]
+    (handler (cond-> msg
+               (and (= op "eval") pprint)
+               (assoc :transport (pprint-transport msg))))))
 
 (set-descriptor!
  #'wrap-pprint
  (cljs/expects-piggieback
-  {:requires #{"clone" #'pr-values}
+  {:requires #{"clone" #'pr-values #'wrap-pprint-fn}
    :expects #{"eval"}
    :handles
    {"pprint-middleware"
-    {:doc "Enhances the `eval` op by pretty printing the evaluation result if a `:pprint` slot is found in the msg map. Not an op by itself."}}}))
+    {:doc "Enhances the `eval` op by adding pretty-printing. Not an op in itself."
+     :optional (merge wrap-pprint-fn-optional-arguments
+                      {"pprint" "If present and non-nil, pretty-print the result of evaluation."})}}}))

src/cider/nrepl/middleware/refresh.clj

@@ -4,7 +4,8 @@
       ;; `refresh-tracker` is reset with every refresh. This only has any effect
       ;; when developing cider-nrepl itself, or when cider-nrepl is used as a
       ;; checkout dependency - tools.namespace doesn't reload source in JARs.
-  (:require [cider.nrepl.middleware.stacktrace :refer [analyze-causes]]
+  (:require [cider.nrepl.middleware.pprint :as pprint]
+            [cider.nrepl.middleware.stacktrace :refer [analyze-causes]]
             [cider.nrepl.middleware.util.misc :as u]
             [clojure.main :refer [repl-caught]]
             [clojure.tools.namespace.dir :as dir]
@@ -54,7 +55,7 @@
                     (-> (set (:arglists (meta var)))
                         (contains? []))))
       (throw (IllegalArgumentException.
-              (format "%s is not a single-arity fn" sym))))
+              (format "%s is not a function of no arguments" sym))))
 
     (binding [*msg* msg
               *out* (get @session #'*out*)
@@ -70,12 +71,12 @@
 
 (defn- error-reply
   [{:keys [error error-ns]}
-   {:keys [print-length print-level session transport] :as msg}]
+   {:keys [pprint-fn session transport] :as msg}]
 
   (transport/send
    transport
    (response-for msg (cond-> {:status :error}
-                       error (assoc :error (analyze-causes error print-length print-level))
+                       error (assoc :error (analyze-causes error pprint-fn))
                        error-ns (assoc :error-ns error-ns))))
 
   (binding [*msg* msg
@@ -171,27 +172,25 @@
 
 (set-descriptor!
  #'wrap-refresh
- {:requires #{"clone"}
+ {:requires #{"clone" #'pprint/wrap-pprint-fn}
   :handles
   {"refresh"
    {:doc "Reloads all changed files in dependency order."
-    :optional {"dirs" "List of directories to scan. If no directories given, defaults to all directories on the classpath."
-               "before" "The namespace-qualified name of a zero-arity function to call before reloading."
-               "after" "The namespace-qualified name of a zero-arity function to call after reloading."
-               "print-length" "Value to bind to `*print-length*` when pretty-printing error data, if an exception is thrown."
-               "print-level" "Value to bind to `*print-level*` when pretty-printing error data, if an exception is thrown."}
+    :optional (merge pprint/wrap-pprint-fn-optional-arguments
+                     {"dirs" "List of directories to scan. If no directories given, defaults to all directories on the classpath."
+                      "before" "The namespace-qualified name of a zero-arity function to call before reloading."
+                      "after" "The namespace-qualified name of a zero-arity function to call after reloading."})
     :returns {"reloading" "List of namespaces that will be reloaded."
               "status" "`:ok` if reloading was successful; otherwise `:error`."
               "error" "A sequence of all causes of the thrown exception when `status` is `:error`."
               "error-ns" "The namespace that caused reloading to fail when `status` is `:error`."}}
 
    "refresh-all"
    {:doc "Reloads all files in dependency order."
-    :optional {"dirs" "List of directories to scan. If no directories given, defaults to all directories on the classpath."
-               "before" "The namespace-qualified name of a zero-arity function to call before reloading."
-               "after" "The namespace-qualified name of a zero-arity function to call after reloading."
-               "print-length" "Value to bind to `*print-length*` when pretty-printing error data, if an exception is thrown."
-               "print-level" "Value to bind to `*print-level*` when pretty-printing error data, if an exception is thrown."}
+    :optional (merge pprint/wrap-pprint-fn-optional-arguments
+                     {"dirs" "List of directories to scan. If no directories given, defaults to all directories on the classpath."
+                      "before" "The namespace-qualified name of a zero-arity function to call before reloading."
+                      "after" "The namespace-qualified name of a zero-arity function to call after reloading."})
     :returns {"reloading" "List of namespaces that will be reloaded."
               "status" "`:ok` if reloading was successful; otherwise `:error`."
               "error" "A sequence of all causes of the thrown exception when `status` is `:error`."

src/cider/nrepl/middleware/stacktrace.clj

@@ -1,8 +1,8 @@
 (ns cider.nrepl.middleware.stacktrace
   "Cause and stacktrace analysis for exceptions"
   {:author "Jeff Valk"}
-  (:require [cider.nrepl.middleware.util.cljs :as cljs]
-            [clojure.pprint :as pp]
+  (:require [cider.nrepl.middleware.pprint :as pprint]
+            [cider.nrepl.middleware.util.cljs :as cljs]
             [clojure.repl :as repl]
             [clojure.string :as str]
             [clojure.tools.nrepl.middleware :refer [set-descriptor!]]
@@ -122,33 +122,31 @@
 (defn analyze-cause
   "Return a map describing the exception cause. If `ex-data` exists, a `:data`
   key is appended."
-  [^Exception e print-length print-level]
+  [^Exception e pprint-fn]
   (let [m {:class (.getName (class e))
            :message (.getMessage e)
            :stacktrace (analyze-stacktrace e)}]
     (if-let [data (filtered-ex-data e)]
-      (assoc m :data (binding [*print-length* print-length
-                               *print-level* print-level]
-                       (with-out-str (pp/pprint data))))
+      (assoc m :data (with-out-str (pprint-fn data)))
       m)))
 
 (defn analyze-causes
   "Return the cause chain beginning with the thrown exception, with stack frames
   for each."
-  [e print-length print-level]
+  [e pprint-fn]
   (->> e
        (iterate #(.getCause ^Exception %))
        (take-while identity)
-       (map (comp extract-location #(analyze-cause % print-length print-level)))))
+       (map (comp extract-location #(analyze-cause % pprint-fn)))))
 
 ;;; ## Middleware
 
 (defn wrap-stacktrace-reply
-  [{:keys [session transport print-length print-level] :as msg}]
+  [{:keys [session transport pprint-fn] :as msg}]
   ;; no stacktrace support for cljs currently - they are printed by piggieback anyway
   (if-let [e (and (not (cljs/grab-cljs-env msg))
                   (@session #'*e))]
-    (doseq [cause (analyze-causes e print-length print-level)]
+    (doseq [cause (analyze-causes e pprint-fn)]
       (t/send transport (response-for msg cause)))
     (t/send transport (response-for msg :status :no-error)))
   (t/send transport (response-for msg :status :done)))
@@ -166,9 +164,10 @@
 (set-descriptor!
  #'wrap-stacktrace
  (cljs/requires-piggieback
-  {:requires #{#'session}
+  {:requires #{#'session #'pprint/wrap-pprint-fn}
    :expects #{}
    :handles {"stacktrace"
              {:doc (str "Return messages describing each cause and stack frame "
                         "of the most recent exception.")
+              :optional pprint/wrap-pprint-fn-optional-arguments
               :returns {"status" "\"done\", or \"no-error\" if `*e` is nil"}}}}))

src/cider/nrepl/middleware/test.clj

@@ -1,7 +1,8 @@
 (ns cider.nrepl.middleware.test
   "Test execution, reporting, and inspection"
   {:author "Jeff Valk"}
-  (:require [cider.nrepl.middleware.stacktrace :as st]
+  (:require [cider.nrepl.middleware.pprint :as pprint]
+            [cider.nrepl.middleware.stacktrace :as st]
             [cider.nrepl.middleware.util.misc :as u]
             [clojure.pprint :as pp]
             [clojure.test :as test]
@@ -182,11 +183,11 @@
   "Return exception cause and stack frame info for an erring test via the
   `stacktrace` middleware. The error to be retrieved is referenced by namespace,
   var name, and assertion index within the var."
-  [{:keys [ns var index session transport print-length print-level] :as msg}]
+  [{:keys [ns var index session transport pprint-fn] :as msg}]
   (with-interruptible-eval msg
     (let [[ns var] (map u/as-sym [ns var])]
       (if-let [e (get-in @results [ns var index :error])]
-        (doseq [cause (st/analyze-causes e print-length print-level)]
+        (doseq [cause (st/analyze-causes e pprint-fn)]
           (t/send transport (response-for msg cause)))
         (t/send transport (response-for msg :status :no-error)))
       (t/send transport (response-for msg :status :done)))))
@@ -222,8 +223,11 @@
 ;; nREPL middleware descriptor info
 (set-descriptor!
  #'wrap-test
- {:requires #{#'session}
+ {:requires #{#'session #'pprint/wrap-pprint-fn}
   :expects #{#'pr-values}
-  :handles {"test"            {:doc (:doc (meta #'handle-test))}
-            "test-stacktrace" {:doc (:doc (meta #'handle-stacktrace))}
-            "retest"          {:doc (:doc (meta #'handle-retest))}}})
+  :handles {"test"            {:doc (:doc (meta #'handle-test))
+                               :optional pprint/wrap-pprint-fn-optional-arguments}
+            "test-stacktrace" {:doc (:doc (meta #'handle-stacktrace))
+                               :optional pprint/wrap-pprint-fn-optional-arguments}
+            "retest"          {:doc (:doc (meta #'handle-retest))
+                               :optional pprint/wrap-pprint-fn-optional-arguments}}})

test/clj/cider/nrepl/middleware/pprint_test.clj

@@ -32,7 +32,7 @@
              (:pprint-out (session/message {:op :eval
                                             :code code
                                             :pprint "true"
-                                            :right-margin 10})))))
+                                            :print-right-margin 10})))))
 
     (testing "wrap-pprint does not escape special characters when printing strings"
       (is (= "abc\ndef\tghi\n"
@@ -51,4 +51,22 @@
                         {:pprint-sentinel {}}
                         {:pprint-out "[4 5 6]\n"}
                         {:pprint-sentinel {}}
-                        {:status ["done"]}])))))
+                        {:status ["done"]}]))))
+
+  (testing "fipp-pprint works"
+    (let [message {:op :eval
+                   :code "{nil [nil nil nil #{nil} nil nil nil]}"
+                   :pprint "true"
+                   :pprint-fn "cider.nrepl.middleware.pprint/fipp-pprint"
+                   :print-right-margin 10}]
+      (is (= "{nil\n [nil\n  nil\n  nil\n  #{nil}\n  nil\n  nil\n  nil]}\n"
+             (:pprint-out (session/message (dissoc message :pprint-fn)))))
+      (is (= "{nil [nil\n      nil\n      nil\n      #{nil}\n      nil\n      nil\n      nil]}\n"
+             (:pprint-out (session/message message))))))
+
+  (testing "puget-pprint works"
+    (is (= "{:a 1, :b 2, :c 3, :d 4, :e 5}\n"
+           (:pprint-out (session/message {:op :eval
+                                          :code "{:b 2 :e 5 :a 1 :d 4 :c 3}"
+                                          :pprint "true"
+                                          :pprint-fn "cider.nrepl.middleware.pprint/puget-pprint"}))))))