|
rlm@10
|
1 ;;; pprint_base.clj -- part of the pretty printer for Clojure
|
|
rlm@10
|
2
|
|
rlm@10
|
3 ;; by Tom Faulhaber
|
|
rlm@10
|
4 ;; April 3, 2009
|
|
rlm@10
|
5
|
|
rlm@10
|
6 ; Copyright (c) Tom Faulhaber, Jan 2009. All rights reserved.
|
|
rlm@10
|
7 ; The use and distribution terms for this software are covered by the
|
|
rlm@10
|
8 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
|
|
rlm@10
|
9 ; which can be found in the file epl-v10.html at the root of this distribution.
|
|
rlm@10
|
10 ; By using this software in any fashion, you are agreeing to be bound by
|
|
rlm@10
|
11 ; the terms of this license.
|
|
rlm@10
|
12 ; You must not remove this notice, or any other, from this software.
|
|
rlm@10
|
13
|
|
rlm@10
|
14 ;; This module implements the generic pretty print functions and special variables
|
|
rlm@10
|
15
|
|
rlm@10
|
16 (in-ns 'clojure.contrib.pprint)
|
|
rlm@10
|
17
|
|
rlm@10
|
18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
19 ;; Variables that control the pretty printer
|
|
rlm@10
|
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
21
|
|
rlm@10
|
22 ;;;
|
|
rlm@10
|
23 ;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core
|
|
rlm@10
|
24 ;;; TODO: use *print-dup* here (or is it supplanted by other variables?)
|
|
rlm@10
|
25 ;;; TODO: make dispatch items like "(let..." get counted in *print-length*
|
|
rlm@10
|
26 ;;; constructs
|
|
rlm@10
|
27
|
|
rlm@10
|
28
|
|
rlm@10
|
29 (def
|
|
rlm@10
|
30 ^{ :doc "Bind to true if you want write to use pretty printing"}
|
|
rlm@10
|
31 *print-pretty* true)
|
|
rlm@10
|
32
|
|
rlm@10
|
33 (defonce ; If folks have added stuff here, don't overwrite
|
|
rlm@10
|
34 ^{ :doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch
|
|
rlm@10
|
35 to modify."}
|
|
rlm@10
|
36 *print-pprint-dispatch* nil)
|
|
rlm@10
|
37
|
|
rlm@10
|
38 (def
|
|
rlm@10
|
39 ^{ :doc "Pretty printing will try to avoid anything going beyond this column.
|
|
rlm@10
|
40 Set it to nil to have pprint let the line be arbitrarily long. This will ignore all
|
|
rlm@10
|
41 non-mandatory newlines."}
|
|
rlm@10
|
42 *print-right-margin* 72)
|
|
rlm@10
|
43
|
|
rlm@10
|
44 (def
|
|
rlm@10
|
45 ^{ :doc "The column at which to enter miser style. Depending on the dispatch table,
|
|
rlm@10
|
46 miser style add newlines in more places to try to keep lines short allowing for further
|
|
rlm@10
|
47 levels of nesting."}
|
|
rlm@10
|
48 *print-miser-width* 40)
|
|
rlm@10
|
49
|
|
rlm@10
|
50 ;;; TODO implement output limiting
|
|
rlm@10
|
51 (def
|
|
rlm@10
|
52 ^{ :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"}
|
|
rlm@10
|
53 *print-lines* nil)
|
|
rlm@10
|
54
|
|
rlm@10
|
55 ;;; TODO: implement circle and shared
|
|
rlm@10
|
56 (def
|
|
rlm@10
|
57 ^{ :doc "Mark circular structures (N.B. This is not yet used)"}
|
|
rlm@10
|
58 *print-circle* nil)
|
|
rlm@10
|
59
|
|
rlm@10
|
60 ;;; TODO: should we just use *print-dup* here?
|
|
rlm@10
|
61 (def
|
|
rlm@10
|
62 ^{ :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"}
|
|
rlm@10
|
63 *print-shared* nil)
|
|
rlm@10
|
64
|
|
rlm@10
|
65 (def
|
|
rlm@10
|
66 ^{ :doc "Don't print namespaces with symbols. This is particularly useful when
|
|
rlm@10
|
67 pretty printing the results of macro expansions"}
|
|
rlm@10
|
68 *print-suppress-namespaces* nil)
|
|
rlm@10
|
69
|
|
rlm@10
|
70 ;;; TODO: support print-base and print-radix in cl-format
|
|
rlm@10
|
71 ;;; TODO: support print-base and print-radix in rationals
|
|
rlm@10
|
72 (def
|
|
rlm@10
|
73 ^{ :doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8,
|
|
rlm@10
|
74 or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the
|
|
rlm@10
|
75 radix specifier is in the form #XXr where XX is the decimal value of *print-base* "}
|
|
rlm@10
|
76 *print-radix* nil)
|
|
rlm@10
|
77
|
|
rlm@10
|
78 (def
|
|
rlm@10
|
79 ^{ :doc "The base to use for printing integers and rationals."}
|
|
rlm@10
|
80 *print-base* 10)
|
|
rlm@10
|
81
|
|
rlm@10
|
82
|
|
rlm@10
|
83
|
|
rlm@10
|
84 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
85 ;; Internal variables that keep track of where we are in the
|
|
rlm@10
|
86 ;; structure
|
|
rlm@10
|
87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
88
|
|
rlm@10
|
89 (def ^{ :private true } *current-level* 0)
|
|
rlm@10
|
90
|
|
rlm@10
|
91 (def ^{ :private true } *current-length* nil)
|
|
rlm@10
|
92
|
|
rlm@10
|
93 ;; TODO: add variables for length, lines.
|
|
rlm@10
|
94
|
|
rlm@10
|
95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
96 ;; Support for the write function
|
|
rlm@10
|
97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
98
|
|
rlm@10
|
99 (declare format-simple-number)
|
|
rlm@10
|
100
|
|
rlm@10
|
101 (def ^{:private true} orig-pr pr)
|
|
rlm@10
|
102
|
|
rlm@10
|
103 (defn- pr-with-base [x]
|
|
rlm@10
|
104 (if-let [s (format-simple-number x)]
|
|
rlm@10
|
105 (print s)
|
|
rlm@10
|
106 (orig-pr x)))
|
|
rlm@10
|
107
|
|
rlm@10
|
108 (def ^{:private true} write-option-table
|
|
rlm@10
|
109 {;:array *print-array*
|
|
rlm@10
|
110 :base 'clojure.contrib.pprint/*print-base*,
|
|
rlm@10
|
111 ;;:case *print-case*,
|
|
rlm@10
|
112 :circle 'clojure.contrib.pprint/*print-circle*,
|
|
rlm@10
|
113 ;;:escape *print-escape*,
|
|
rlm@10
|
114 ;;:gensym *print-gensym*,
|
|
rlm@10
|
115 :length 'clojure.core/*print-length*,
|
|
rlm@10
|
116 :level 'clojure.core/*print-level*,
|
|
rlm@10
|
117 :lines 'clojure.contrib.pprint/*print-lines*,
|
|
rlm@10
|
118 :miser-width 'clojure.contrib.pprint/*print-miser-width*,
|
|
rlm@10
|
119 :dispatch 'clojure.contrib.pprint/*print-pprint-dispatch*,
|
|
rlm@10
|
120 :pretty 'clojure.contrib.pprint/*print-pretty*,
|
|
rlm@10
|
121 :radix 'clojure.contrib.pprint/*print-radix*,
|
|
rlm@10
|
122 :readably 'clojure.core/*print-readably*,
|
|
rlm@10
|
123 :right-margin 'clojure.contrib.pprint/*print-right-margin*,
|
|
rlm@10
|
124 :suppress-namespaces 'clojure.contrib.pprint/*print-suppress-namespaces*})
|
|
rlm@10
|
125
|
|
rlm@10
|
126
|
|
rlm@10
|
127 (defmacro ^{:private true} binding-map [amap & body]
|
|
rlm@10
|
128 (let []
|
|
rlm@10
|
129 `(do
|
|
rlm@10
|
130 (. clojure.lang.Var (pushThreadBindings ~amap))
|
|
rlm@10
|
131 (try
|
|
rlm@10
|
132 ~@body
|
|
rlm@10
|
133 (finally
|
|
rlm@10
|
134 (. clojure.lang.Var (popThreadBindings)))))))
|
|
rlm@10
|
135
|
|
rlm@10
|
136 (defn- table-ize [t m]
|
|
rlm@10
|
137 (apply hash-map (mapcat
|
|
rlm@10
|
138 #(when-let [v (get t (key %))] [(find-var v) (val %)])
|
|
rlm@10
|
139 m)))
|
|
rlm@10
|
140
|
|
rlm@10
|
141 (defn- pretty-writer?
|
|
rlm@10
|
142 "Return true iff x is a PrettyWriter"
|
|
rlm@10
|
143 [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x)))
|
|
rlm@10
|
144
|
|
rlm@10
|
145 (defn- make-pretty-writer
|
|
rlm@10
|
146 "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width"
|
|
rlm@10
|
147 [base-writer right-margin miser-width]
|
|
rlm@10
|
148 (pretty-writer base-writer right-margin miser-width))
|
|
rlm@10
|
149
|
|
rlm@10
|
150 (defmacro ^{:private true} with-pretty-writer [base-writer & body]
|
|
rlm@10
|
151 `(let [base-writer# ~base-writer
|
|
rlm@10
|
152 new-writer# (not (pretty-writer? base-writer#))]
|
|
rlm@10
|
153 (binding [*out* (if new-writer#
|
|
rlm@10
|
154 (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*)
|
|
rlm@10
|
155 base-writer#)]
|
|
rlm@10
|
156 ~@body
|
|
rlm@10
|
157 (.flush *out*))))
|
|
rlm@10
|
158
|
|
rlm@10
|
159
|
|
rlm@10
|
160 ;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc.
|
|
rlm@10
|
161 (defn write-out
|
|
rlm@10
|
162 "Write an object to *out* subject to the current bindings of the printer control
|
|
rlm@10
|
163 variables. Use the kw-args argument to override individual variables for this call (and
|
|
rlm@10
|
164 any recursive calls).
|
|
rlm@10
|
165
|
|
rlm@10
|
166 *out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility
|
|
rlm@10
|
167 of the caller.
|
|
rlm@10
|
168
|
|
rlm@10
|
169 This method is primarily intended for use by pretty print dispatch functions that
|
|
rlm@10
|
170 already know that the pretty printer will have set up their environment appropriately.
|
|
rlm@10
|
171 Normal library clients should use the standard \"write\" interface. "
|
|
rlm@10
|
172 [object]
|
|
rlm@10
|
173 (let [length-reached (and
|
|
rlm@10
|
174 *current-length*
|
|
rlm@10
|
175 *print-length*
|
|
rlm@10
|
176 (>= *current-length* *print-length*))]
|
|
rlm@10
|
177 (if-not *print-pretty*
|
|
rlm@10
|
178 (pr object)
|
|
rlm@10
|
179 (if length-reached
|
|
rlm@10
|
180 (print "...")
|
|
rlm@10
|
181 (do
|
|
rlm@10
|
182 (if *current-length* (set! *current-length* (inc *current-length*)))
|
|
rlm@10
|
183 (*print-pprint-dispatch* object))))
|
|
rlm@10
|
184 length-reached))
|
|
rlm@10
|
185
|
|
rlm@10
|
186 (defn write
|
|
rlm@10
|
187 "Write an object subject to the current bindings of the printer control variables.
|
|
rlm@10
|
188 Use the kw-args argument to override individual variables for this call (and any
|
|
rlm@10
|
189 recursive calls). Returns the string result if :stream is nil or nil otherwise.
|
|
rlm@10
|
190
|
|
rlm@10
|
191 The following keyword arguments can be passed with values:
|
|
rlm@10
|
192 Keyword Meaning Default value
|
|
rlm@10
|
193 :stream Writer for output or nil true (indicates *out*)
|
|
rlm@10
|
194 :base Base to use for writing rationals Current value of *print-base*
|
|
rlm@10
|
195 :circle* If true, mark circular structures Current value of *print-circle*
|
|
rlm@10
|
196 :length Maximum elements to show in sublists Current value of *print-length*
|
|
rlm@10
|
197 :level Maximum depth Current value of *print-level*
|
|
rlm@10
|
198 :lines* Maximum lines of output Current value of *print-lines*
|
|
rlm@10
|
199 :miser-width Width to enter miser mode Current value of *print-miser-width*
|
|
rlm@10
|
200 :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch*
|
|
rlm@10
|
201 :pretty If true, do pretty printing Current value of *print-pretty*
|
|
rlm@10
|
202 :radix If true, prepend a radix specifier Current value of *print-radix*
|
|
rlm@10
|
203 :readably* If true, print readably Current value of *print-readably*
|
|
rlm@10
|
204 :right-margin The column for the right margin Current value of *print-right-margin*
|
|
rlm@10
|
205 :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces*
|
|
rlm@10
|
206
|
|
rlm@10
|
207 * = not yet supported
|
|
rlm@10
|
208 "
|
|
rlm@10
|
209 [object & kw-args]
|
|
rlm@10
|
210 (let [options (merge {:stream true} (apply hash-map kw-args))]
|
|
rlm@10
|
211 (binding-map (table-ize write-option-table options)
|
|
rlm@10
|
212 (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {})
|
|
rlm@10
|
213 (let [optval (if (contains? options :stream)
|
|
rlm@10
|
214 (:stream options)
|
|
rlm@10
|
215 true)
|
|
rlm@10
|
216 base-writer (condp = optval
|
|
rlm@10
|
217 nil (java.io.StringWriter.)
|
|
rlm@10
|
218 true *out*
|
|
rlm@10
|
219 optval)]
|
|
rlm@10
|
220 (if *print-pretty*
|
|
rlm@10
|
221 (with-pretty-writer base-writer
|
|
rlm@10
|
222 (write-out object))
|
|
rlm@10
|
223 (binding [*out* base-writer]
|
|
rlm@10
|
224 (pr object)))
|
|
rlm@10
|
225 (if (nil? optval)
|
|
rlm@10
|
226 (.toString ^java.io.StringWriter base-writer)))))))
|
|
rlm@10
|
227
|
|
rlm@10
|
228
|
|
rlm@10
|
229 (defn pprint
|
|
rlm@10
|
230 "Pretty print object to the optional output writer. If the writer is not provided,
|
|
rlm@10
|
231 print the object to the currently bound value of *out*."
|
|
rlm@10
|
232 ([object] (pprint object *out*))
|
|
rlm@10
|
233 ([object writer]
|
|
rlm@10
|
234 (with-pretty-writer writer
|
|
rlm@10
|
235 (binding [*print-pretty* true]
|
|
rlm@10
|
236 (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {})
|
|
rlm@10
|
237 (write-out object)))
|
|
rlm@10
|
238 (if (not (= 0 (get-column *out*)))
|
|
rlm@10
|
239 (.write *out* (int \newline))))))
|
|
rlm@10
|
240
|
|
rlm@10
|
241 (defmacro pp
|
|
rlm@10
|
242 "A convenience macro that pretty prints the last thing output. This is
|
|
rlm@10
|
243 exactly equivalent to (pprint *1)."
|
|
rlm@10
|
244 [] `(pprint *1))
|
|
rlm@10
|
245
|
|
rlm@10
|
246 (defn set-pprint-dispatch
|
|
rlm@10
|
247 "Set the pretty print dispatch function to a function matching (fn [obj] ...)
|
|
rlm@10
|
248 where obj is the object to pretty print. That function will be called with *out* set
|
|
rlm@10
|
249 to a pretty printing writer to which it should do its printing.
|
|
rlm@10
|
250
|
|
rlm@10
|
251 For example functions, see *simple-dispatch* and *code-dispatch* in
|
|
rlm@10
|
252 clojure.contrib.pprint.dispatch.clj."
|
|
rlm@10
|
253 [function]
|
|
rlm@10
|
254 (let [old-meta (meta #'*print-pprint-dispatch*)]
|
|
rlm@10
|
255 (alter-var-root #'*print-pprint-dispatch* (constantly function))
|
|
rlm@10
|
256 (alter-meta! #'*print-pprint-dispatch* (constantly old-meta)))
|
|
rlm@10
|
257 nil)
|
|
rlm@10
|
258
|
|
rlm@10
|
259 (defmacro with-pprint-dispatch
|
|
rlm@10
|
260 "Execute body with the pretty print dispatch function bound to function."
|
|
rlm@10
|
261 [function & body]
|
|
rlm@10
|
262 `(binding [*print-pprint-dispatch* ~function]
|
|
rlm@10
|
263 ~@body))
|
|
rlm@10
|
264
|
|
rlm@10
|
265 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
266 ;; Support for the functional interface to the pretty printer
|
|
rlm@10
|
267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
268
|
|
rlm@10
|
269 (defn- parse-lb-options [opts body]
|
|
rlm@10
|
270 (loop [body body
|
|
rlm@10
|
271 acc []]
|
|
rlm@10
|
272 (if (opts (first body))
|
|
rlm@10
|
273 (recur (drop 2 body) (concat acc (take 2 body)))
|
|
rlm@10
|
274 [(apply hash-map acc) body])))
|
|
rlm@10
|
275
|
|
rlm@10
|
276 (defn- check-enumerated-arg [arg choices]
|
|
rlm@10
|
277 (if-not (choices arg)
|
|
rlm@10
|
278 (throw
|
|
rlm@10
|
279 (IllegalArgumentException.
|
|
rlm@10
|
280 ;; TODO clean up choices string
|
|
rlm@10
|
281 (str "Bad argument: " arg ". It must be one of " choices)))))
|
|
rlm@10
|
282
|
|
rlm@10
|
283 (defn level-exceeded []
|
|
rlm@10
|
284 (and *print-level* (>= *current-level* *print-level*)))
|
|
rlm@10
|
285
|
|
rlm@10
|
286 (defmacro pprint-logical-block
|
|
rlm@10
|
287 "Execute the body as a pretty printing logical block with output to *out* which
|
|
rlm@10
|
288 must be a pretty printing writer. When used from pprint or cl-format, this can be
|
|
rlm@10
|
289 assumed.
|
|
rlm@10
|
290
|
|
rlm@10
|
291 Before the body, the caller can optionally specify options: :prefix, :per-line-prefix,
|
|
rlm@10
|
292 and :suffix."
|
|
rlm@10
|
293 {:arglists '[[options* body]]}
|
|
rlm@10
|
294 [& args]
|
|
rlm@10
|
295 (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
|
|
rlm@10
|
296 `(do (if (level-exceeded)
|
|
rlm@10
|
297 (.write ^java.io.Writer *out* "#")
|
|
rlm@10
|
298 (binding [*current-level* (inc *current-level*)
|
|
rlm@10
|
299 *current-length* 0]
|
|
rlm@10
|
300 (start-block *out*
|
|
rlm@10
|
301 ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))
|
|
rlm@10
|
302 ~@body
|
|
rlm@10
|
303 (end-block *out*)))
|
|
rlm@10
|
304 nil)))
|
|
rlm@10
|
305
|
|
rlm@10
|
306 (defn pprint-newline
|
|
rlm@10
|
307 "Print a conditional newline to a pretty printing stream. kind specifies if the
|
|
rlm@10
|
308 newline is :linear, :miser, :fill, or :mandatory.
|
|
rlm@10
|
309
|
|
rlm@10
|
310 Output is sent to *out* which must be a pretty printing writer."
|
|
rlm@10
|
311 [kind]
|
|
rlm@10
|
312 (check-enumerated-arg kind #{:linear :miser :fill :mandatory})
|
|
rlm@10
|
313 (nl *out* kind))
|
|
rlm@10
|
314
|
|
rlm@10
|
315 (defn pprint-indent
|
|
rlm@10
|
316 "Create an indent at this point in the pretty printing stream. This defines how
|
|
rlm@10
|
317 following lines are indented. relative-to can be either :block or :current depending
|
|
rlm@10
|
318 whether the indent should be computed relative to the start of the logical block or
|
|
rlm@10
|
319 the current column position. n is an offset.
|
|
rlm@10
|
320
|
|
rlm@10
|
321 Output is sent to *out* which must be a pretty printing writer."
|
|
rlm@10
|
322 [relative-to n]
|
|
rlm@10
|
323 (check-enumerated-arg relative-to #{:block :current})
|
|
rlm@10
|
324 (indent *out* relative-to n))
|
|
rlm@10
|
325
|
|
rlm@10
|
326 ;; TODO a real implementation for pprint-tab
|
|
rlm@10
|
327 (defn pprint-tab
|
|
rlm@10
|
328 "Tab at this point in the pretty printing stream. kind specifies whether the tab
|
|
rlm@10
|
329 is :line, :section, :line-relative, or :section-relative.
|
|
rlm@10
|
330
|
|
rlm@10
|
331 Colnum and colinc specify the target column and the increment to move the target
|
|
rlm@10
|
332 forward if the output is already past the original target.
|
|
rlm@10
|
333
|
|
rlm@10
|
334 Output is sent to *out* which must be a pretty printing writer.
|
|
rlm@10
|
335
|
|
rlm@10
|
336 THIS FUNCTION IS NOT YET IMPLEMENTED."
|
|
rlm@10
|
337 [kind colnum colinc]
|
|
rlm@10
|
338 (check-enumerated-arg kind #{:line :section :line-relative :section-relative})
|
|
rlm@10
|
339 (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))
|
|
rlm@10
|
340
|
|
rlm@10
|
341
|
|
rlm@10
|
342 nil
|
