Mercurial > lasercutter

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

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