comparison src/clojure/contrib/pprint/pprint_base.clj @ 10:ef7dbbd6452c

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