Mercurial > lasercutter
comparison src/clojure/pprint/dispatch.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 ;; dispatch.clj -- part of the pretty printer for Clojure | |
2 | |
3 ; Copyright (c) Rich Hickey. All rights reserved. | |
4 ; The use and distribution terms for this software are covered by the | |
5 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
6 ; which can be found in the file epl-v10.html at the root of this distribution. | |
7 ; By using this software in any fashion, you are agreeing to be bound by | |
8 ; the terms of this license. | |
9 ; You must not remove this notice, or any other, from this software. | |
10 | |
11 ;; Author: Tom Faulhaber | |
12 ;; April 3, 2009 | |
13 | |
14 | |
15 ;; This module implements the default dispatch tables for pretty printing code and | |
16 ;; data. | |
17 | |
18 (in-ns 'clojure.pprint) | |
19 | |
20 (defn- use-method | |
21 "Installs a function as a new method of multimethod associated with dispatch-value. " | |
22 [multifn dispatch-val func] | |
23 (. multifn addMethod dispatch-val func)) | |
24 | |
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
26 ;; Implementations of specific dispatch table entries | |
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
28 | |
29 ;;; Handle forms that can be "back-translated" to reader macros | |
30 ;;; Not all reader macros can be dealt with this way or at all. | |
31 ;;; Macros that we can't deal with at all are: | |
32 ;;; ; - The comment character is aborbed by the reader and never is part of the form | |
33 ;;; ` - Is fully processed at read time into a lisp expression (which will contain concats | |
34 ;;; and regular quotes). | |
35 ;;; ~@ - Also fully eaten by the processing of ` and can't be used outside. | |
36 ;;; , - is whitespace and is lost (like all other whitespace). Formats can generate commas | |
37 ;;; where they deem them useful to help readability. | |
38 ;;; ^ - Adding metadata completely disappears at read time and the data appears to be | |
39 ;;; completely lost. | |
40 ;;; | |
41 ;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{}) | |
42 ;;; or directly by printing the objects using Clojure's built-in print functions (like | |
43 ;;; :keyword, \char, or ""). The notable exception is #() which is special-cased. | |
44 | |
45 (def ^{:private true} reader-macros | |
46 {'quote "'", 'clojure.core/deref "@", | |
47 'var "#'", 'clojure.core/unquote "~"}) | |
48 | |
49 (defn- pprint-reader-macro [alis] | |
50 (let [^String macro-char (reader-macros (first alis))] | |
51 (when (and macro-char (= 2 (count alis))) | |
52 (.write ^java.io.Writer *out* macro-char) | |
53 (write-out (second alis)) | |
54 true))) | |
55 | |
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
57 ;; Dispatch for the basic data types when interpreted | |
58 ;; as data (as opposed to code). | |
59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
60 | |
61 ;;; TODO: inline these formatter statements into funcs so that we | |
62 ;;; are a little easier on the stack. (Or, do "real" compilation, a | |
63 ;;; la Common Lisp) | |
64 | |
65 ;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>")) | |
66 (defn- pprint-simple-list [alis] | |
67 (pprint-logical-block :prefix "(" :suffix ")" | |
68 (loop [alis (seq alis)] | |
69 (when alis | |
70 (write-out (first alis)) | |
71 (when (next alis) | |
72 (.write ^java.io.Writer *out* " ") | |
73 (pprint-newline :linear) | |
74 (recur (next alis))))))) | |
75 | |
76 (defn- pprint-list [alis] | |
77 (if-not (pprint-reader-macro alis) | |
78 (pprint-simple-list alis))) | |
79 | |
80 ;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>")) | |
81 (defn- pprint-vector [avec] | |
82 (pprint-logical-block :prefix "[" :suffix "]" | |
83 (loop [aseq (seq avec)] | |
84 (when aseq | |
85 (write-out (first aseq)) | |
86 (when (next aseq) | |
87 (.write ^java.io.Writer *out* " ") | |
88 (pprint-newline :linear) | |
89 (recur (next aseq))))))) | |
90 | |
91 (def ^{:private true} pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>")) | |
92 | |
93 ;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>")) | |
94 (defn- pprint-map [amap] | |
95 (pprint-logical-block :prefix "{" :suffix "}" | |
96 (loop [aseq (seq amap)] | |
97 (when aseq | |
98 (pprint-logical-block | |
99 (write-out (ffirst aseq)) | |
100 (.write ^java.io.Writer *out* " ") | |
101 (pprint-newline :linear) | |
102 (write-out (fnext (first aseq)))) | |
103 (when (next aseq) | |
104 (.write ^java.io.Writer *out* ", ") | |
105 (pprint-newline :linear) | |
106 (recur (next aseq))))))) | |
107 | |
108 (def ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>")) | |
109 | |
110 ;;; TODO: don't block on promise (currently impossible) | |
111 | |
112 (def ^{:private true} | |
113 type-map {"core$future_call" "Future", | |
114 "core$promise" "Promise"}) | |
115 | |
116 (defn- map-ref-type | |
117 "Map ugly type names to something simpler" | |
118 [name] | |
119 (or (when-let [match (re-find #"^[^$]+\$[^$]+" name)] | |
120 (type-map match)) | |
121 name)) | |
122 | |
123 (defn- pprint-ideref [o] | |
124 (let [prefix (format "#<%s@%x%s: " | |
125 (map-ref-type (.getSimpleName (class o))) | |
126 (System/identityHashCode o) | |
127 (if (and (instance? clojure.lang.Agent o) | |
128 (agent-error o)) | |
129 " FAILED" | |
130 ""))] | |
131 (pprint-logical-block :prefix prefix :suffix ">" | |
132 (pprint-indent :block (-> (count prefix) (- 2) -)) | |
133 (pprint-newline :linear) | |
134 (write-out (cond | |
135 (and (future? o) (not (future-done? o))) :pending | |
136 :else @o))))) | |
137 | |
138 (def ^{:private true} pprint-pqueue (formatter-out "~<<-(~;~@{~w~^ ~_~}~;)-<~:>")) | |
139 | |
140 (defn- pprint-simple-default [obj] | |
141 (cond | |
142 (.isArray (class obj)) (pprint-array obj) | |
143 (and *print-suppress-namespaces* (symbol? obj)) (print (name obj)) | |
144 :else (pr obj))) | |
145 | |
146 | |
147 (defmulti | |
148 simple-dispatch | |
149 "The pretty print dispatch function for simple data structure format." | |
150 {:added "1.2" :arglists '[[object]]} | |
151 class) | |
152 | |
153 (use-method simple-dispatch clojure.lang.ISeq pprint-list) | |
154 (use-method simple-dispatch clojure.lang.IPersistentVector pprint-vector) | |
155 (use-method simple-dispatch clojure.lang.IPersistentMap pprint-map) | |
156 (use-method simple-dispatch clojure.lang.IPersistentSet pprint-set) | |
157 (use-method simple-dispatch clojure.lang.PersistentQueue pprint-pqueue) | |
158 (use-method simple-dispatch clojure.lang.IDeref pprint-ideref) | |
159 (use-method simple-dispatch nil pr) | |
160 (use-method simple-dispatch :default pprint-simple-default) | |
161 | |
162 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
163 ;;; Dispatch for the code table | |
164 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
165 | |
166 (declare pprint-simple-code-list) | |
167 | |
168 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
169 ;;; Format something that looks like a simple def (sans metadata, since the reader | |
170 ;;; won't give it to us now). | |
171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
172 | |
173 (def ^{:private true} pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>")) | |
174 | |
175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
176 ;;; Format something that looks like a defn or defmacro | |
177 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
178 | |
179 ;;; Format the params and body of a defn with a single arity | |
180 (defn- single-defn [alis has-doc-str?] | |
181 (if (seq alis) | |
182 (do | |
183 (if has-doc-str? | |
184 ((formatter-out " ~_")) | |
185 ((formatter-out " ~@_"))) | |
186 ((formatter-out "~{~w~^ ~_~}") alis)))) | |
187 | |
188 ;;; Format the param and body sublists of a defn with multiple arities | |
189 (defn- multi-defn [alis has-doc-str?] | |
190 (if (seq alis) | |
191 ((formatter-out " ~_~{~w~^ ~_~}") alis))) | |
192 | |
193 ;;; TODO: figure out how to support capturing metadata in defns (we might need a | |
194 ;;; special reader) | |
195 (defn- pprint-defn [alis] | |
196 (if (next alis) | |
197 (let [[defn-sym defn-name & stuff] alis | |
198 [doc-str stuff] (if (string? (first stuff)) | |
199 [(first stuff) (next stuff)] | |
200 [nil stuff]) | |
201 [attr-map stuff] (if (map? (first stuff)) | |
202 [(first stuff) (next stuff)] | |
203 [nil stuff])] | |
204 (pprint-logical-block :prefix "(" :suffix ")" | |
205 ((formatter-out "~w ~1I~@_~w") defn-sym defn-name) | |
206 (if doc-str | |
207 ((formatter-out " ~_~w") doc-str)) | |
208 (if attr-map | |
209 ((formatter-out " ~_~w") attr-map)) | |
210 ;; Note: the multi-defn case will work OK for malformed defns too | |
211 (cond | |
212 (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) | |
213 :else (multi-defn stuff (or doc-str attr-map))))) | |
214 (pprint-simple-code-list alis))) | |
215 | |
216 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
217 ;;; Format something with a binding form | |
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
219 | |
220 (defn- pprint-binding-form [binding-vec] | |
221 (pprint-logical-block :prefix "[" :suffix "]" | |
222 (loop [binding binding-vec] | |
223 (when (seq binding) | |
224 (pprint-logical-block binding | |
225 (write-out (first binding)) | |
226 (when (next binding) | |
227 (.write ^java.io.Writer *out* " ") | |
228 (pprint-newline :miser) | |
229 (write-out (second binding)))) | |
230 (when (next (rest binding)) | |
231 (.write ^java.io.Writer *out* " ") | |
232 (pprint-newline :linear) | |
233 (recur (next (rest binding)))))))) | |
234 | |
235 (defn- pprint-let [alis] | |
236 (let [base-sym (first alis)] | |
237 (pprint-logical-block :prefix "(" :suffix ")" | |
238 (if (and (next alis) (vector? (second alis))) | |
239 (do | |
240 ((formatter-out "~w ~1I~@_") base-sym) | |
241 (pprint-binding-form (second alis)) | |
242 ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis)))) | |
243 (pprint-simple-code-list alis))))) | |
244 | |
245 | |
246 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
247 ;;; Format something that looks like "if" | |
248 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
249 | |
250 (def ^{:private true} pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>")) | |
251 | |
252 (defn- pprint-cond [alis] | |
253 (pprint-logical-block :prefix "(" :suffix ")" | |
254 (pprint-indent :block 1) | |
255 (write-out (first alis)) | |
256 (when (next alis) | |
257 (.write ^java.io.Writer *out* " ") | |
258 (pprint-newline :linear) | |
259 (loop [alis (next alis)] | |
260 (when alis | |
261 (pprint-logical-block alis | |
262 (write-out (first alis)) | |
263 (when (next alis) | |
264 (.write ^java.io.Writer *out* " ") | |
265 (pprint-newline :miser) | |
266 (write-out (second alis)))) | |
267 (when (next (rest alis)) | |
268 (.write ^java.io.Writer *out* " ") | |
269 (pprint-newline :linear) | |
270 (recur (next (rest alis))))))))) | |
271 | |
272 (defn- pprint-condp [alis] | |
273 (if (> (count alis) 3) | |
274 (pprint-logical-block :prefix "(" :suffix ")" | |
275 (pprint-indent :block 1) | |
276 (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis) | |
277 (loop [alis (seq (drop 3 alis))] | |
278 (when alis | |
279 (pprint-logical-block alis | |
280 (write-out (first alis)) | |
281 (when (next alis) | |
282 (.write ^java.io.Writer *out* " ") | |
283 (pprint-newline :miser) | |
284 (write-out (second alis)))) | |
285 (when (next (rest alis)) | |
286 (.write ^java.io.Writer *out* " ") | |
287 (pprint-newline :linear) | |
288 (recur (next (rest alis))))))) | |
289 (pprint-simple-code-list alis))) | |
290 | |
291 ;;; The map of symbols that are defined in an enclosing #() anonymous function | |
292 (def ^{:private true} *symbol-map* {}) | |
293 | |
294 (defn- pprint-anon-func [alis] | |
295 (let [args (second alis) | |
296 nlis (first (rest (rest alis)))] | |
297 (if (vector? args) | |
298 (binding [*symbol-map* (if (= 1 (count args)) | |
299 {(first args) "%"} | |
300 (into {} | |
301 (map | |
302 #(vector %1 (str \% %2)) | |
303 args | |
304 (range 1 (inc (count args))))))] | |
305 ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis)) | |
306 (pprint-simple-code-list alis)))) | |
307 | |
308 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
309 ;;; The master definitions for formatting lists in code (that is, (fn args...) or | |
310 ;;; special forms). | |
311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
312 | |
313 ;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is | |
314 ;;; easier on the stack. | |
315 | |
316 (defn- pprint-simple-code-list [alis] | |
317 (pprint-logical-block :prefix "(" :suffix ")" | |
318 (pprint-indent :block 1) | |
319 (loop [alis (seq alis)] | |
320 (when alis | |
321 (write-out (first alis)) | |
322 (when (next alis) | |
323 (.write ^java.io.Writer *out* " ") | |
324 (pprint-newline :linear) | |
325 (recur (next alis))))))) | |
326 | |
327 ;;; Take a map with symbols as keys and add versions with no namespace. | |
328 ;;; That is, if ns/sym->val is in the map, add sym->val to the result. | |
329 (defn- two-forms [amap] | |
330 (into {} | |
331 (mapcat | |
332 identity | |
333 (for [x amap] | |
334 [x [(symbol (name (first x))) (second x)]])))) | |
335 | |
336 (defn- add-core-ns [amap] | |
337 (let [core "clojure.core"] | |
338 (into {} | |
339 (map #(let [[s f] %] | |
340 (if (not (or (namespace s) (special-symbol? s))) | |
341 [(symbol core (name s)) f] | |
342 %)) | |
343 amap)))) | |
344 | |
345 (def ^{:private true} *code-table* | |
346 (two-forms | |
347 (add-core-ns | |
348 {'def pprint-hold-first, 'defonce pprint-hold-first, | |
349 'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn, | |
350 'let pprint-let, 'loop pprint-let, 'binding pprint-let, | |
351 'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let, | |
352 'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let, | |
353 'when-first pprint-let, | |
354 'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if, | |
355 'cond pprint-cond, 'condp pprint-condp, | |
356 'fn* pprint-anon-func, | |
357 '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first, | |
358 'locking pprint-hold-first, 'struct pprint-hold-first, | |
359 'struct-map pprint-hold-first, | |
360 }))) | |
361 | |
362 (defn- pprint-code-list [alis] | |
363 (if-not (pprint-reader-macro alis) | |
364 (if-let [special-form (*code-table* (first alis))] | |
365 (special-form alis) | |
366 (pprint-simple-code-list alis)))) | |
367 | |
368 (defn- pprint-code-symbol [sym] | |
369 (if-let [arg-num (sym *symbol-map*)] | |
370 (print arg-num) | |
371 (if *print-suppress-namespaces* | |
372 (print (name sym)) | |
373 (pr sym)))) | |
374 | |
375 (defmulti | |
376 code-dispatch | |
377 "The pretty print dispatch function for pretty printing Clojure code." | |
378 {:added "1.2" :arglists '[[object]]} | |
379 class) | |
380 | |
381 (use-method code-dispatch clojure.lang.ISeq pprint-code-list) | |
382 (use-method code-dispatch clojure.lang.Symbol pprint-code-symbol) | |
383 | |
384 ;; The following are all exact copies of simple-dispatch | |
385 (use-method code-dispatch clojure.lang.IPersistentVector pprint-vector) | |
386 (use-method code-dispatch clojure.lang.IPersistentMap pprint-map) | |
387 (use-method code-dispatch clojure.lang.IPersistentSet pprint-set) | |
388 (use-method code-dispatch clojure.lang.PersistentQueue pprint-pqueue) | |
389 (use-method code-dispatch clojure.lang.IDeref pprint-ideref) | |
390 (use-method code-dispatch nil pr) | |
391 (use-method code-dispatch :default pprint-simple-default) | |
392 | |
393 (set-pprint-dispatch simple-dispatch) | |
394 | |
395 | |
396 ;;; For testing | |
397 (comment | |
398 | |
399 (with-pprint-dispatch code-dispatch | |
400 (pprint | |
401 '(defn cl-format | |
402 "An implementation of a Common Lisp compatible format function" | |
403 [stream format-in & args] | |
404 (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) | |
405 navigator (init-navigator args)] | |
406 (execute-format stream compiled-format navigator))))) | |
407 | |
408 (with-pprint-dispatch code-dispatch | |
409 (pprint | |
410 '(defn cl-format | |
411 [stream format-in & args] | |
412 (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) | |
413 navigator (init-navigator args)] | |
414 (execute-format stream compiled-format navigator))))) | |
415 | |
416 (with-pprint-dispatch code-dispatch | |
417 (pprint | |
418 '(defn- -write | |
419 ([this x] | |
420 (condp = (class x) | |
421 String | |
422 (let [s0 (write-initial-lines this x) | |
423 s (.replaceFirst s0 "\\s+$" "") | |
424 white-space (.substring s0 (count s)) | |
425 mode (getf :mode)] | |
426 (if (= mode :writing) | |
427 (dosync | |
428 (write-white-space this) | |
429 (.col_write this s) | |
430 (setf :trailing-white-space white-space)) | |
431 (add-to-buffer this (make-buffer-blob s white-space)))) | |
432 | |
433 Integer | |
434 (let [c ^Character x] | |
435 (if (= (getf :mode) :writing) | |
436 (do | |
437 (write-white-space this) | |
438 (.col_write this x)) | |
439 (if (= c (int \newline)) | |
440 (write-initial-lines this "\n") | |
441 (add-to-buffer this (make-buffer-blob (str (char c)) nil)))))))))) | |
442 | |
443 (with-pprint-dispatch code-dispatch | |
444 (pprint | |
445 '(defn pprint-defn [writer alis] | |
446 (if (next alis) | |
447 (let [[defn-sym defn-name & stuff] alis | |
448 [doc-str stuff] (if (string? (first stuff)) | |
449 [(first stuff) (next stuff)] | |
450 [nil stuff]) | |
451 [attr-map stuff] (if (map? (first stuff)) | |
452 [(first stuff) (next stuff)] | |
453 [nil stuff])] | |
454 (pprint-logical-block writer :prefix "(" :suffix ")" | |
455 (cl-format true "~w ~1I~@_~w" defn-sym defn-name) | |
456 (if doc-str | |
457 (cl-format true " ~_~w" doc-str)) | |
458 (if attr-map | |
459 (cl-format true " ~_~w" attr-map)) | |
460 ;; Note: the multi-defn case will work OK for malformed defns too | |
461 (cond | |
462 (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) | |
463 :else (multi-defn stuff (or doc-str attr-map))))) | |
464 (pprint-simple-code-list writer alis))))) | |
465 ) | |
466 nil | |
467 |