I added a new macro, print-length-loop, that augments loop to only iterate *print-length* times and then emit the "...". This makes it easy to write correct hand-coded dispatch functions.

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

4 files changed, 90 insertions, 8 deletions

diff --git a/src/clj/clojure/pprint.clj b/src/clj/clojure/pprint.clj
index 846a5f32..ba90aa65 100644
--- a/src/clj/clojure/pprint.clj
+++ b/src/clj/clojure/pprint.clj
@@ -35,7 +35,8 @@ See documentation for pprint and cl-format for more information or
 complete documentation on the the clojure web site on github.",
        :added "1.2"}
     clojure.pprint
-    (:refer-clojure :exclude (deftype)))
+    (:refer-clojure :exclude (deftype))
+    (:use [clojure.walk :only [walk]]))
 
 
 (load "pprint/utilities")
diff --git a/src/clj/clojure/pprint/dispatch.clj b/src/clj/clojure/pprint/dispatch.clj
index a6ae2931..19ba9836 100644
--- a/src/clj/clojure/pprint/dispatch.clj
+++ b/src/clj/clojure/pprint/dispatch.clj
@@ -65,7 +65,7 @@
 ;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))
 (defn- pprint-simple-list [alis]
   (pprint-logical-block :prefix "(" :suffix ")"
-    (loop [alis (seq alis)]
+    (print-length-loop [alis (seq alis)]
       (when alis
 	(write-out (first alis))
 	(when (next alis)
@@ -80,7 +80,7 @@
 ;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>"))
 (defn- pprint-vector [avec]
   (pprint-logical-block :prefix "[" :suffix "]"
-    (loop [aseq (seq avec)]
+    (print-length-loop [aseq (seq avec)]
       (when aseq
 	(write-out (first aseq))
 	(when (next aseq)
@@ -93,12 +93,13 @@
 ;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
 (defn- pprint-map [amap]
   (pprint-logical-block :prefix "{" :suffix "}"
-    (loop [aseq (seq amap)]
+    (print-length-loop [aseq (seq amap)]
       (when aseq
 	(pprint-logical-block 
           (write-out (ffirst aseq))
           (.write ^java.io.Writer *out* " ")
           (pprint-newline :linear)
+          (set! *current-length* 0)     ; always print both parts of the [k v] pair
           (write-out (fnext (first aseq))))
         (when (next aseq)
           (.write ^java.io.Writer *out* ", ")
@@ -218,7 +219,7 @@
 
 (defn- pprint-binding-form [binding-vec]
   (pprint-logical-block :prefix "[" :suffix "]"
-    (loop [binding binding-vec]
+    (print-length-loop [binding binding-vec]
       (when (seq binding)
         (pprint-logical-block binding
           (write-out (first binding))
@@ -255,7 +256,7 @@
     (when (next alis)
       (.write ^java.io.Writer *out* " ")
       (pprint-newline :linear)
-     (loop [alis (next alis)]
+     (print-length-loop [alis (next alis)]
        (when alis
          (pprint-logical-block alis
           (write-out (first alis))
@@ -273,7 +274,7 @@
     (pprint-logical-block :prefix "(" :suffix ")"
       (pprint-indent :block 1)
       (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)
-      (loop [alis (seq (drop 3 alis))]
+      (print-length-loop [alis (seq (drop 3 alis))]
         (when alis
           (pprint-logical-block alis
             (write-out (first alis))
@@ -315,7 +316,7 @@
 (defn- pprint-simple-code-list [alis]
   (pprint-logical-block :prefix "(" :suffix ")"
     (pprint-indent :block 1)
-    (loop [alis (seq alis)]
+    (print-length-loop [alis (seq alis)]
       (when alis
 	(write-out (first alis))
 	(when (next alis)
diff --git a/src/clj/clojure/pprint/pprint_base.clj b/src/clj/clojure/pprint/pprint_base.clj
index 4be9ac51..ea035d42 100644
--- a/src/clj/clojure/pprint/pprint_base.clj
+++ b/src/clj/clojure/pprint/pprint_base.clj
@@ -371,4 +371,33 @@ THIS FUNCTION IS NOT YET IMPLEMENTED."
   (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Helpers for dispatch function writing
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- pll-mod-body [var-sym body]
+  (letfn [(inner [form]
+                 (if (seq? form)
+                   (let [form (macroexpand form)] 
+                     (condp = (first form)
+                       'loop* form
+                       'recur (concat `(recur (inc ~var-sym)) (rest form))
+                       (walk inner identity form)))
+                   form))]
+    (walk inner identity body)))
+
+(defmacro print-length-loop
+  "A version of loop that iterates at most *print-length* times. This is designed 
+for use in pretty-printer dispatch functions."
+  {:added "1.3"}
+  [bindings & body]
+  (let [count-var (gensym "length-count")
+        mod-body (pll-mod-body count-var body)]
+    `(loop ~(apply vector count-var 0 bindings)
+       (if (or (not *print-length*) (< ~count-var *print-length*))
+         (do ~@mod-body)
+         (.write ^java.io.Writer *out* "...")))))
+
 nil
diff --git a/test/clojure/test_clojure/pprint/test_pretty.clj b/test/clojure/test_clojure/pprint/test_pretty.clj
index ebbb29a1..77af6c52 100644
--- a/test/clojure/test_clojure/pprint/test_pretty.clj
+++ b/test/clojure/test_clojure/pprint/test_pretty.clj
@@ -272,4 +272,55 @@ Usage: *hello*
   "[\"hello\" \"there\"]\n"
 )
 
+(simple-tests print-length-tests
+  (binding [*print-length* 1] (with-out-str (pprint '(a b c d e f))))
+  "(a ...)\n"
+  (binding [*print-length* 2] (with-out-str (pprint '(a b c d e f))))
+  "(a b ...)\n"
+  (binding [*print-length* 6] (with-out-str (pprint '(a b c d e f))))
+  "(a b c d e f)\n"
+  (binding [*print-length* 8] (with-out-str (pprint '(a b c d e f))))
+  "(a b c d e f)\n"
+
+  (binding [*print-length* 1] (with-out-str (pprint [1 2 3 4 5 6])))
+  "[1 ...]\n"
+  (binding [*print-length* 2] (with-out-str (pprint [1 2 3 4 5 6])))
+  "[1 2 ...]\n"
+  (binding [*print-length* 6] (with-out-str (pprint [1 2 3 4 5 6])))
+  "[1 2 3 4 5 6]\n"
+  (binding [*print-length* 8] (with-out-str (pprint [1 2 3 4 5 6])))
+  "[1 2 3 4 5 6]\n"
+
+  ;; This set of tests isn't that great cause it assumes that the set remains
+  ;; ordered for printing. This is currently (1.3) true, but no future
+  ;; guarantees
+  (binding [*print-length* 1] (with-out-str (pprint #{1 2 3 4 5 6})))
+  "#{1 ...}\n"
+  (binding [*print-length* 2] (with-out-str (pprint #{1 2 3 4 5 6})))
+  "#{1 2 ...}\n"
+  (binding [*print-length* 6] (with-out-str (pprint #{1 2 3 4 5 6})))
+  "#{1 2 3 4 5 6}\n"
+  (binding [*print-length* 8] (with-out-str (pprint #{1 2 3 4 5 6})))
+  "#{1 2 3 4 5 6}\n"
+
+  ;; See above comment and apply to this map :)
+  (binding [*print-length* 1] (with-out-str (pprint {1 2, 3 4, 5 6, 7 8, 9 10, 11 12})))
+  "{1 2, ...}\n"
+  (binding [*print-length* 2] (with-out-str (pprint {1 2, 3 4, 5 6, 7 8, 9 10, 11 12})))
+  "{1 2, 3 4, ...}\n"
+  (binding [*print-length* 6] (with-out-str (pprint {1 2, 3 4, 5 6, 7 8, 9 10, 11 12})))
+  "{1 2, 3 4, 5 6, 7 8, 9 10, 11 12}\n"
+  (binding [*print-length* 8] (with-out-str (pprint {1 2, 3 4, 5 6, 7 8, 9 10, 11 12})))
+  "{1 2, 3 4, 5 6, 7 8, 9 10, 11 12}\n"
+
+
+  (binding [*print-length* 1] (with-out-str (pprint (int-array [1 2 3 4 5 6]))))
+  "[1, ...]\n"
+  (binding [*print-length* 2] (with-out-str (pprint (int-array [1 2 3 4 5 6]))))
+  "[1, 2, ...]\n"
+  (binding [*print-length* 6] (with-out-str (pprint (int-array [1 2 3 4 5 6]))))
+  "[1, 2, 3, 4, 5, 6]\n"
+  (binding [*print-length* 8] (with-out-str (pprint (int-array [1 2 3 4 5 6]))))
+  "[1, 2, 3, 4, 5, 6]\n"
+  )