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