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