Mercurial > lasercutter
comparison src/clojure/pprint/pretty_writer.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 ;;; pretty_writer.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 ;; Revised to use proxy instead of gen-class April 2010 | |
14 | |
15 ;; This module implements a wrapper around a java.io.Writer which implements the | |
16 ;; core of the XP algorithm. | |
17 | |
18 (in-ns 'clojure.pprint) | |
19 | |
20 (import [clojure.lang IDeref] | |
21 [java.io Writer]) | |
22 | |
23 ;; TODO: Support for tab directives | |
24 | |
25 | |
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
27 ;;; Forward declarations | |
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
29 | |
30 (declare get-miser-width) | |
31 | |
32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
33 ;;; Macros to simplify dealing with types and classes. These are | |
34 ;;; really utilities, but I'm experimenting with them here. | |
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
36 | |
37 (defmacro ^{:private true} | |
38 getf | |
39 "Get the value of the field a named by the argument (which should be a keyword)." | |
40 [sym] | |
41 `(~sym @@~'this)) | |
42 | |
43 (defmacro ^{:private true} | |
44 setf [sym new-val] | |
45 "Set the value of the field SYM to NEW-VAL" | |
46 `(alter @~'this assoc ~sym ~new-val)) | |
47 | |
48 (defmacro ^{:private true} | |
49 deftype [type-name & fields] | |
50 (let [name-str (name type-name)] | |
51 `(do | |
52 (defstruct ~type-name :type-tag ~@fields) | |
53 (alter-meta! #'~type-name assoc :private true) | |
54 (defn- ~(symbol (str "make-" name-str)) | |
55 [& vals#] (apply struct ~type-name ~(keyword name-str) vals#)) | |
56 (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str)))))) | |
57 | |
58 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
59 ;;; The data structures used by pretty-writer | |
60 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
61 | |
62 (defstruct ^{:private true} logical-block | |
63 :parent :section :start-col :indent | |
64 :done-nl :intra-block-nl | |
65 :prefix :per-line-prefix :suffix | |
66 :logical-block-callback) | |
67 | |
68 (defn- ancestor? [parent child] | |
69 (loop [child (:parent child)] | |
70 (cond | |
71 (nil? child) false | |
72 (identical? parent child) true | |
73 :else (recur (:parent child))))) | |
74 | |
75 (defstruct ^{:private true} section :parent) | |
76 | |
77 (defn- buffer-length [l] | |
78 (let [l (seq l)] | |
79 (if l | |
80 (- (:end-pos (last l)) (:start-pos (first l))) | |
81 0))) | |
82 | |
83 ; A blob of characters (aka a string) | |
84 (deftype buffer-blob :data :trailing-white-space :start-pos :end-pos) | |
85 | |
86 ; A newline | |
87 (deftype nl-t :type :logical-block :start-pos :end-pos) | |
88 | |
89 (deftype start-block-t :logical-block :start-pos :end-pos) | |
90 | |
91 (deftype end-block-t :logical-block :start-pos :end-pos) | |
92 | |
93 (deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos) | |
94 | |
95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
96 ;;; Functions to write tokens in the output buffer | |
97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
98 | |
99 (declare emit-nl) | |
100 | |
101 (defmulti ^{:private true} write-token #(:type-tag %2)) | |
102 (defmethod write-token :start-block-t [^Writer this token] | |
103 (when-let [cb (getf :logical-block-callback)] (cb :start)) | |
104 (let [lb (:logical-block token)] | |
105 (dosync | |
106 (when-let [^String prefix (:prefix lb)] | |
107 (.write (getf :base) prefix)) | |
108 (let [col (get-column (getf :base))] | |
109 (ref-set (:start-col lb) col) | |
110 (ref-set (:indent lb) col))))) | |
111 | |
112 (defmethod write-token :end-block-t [^Writer this token] | |
113 (when-let [cb (getf :logical-block-callback)] (cb :end)) | |
114 (when-let [^String suffix (:suffix (:logical-block token))] | |
115 (.write (getf :base) suffix))) | |
116 | |
117 (defmethod write-token :indent-t [^Writer this token] | |
118 (let [lb (:logical-block token)] | |
119 (ref-set (:indent lb) | |
120 (+ (:offset token) | |
121 (condp = (:relative-to token) | |
122 :block @(:start-col lb) | |
123 :current (get-column (getf :base))))))) | |
124 | |
125 (defmethod write-token :buffer-blob [^Writer this token] | |
126 (.write (getf :base) ^String (:data token))) | |
127 | |
128 (defmethod write-token :nl-t [^Writer this token] | |
129 ; (prlabel wt @(:done-nl (:logical-block token))) | |
130 ; (prlabel wt (:type token) (= (:type token) :mandatory)) | |
131 (if (or (= (:type token) :mandatory) | |
132 (and (not (= (:type token) :fill)) | |
133 @(:done-nl (:logical-block token)))) | |
134 (emit-nl this token) | |
135 (if-let [^String tws (getf :trailing-white-space)] | |
136 (.write (getf :base) tws))) | |
137 (dosync (setf :trailing-white-space nil))) | |
138 | |
139 (defn- write-tokens [^Writer this tokens force-trailing-whitespace] | |
140 (doseq [token tokens] | |
141 (if-not (= (:type-tag token) :nl-t) | |
142 (if-let [^String tws (getf :trailing-white-space)] | |
143 (.write (getf :base) tws))) | |
144 (write-token this token) | |
145 (setf :trailing-white-space (:trailing-white-space token))) | |
146 (let [^String tws (getf :trailing-white-space)] | |
147 (when (and force-trailing-whitespace tws) | |
148 (.write (getf :base) tws) | |
149 (setf :trailing-white-space nil)))) | |
150 | |
151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
152 ;;; emit-nl? method defs for each type of new line. This makes | |
153 ;;; the decision about whether to print this type of new line. | |
154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
155 | |
156 | |
157 (defn- tokens-fit? [^Writer this tokens] | |
158 ;;; (prlabel tf? (get-column (getf :base) (buffer-length tokens)) | |
159 (let [maxcol (get-max-column (getf :base))] | |
160 (or | |
161 (nil? maxcol) | |
162 (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol)))) | |
163 | |
164 (defn- linear-nl? [this lb section] | |
165 ; (prlabel lnl? @(:done-nl lb) (tokens-fit? this section)) | |
166 (or @(:done-nl lb) | |
167 (not (tokens-fit? this section)))) | |
168 | |
169 (defn- miser-nl? [^Writer this lb section] | |
170 (let [miser-width (get-miser-width this) | |
171 maxcol (get-max-column (getf :base))] | |
172 (and miser-width maxcol | |
173 (>= @(:start-col lb) (- maxcol miser-width)) | |
174 (linear-nl? this lb section)))) | |
175 | |
176 (defmulti ^{:private true} emit-nl? (fn [t _ _ _] (:type t))) | |
177 | |
178 (defmethod emit-nl? :linear [newl this section _] | |
179 (let [lb (:logical-block newl)] | |
180 (linear-nl? this lb section))) | |
181 | |
182 (defmethod emit-nl? :miser [newl this section _] | |
183 (let [lb (:logical-block newl)] | |
184 (miser-nl? this lb section))) | |
185 | |
186 (defmethod emit-nl? :fill [newl this section subsection] | |
187 (let [lb (:logical-block newl)] | |
188 (or @(:intra-block-nl lb) | |
189 (not (tokens-fit? this subsection)) | |
190 (miser-nl? this lb section)))) | |
191 | |
192 (defmethod emit-nl? :mandatory [_ _ _ _] | |
193 true) | |
194 | |
195 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
196 ;;; Various support functions | |
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
198 | |
199 | |
200 (defn- get-section [buffer] | |
201 (let [nl (first buffer) | |
202 lb (:logical-block nl) | |
203 section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb))) | |
204 (next buffer)))] | |
205 [section (seq (drop (inc (count section)) buffer))])) | |
206 | |
207 (defn- get-sub-section [buffer] | |
208 (let [nl (first buffer) | |
209 lb (:logical-block nl) | |
210 section (seq (take-while #(let [nl-lb (:logical-block %)] | |
211 (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb))))) | |
212 (next buffer)))] | |
213 section)) | |
214 | |
215 (defn- update-nl-state [lb] | |
216 (dosync | |
217 (ref-set (:intra-block-nl lb) false) | |
218 (ref-set (:done-nl lb) true) | |
219 (loop [lb (:parent lb)] | |
220 (if lb | |
221 (do (ref-set (:done-nl lb) true) | |
222 (ref-set (:intra-block-nl lb) true) | |
223 (recur (:parent lb))))))) | |
224 | |
225 (defn- emit-nl [^Writer this nl] | |
226 (.write (getf :base) (int \newline)) | |
227 (dosync (setf :trailing-white-space nil)) | |
228 (let [lb (:logical-block nl) | |
229 ^String prefix (:per-line-prefix lb)] | |
230 (if prefix | |
231 (.write (getf :base) prefix)) | |
232 (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix)) | |
233 \space))] | |
234 (.write (getf :base) istr)) | |
235 (update-nl-state lb))) | |
236 | |
237 (defn- split-at-newline [tokens] | |
238 (let [pre (seq (take-while #(not (nl-t? %)) tokens))] | |
239 [pre (seq (drop (count pre) tokens))])) | |
240 | |
241 ;;; Methods for showing token strings for debugging | |
242 | |
243 (defmulti ^{:private true} tok :type-tag) | |
244 (defmethod tok :nl-t [token] | |
245 (:type token)) | |
246 (defmethod tok :buffer-blob [token] | |
247 (str \" (:data token) (:trailing-white-space token) \")) | |
248 (defmethod tok :default [token] | |
249 (:type-tag token)) | |
250 (defn- toks [toks] (map tok toks)) | |
251 | |
252 ;;; write-token-string is called when the set of tokens in the buffer | |
253 ;;; is longer than the available space on the line | |
254 | |
255 (defn- write-token-string [this tokens] | |
256 (let [[a b] (split-at-newline tokens)] | |
257 ;; (prlabel wts (toks a) (toks b)) | |
258 (if a (write-tokens this a false)) | |
259 (if b | |
260 (let [[section remainder] (get-section b) | |
261 newl (first b)] | |
262 ;; (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) | |
263 (let [do-nl (emit-nl? newl this section (get-sub-section b)) | |
264 result (if do-nl | |
265 (do | |
266 ;; (prlabel emit-nl (:type newl)) | |
267 (emit-nl this newl) | |
268 (next b)) | |
269 b) | |
270 long-section (not (tokens-fit? this result)) | |
271 result (if long-section | |
272 (let [rem2 (write-token-string this section)] | |
273 ;;; (prlabel recurse (toks rem2)) | |
274 (if (= rem2 section) | |
275 (do ; If that didn't produce any output, it has no nls | |
276 ; so we'll force it | |
277 (write-tokens this section false) | |
278 remainder) | |
279 (into [] (concat rem2 remainder)))) | |
280 result) | |
281 ;; ff (prlabel wts (toks result)) | |
282 ] | |
283 result))))) | |
284 | |
285 (defn- write-line [^Writer this] | |
286 (dosync | |
287 (loop [buffer (getf :buffer)] | |
288 ;; (prlabel wl1 (toks buffer)) | |
289 (setf :buffer (into [] buffer)) | |
290 (if (not (tokens-fit? this buffer)) | |
291 (let [new-buffer (write-token-string this buffer)] | |
292 ;; (prlabel wl new-buffer) | |
293 (if-not (identical? buffer new-buffer) | |
294 (recur new-buffer))))))) | |
295 | |
296 ;;; Add a buffer token to the buffer and see if it's time to start | |
297 ;;; writing | |
298 (defn- add-to-buffer [^Writer this token] | |
299 ; (prlabel a2b token) | |
300 (dosync | |
301 (setf :buffer (conj (getf :buffer) token)) | |
302 (if (not (tokens-fit? this (getf :buffer))) | |
303 (write-line this)))) | |
304 | |
305 ;;; Write all the tokens that have been buffered | |
306 (defn- write-buffered-output [^Writer this] | |
307 (write-line this) | |
308 (if-let [buf (getf :buffer)] | |
309 (do | |
310 (write-tokens this buf true) | |
311 (setf :buffer [])))) | |
312 | |
313 ;;; If there are newlines in the string, print the lines up until the last newline, | |
314 ;;; making the appropriate adjustments. Return the remainder of the string | |
315 (defn- write-initial-lines | |
316 [^Writer this ^String s] | |
317 (let [lines (.split s "\n" -1)] | |
318 (if (= (count lines) 1) | |
319 s | |
320 (dosync | |
321 (let [^String prefix (:per-line-prefix (first (getf :logical-blocks))) | |
322 ^String l (first lines)] | |
323 (if (= :buffering (getf :mode)) | |
324 (let [oldpos (getf :pos) | |
325 newpos (+ oldpos (count l))] | |
326 (setf :pos newpos) | |
327 (add-to-buffer this (make-buffer-blob l nil oldpos newpos)) | |
328 (write-buffered-output this)) | |
329 (.write (getf :base) l)) | |
330 (.write (getf :base) (int \newline)) | |
331 (doseq [^String l (next (butlast lines))] | |
332 (.write (getf :base) l) | |
333 (.write (getf :base) (int \newline)) | |
334 (if prefix | |
335 (.write (getf :base) prefix))) | |
336 (setf :buffering :writing) | |
337 (last lines)))))) | |
338 | |
339 | |
340 (defn- write-white-space [^Writer this] | |
341 (if-let [^String tws (getf :trailing-white-space)] | |
342 (dosync | |
343 (.write (getf :base) tws) | |
344 (setf :trailing-white-space nil)))) | |
345 | |
346 (defn- p-write-char [^Writer this ^Integer c] | |
347 (if (= (getf :mode) :writing) | |
348 (do | |
349 (write-white-space this) | |
350 (.write (getf :base) c)) | |
351 (if (= c \newline) | |
352 (write-initial-lines this "\n") | |
353 (let [oldpos (getf :pos) | |
354 newpos (inc oldpos)] | |
355 (dosync | |
356 (setf :pos newpos) | |
357 (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos))))))) | |
358 | |
359 | |
360 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
361 ;;; Initialize the pretty-writer instance | |
362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
363 | |
364 | |
365 (defn- pretty-writer [writer max-columns miser-width] | |
366 (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false)) | |
367 fields (ref {:pretty-writer true | |
368 :base (column-writer writer max-columns) | |
369 :logical-blocks lb | |
370 :sections nil | |
371 :mode :writing | |
372 :buffer [] | |
373 :buffer-block lb | |
374 :buffer-level 1 | |
375 :miser-width miser-width | |
376 :trailing-white-space nil | |
377 :pos 0})] | |
378 (proxy [Writer IDeref] [] | |
379 (deref [] fields) | |
380 | |
381 (write | |
382 ([x] | |
383 ;; (prlabel write x (getf :mode)) | |
384 (condp = (class x) | |
385 String | |
386 (let [^String s0 (write-initial-lines this x) | |
387 ^String s (.replaceFirst s0 "\\s+$" "") | |
388 white-space (.substring s0 (count s)) | |
389 mode (getf :mode)] | |
390 (dosync | |
391 (if (= mode :writing) | |
392 (do | |
393 (write-white-space this) | |
394 (.write (getf :base) s) | |
395 (setf :trailing-white-space white-space)) | |
396 (let [oldpos (getf :pos) | |
397 newpos (+ oldpos (count s0))] | |
398 (setf :pos newpos) | |
399 (add-to-buffer this (make-buffer-blob s white-space oldpos newpos)))))) | |
400 | |
401 Integer | |
402 (p-write-char this x)))) | |
403 | |
404 (flush [] | |
405 (if (= (getf :mode) :buffering) | |
406 (dosync | |
407 (write-tokens this (getf :buffer) true) | |
408 (setf :buffer [])) | |
409 (write-white-space this))) | |
410 | |
411 (close [] | |
412 (.flush this))))) | |
413 | |
414 | |
415 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
416 ;;; Methods for pretty-writer | |
417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
418 | |
419 (defn- start-block | |
420 [^Writer this | |
421 ^String prefix ^String per-line-prefix ^String suffix] | |
422 (dosync | |
423 (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0) | |
424 (ref false) (ref false) | |
425 prefix per-line-prefix suffix)] | |
426 (setf :logical-blocks lb) | |
427 (if (= (getf :mode) :writing) | |
428 (do | |
429 (write-white-space this) | |
430 (when-let [cb (getf :logical-block-callback)] (cb :start)) | |
431 (if prefix | |
432 (.write (getf :base) prefix)) | |
433 (let [col (get-column (getf :base))] | |
434 (ref-set (:start-col lb) col) | |
435 (ref-set (:indent lb) col))) | |
436 (let [oldpos (getf :pos) | |
437 newpos (+ oldpos (if prefix (count prefix) 0))] | |
438 (setf :pos newpos) | |
439 (add-to-buffer this (make-start-block-t lb oldpos newpos))))))) | |
440 | |
441 (defn- end-block [^Writer this] | |
442 (dosync | |
443 (let [lb (getf :logical-blocks) | |
444 ^String suffix (:suffix lb)] | |
445 (if (= (getf :mode) :writing) | |
446 (do | |
447 (write-white-space this) | |
448 (if suffix | |
449 (.write (getf :base) suffix)) | |
450 (when-let [cb (getf :logical-block-callback)] (cb :end))) | |
451 (let [oldpos (getf :pos) | |
452 newpos (+ oldpos (if suffix (count suffix) 0))] | |
453 (setf :pos newpos) | |
454 (add-to-buffer this (make-end-block-t lb oldpos newpos)))) | |
455 (setf :logical-blocks (:parent lb))))) | |
456 | |
457 (defn- nl [^Writer this type] | |
458 (dosync | |
459 (setf :mode :buffering) | |
460 (let [pos (getf :pos)] | |
461 (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos))))) | |
462 | |
463 (defn- indent [^Writer this relative-to offset] | |
464 (dosync | |
465 (let [lb (getf :logical-blocks)] | |
466 (if (= (getf :mode) :writing) | |
467 (do | |
468 (write-white-space this) | |
469 (ref-set (:indent lb) | |
470 (+ offset (condp = relative-to | |
471 :block @(:start-col lb) | |
472 :current (get-column (getf :base)))))) | |
473 (let [pos (getf :pos)] | |
474 (add-to-buffer this (make-indent-t lb relative-to offset pos pos))))))) | |
475 | |
476 (defn- get-miser-width [^Writer this] | |
477 (getf :miser-width)) | |
478 | |
479 (defn- set-miser-width [^Writer this new-miser-width] | |
480 (dosync (setf :miser-width new-miser-width))) | |
481 | |
482 (defn- set-logical-block-callback [^Writer this f] | |
483 (dosync (setf :logical-block-callback f))) |