From ba2c1a41fff8b9d2e139156f4a3ed2b17b0e9214 Mon Sep 17 00:00:00 2001 From: Tom Faulhaber Date: Wed, 22 Dec 2010 01:06:28 -0800 Subject: [PATCH] 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. --- src/clj/clojure/pprint.clj | 3 +- src/clj/clojure/pprint/dispatch.clj | 15 +++--- src/clj/clojure/pprint/pprint_base.clj | 29 ++++++++++++ test/clojure/test_clojure/pprint/test_pretty.clj | 51 ++++++++++++++++++++++ 4 files changed, 90 insertions(+), 8 deletions(-) diff --git a/src/clj/clojure/pprint.clj b/src/clj/clojure/pprint.clj index 846a5f3..ba90aa6 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 a6ae293..19ba983 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 4be9ac5..ea035d4 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 ebbb29a..77af6c5 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" + ) -- 1.7.0.4