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