Various pprint updates: Generalized support for various ref types Added pprint tests for various datatypes Bring private var access in line with the coding standard & all good sense Add support for PersistentQueue objects

Signed-off-by: Stuart Halloway <stu@thinkrelevance.com>

4 files changed, 93 insertions, 26 deletions

diff --git a/src/clj/clojure/pprint/cl_format.clj b/src/clj/clojure/pprint/cl_format.clj
index 71feeeed..f04aa552 100644
--- a/src/clj/clojure/pprint/cl_format.clj
+++ b/src/clj/clojure/pprint/cl_format.clj
@@ -1884,13 +1884,7 @@ format-in can be either a control string or a previously compiled format."
   {:added "1.2"}
   [format-in]
   `(let [format-in# ~format-in
-         my-c-c# (var-get (get (ns-interns (the-ns 'clojure.pprint))
-                               '~'cached-compile))
-         my-e-f# (var-get (get (ns-interns (the-ns 'clojure.pprint))
-                               '~'execute-format))
-         my-i-n# (var-get (get (ns-interns (the-ns 'clojure.pprint))
-                               '~'init-navigator))
-         cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)]
+         cf# (if (string? format-in#) (#'clojure.pprint/cached-compile format-in#) format-in#)]
      (fn [& args#]
-       (let [navigator# (my-i-n# args#)]
-         (my-e-f# cf# navigator#)))))
+       (let [navigator# (#'clojure.pprint/init-navigator args#)]
+         (#'clojure.pprint/execute-format cf# navigator#)))))
diff --git a/src/clj/clojure/pprint/dispatch.clj b/src/clj/clojure/pprint/dispatch.clj
index 47b6b41f..77e145fa 100644
--- a/src/clj/clojure/pprint/dispatch.clj
+++ b/src/clj/clojure/pprint/dispatch.clj
@@ -106,15 +106,36 @@
           (recur (next aseq)))))))
 
 (def ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))
-(defn- pprint-ref [ref]
-  (pprint-logical-block  :prefix "#<Ref " :suffix ">"
-    (write-out @ref)))
-(defn- pprint-atom [ref]
-  (pprint-logical-block :prefix "#<Atom " :suffix ">"
-    (write-out @ref)))
-(defn- pprint-agent [ref]
-  (pprint-logical-block :prefix "#<Agent " :suffix ">"
-    (write-out @ref)))
+
+;;; TODO: don't block on promise (currently impossible)
+
+(def ^{:private true} 
+     type-map {"core$future_call" "Future",
+               "core$promise" "Promise"})
+
+(defn- map-ref-type 
+  "Map ugly type names to something simpler"
+  [name]
+  (or (when-let [match (re-find #"^[^$]+\$[^$]+" name)]
+        (type-map match))
+      name))
+
+(defn- pprint-ideref [o]
+  (let [prefix (format "#<%s@%x%s: "
+                       (map-ref-type (.getSimpleName (class o)))
+                       (System/identityHashCode o)
+                       (if (and (instance? clojure.lang.Agent o)
+                                (agent-error o))
+                         " FAILED"
+                         ""))]
+    (pprint-logical-block  :prefix prefix :suffix ">"
+                           (pprint-indent :block (-> (count prefix) (- 2) -))
+                           (pprint-newline :linear)
+                           (write-out (cond 
+                                       (and (future? o) (not (future-done? o))) :pending
+                                       :else @o)))))
+
+(def ^{:private true} pprint-pqueue (formatter-out "~<<-(~;~@{~w~^ ~_~}~;)-<~:>"))
 
 (defn- pprint-simple-default [obj]
   (cond 
@@ -133,9 +154,8 @@
 (use-method simple-dispatch clojure.lang.IPersistentVector pprint-vector)
 (use-method simple-dispatch clojure.lang.IPersistentMap pprint-map)
 (use-method simple-dispatch clojure.lang.IPersistentSet pprint-set)
-(use-method simple-dispatch clojure.lang.Ref pprint-ref)
-(use-method simple-dispatch clojure.lang.Atom pprint-atom)
-(use-method simple-dispatch clojure.lang.Agent pprint-agent)
+(use-method simple-dispatch clojure.lang.PersistentQueue pprint-pqueue)
+(use-method simple-dispatch clojure.lang.IDeref pprint-ideref)
 (use-method simple-dispatch nil pr)
 (use-method simple-dispatch :default pprint-simple-default)
 
@@ -365,9 +385,8 @@
 (use-method code-dispatch clojure.lang.IPersistentVector pprint-vector)
 (use-method code-dispatch clojure.lang.IPersistentMap pprint-map)
 (use-method code-dispatch clojure.lang.IPersistentSet pprint-set)
-(use-method code-dispatch clojure.lang.Ref pprint-ref)
-(use-method code-dispatch clojure.lang.Atom pprint-atom)
-(use-method code-dispatch clojure.lang.Agent pprint-agent)
+(use-method code-dispatch clojure.lang.PersistentQueue pprint-pqueue)
+(use-method code-dispatch clojure.lang.IDeref pprint-ideref)
 (use-method code-dispatch nil pr)
 (use-method code-dispatch :default pprint-simple-default)
 
diff --git a/test/clojure/test_clojure/pprint/test_helper.clj b/test/clojure/test_clojure/pprint/test_helper.clj
index 3cc31506..b59be6bb 100644
--- a/test/clojure/test_clojure/pprint/test_helper.clj
+++ b/test/clojure/test_clojure/pprint/test_helper.clj
@@ -15,8 +15,13 @@
 ;; This is just a macro to make my tests a little cleaner
 
 (ns clojure.test-clojure.pprint.test-helper
-  (:use [clojure.test :only (deftest are run-tests)]))
+  (:use [clojure.test :only (deftest is)]))
 
+(defn- back-match [x y] (re-matches y x))
 (defmacro simple-tests [name & test-pairs]
-  `(deftest ~name (are [x y] (= x y) ~@test-pairs)))
+  `(deftest ~name
+     ~@(for [[x y] (partition 2 test-pairs)]
+         (if (instance? java.util.regex.Pattern y)
+           `(is (#'clojure.test-clojure.pprint.test-helper/back-match ~x ~y))
+           `(is (= ~x ~y))))))
 
diff --git a/test/clojure/test_clojure/pprint/test_pretty.clj b/test/clojure/test_clojure/pprint/test_pretty.clj
index 5615da44..74513fe1 100644
--- a/test/clojure/test_clojure/pprint/test_pretty.clj
+++ b/test/clojure/test_clojure/pprint/test_pretty.clj
@@ -192,3 +192,52 @@ Usage: *hello*
           :else (multi-defn stuff (or doc-str attr-map)))))
     (pprint-simple-code-list writer alis)))
 ")
+
+
+(defn tst-pprint
+  "A helper function to pprint to a string with a restricted right margin"
+  [right-margin obj]
+  (binding [*print-right-margin* right-margin
+            *print-pretty* true]
+    (write obj :stream nil)))
+
+;;; A bunch of predefined data to print
+(def future-filled (future-call (fn [] 100)))
+@future-filled
+(def future-unfilled (future-call (fn [] (.acquire (java.util.concurrent.Semaphore. 0)))))
+(def promise-filled (promise))
+(deliver promise-filled '(first second third))
+(def promise-unfilled (promise))
+(def basic-agent (agent '(first second third)))
+(def basic-atom (atom '(first second third)))
+(def basic-ref (ref '(first second third)))
+(def delay-forced (delay '(first second third)))
+(force delay-forced)
+(def delay-unforced (delay '(first second third)))
+(defrecord pprint-test-rec [a b c])
+
+
+(simple-tests pprint-datastructures-tests
+ (tst-pprint 20 future-filled) #"#<Future@[0-9a-f]+: \n  100>"
+ (tst-pprint 20 future-unfilled) #"#<Future@[0-9a-f]+: \n  :pending>"
+ (tst-pprint 20 promise-filled) #"#<Promise@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
+ ;; This hangs currently, cause we can't figure out whether a promise is filled
+ ;;(tst-pprint 20 promise-unfilled) #"#<Promise@[0-9a-f]+: \n  :pending>"
+ (tst-pprint 20 basic-agent) #"#<Agent@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
+ (tst-pprint 20 basic-atom) #"#<Atom@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
+ (tst-pprint 20 basic-ref) #"#<Ref@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
+ (tst-pprint 20 delay-forced) #"#<Delay@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
+ ;; Currently no way not to force the delay
+ ;;(tst-pprint 20 delay-unforced) #"#<Delay@[0-9a-f]+: \n  :pending>"
+ (tst-pprint 20 (pprint-test-rec. 'first 'second 'third)) "{:a first,\n :b second,\n :c third}"
+
+ ;; basic java arrays: fails owing to assembla ticket #346
+ ;;(tst-pprint 10 (int-array (range 7))) "[0,\n 1,\n 2,\n 3,\n 4,\n 5,\n 6]"
+ (tst-pprint 15 (reduce conj clojure.lang.PersistentQueue/EMPTY (range 10)))
+ "<-(0\n   1\n   2\n   3\n   4\n   5\n   6\n   7\n   8\n   9)-<"
+ )
+
+
+
+
+