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