1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/pprint/pretty_writer.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,488 @@
     1.4 +;;; pretty_writer.clj -- part of the pretty printer for Clojure
     1.5 +
     1.6 +;; by Tom Faulhaber
     1.7 +;; April 3, 2009
     1.8 +;; Revised to use proxy instead of gen-class April 2010
     1.9 +
    1.10 +;   Copyright (c) Tom Faulhaber, Jan 2009. All rights reserved.
    1.11 +;   The use and distribution terms for this software are covered by the
    1.12 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
    1.13 +;   which can be found in the file epl-v10.html at the root of this distribution.
    1.14 +;   By using this software in any fashion, you are agreeing to be bound by
    1.15 +;   the terms of this license.
    1.16 +;   You must not remove this notice, or any other, from this software.
    1.17 +
    1.18 +;; This module implements a wrapper around a java.io.Writer which implements the
    1.19 +;; core of the XP algorithm.
    1.20 +
    1.21 +(ns clojure.contrib.pprint.pretty-writer
    1.22 +  (:refer-clojure :exclude (deftype))
    1.23 +  (:use clojure.contrib.pprint.utilities)
    1.24 +  (:use [clojure.contrib.pprint.column-writer
    1.25 +         :only (column-writer get-column get-max-column)])
    1.26 +  (:import
    1.27 +   [clojure.lang IDeref]
    1.28 +   [java.io Writer]))
    1.29 +
    1.30 +;; TODO: Support for tab directives
    1.31 +
    1.32 +
    1.33 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.34 +;;; Forward declarations
    1.35 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.36 +
    1.37 +(declare get-miser-width)
    1.38 +
    1.39 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.40 +;;; Macros to simplify dealing with types and classes. These are
    1.41 +;;; really utilities, but I'm experimenting with them here.
    1.42 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.43 +
    1.44 +(defmacro ^{:private true} 
    1.45 +  getf 
    1.46 +  "Get the value of the field a named by the argument (which should be a keyword)."
    1.47 +  [sym]
    1.48 +  `(~sym @@~'this))
    1.49 +
    1.50 +(defmacro ^{:private true} 
    1.51 +  setf [sym new-val] 
    1.52 +  "Set the value of the field SYM to NEW-VAL"
    1.53 +  `(alter @~'this assoc ~sym ~new-val))
    1.54 +
    1.55 +(defmacro ^{:private true} 
    1.56 +  deftype [type-name & fields]
    1.57 +  (let [name-str (name type-name)]
    1.58 +    `(do
    1.59 +       (defstruct ~type-name :type-tag ~@fields)
    1.60 +       (defn- ~(symbol (str "make-" name-str)) 
    1.61 +         [& vals#] (apply struct ~type-name ~(keyword name-str) vals#))
    1.62 +       (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str))))))
    1.63 +
    1.64 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.65 +;;; The data structures used by pretty-writer
    1.66 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.67 +
    1.68 +(defstruct ^{:private true} logical-block
    1.69 +           :parent :section :start-col :indent
    1.70 +           :done-nl :intra-block-nl
    1.71 +           :prefix :per-line-prefix :suffix
    1.72 +           :logical-block-callback)
    1.73 +
    1.74 +(defn ancestor? [parent child]
    1.75 +  (loop [child (:parent child)]
    1.76 +    (cond 
    1.77 +     (nil? child) false
    1.78 +     (identical? parent child) true
    1.79 +     :else (recur (:parent child)))))
    1.80 +
    1.81 +(defstruct ^{:private true} section :parent)
    1.82 +
    1.83 +(defn buffer-length [l] 
    1.84 +  (let [l (seq l)]
    1.85 +    (if l 
    1.86 +      (- (:end-pos (last l)) (:start-pos (first l)))
    1.87 +      0)))
    1.88 +
    1.89 +; A blob of characters (aka a string)
    1.90 +(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos)
    1.91 +
    1.92 +; A newline
    1.93 +(deftype nl-t :type :logical-block :start-pos :end-pos)
    1.94 +
    1.95 +(deftype start-block-t :logical-block :start-pos :end-pos)
    1.96 +
    1.97 +(deftype end-block-t :logical-block :start-pos :end-pos)
    1.98 +
    1.99 +(deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos)
   1.100 +
   1.101 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.102 +;;; Functions to write tokens in the output buffer
   1.103 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.104 +
   1.105 +(declare emit-nl)
   1.106 +
   1.107 +(defmulti write-token #(:type-tag %2))
   1.108 +(defmethod write-token :start-block-t [^Writer this token]
   1.109 +   (when-let [cb (getf :logical-block-callback)] (cb :start))
   1.110 +   (let [lb (:logical-block token)]
   1.111 +    (dosync
   1.112 +     (when-let [^String prefix (:prefix lb)] 
   1.113 +       (.write (getf :base) prefix))
   1.114 +     (let [col (get-column (getf :base))]
   1.115 +       (ref-set (:start-col lb) col)
   1.116 +       (ref-set (:indent lb) col)))))
   1.117 +
   1.118 +(defmethod write-token :end-block-t [^Writer this token]
   1.119 +  (when-let [cb (getf :logical-block-callback)] (cb :end))
   1.120 +  (when-let [^String suffix (:suffix (:logical-block token))] 
   1.121 +    (.write (getf :base) suffix)))
   1.122 +
   1.123 +(defmethod write-token :indent-t [^Writer this token]
   1.124 +  (let [lb (:logical-block token)]
   1.125 +    (ref-set (:indent lb) 
   1.126 +             (+ (:offset token)
   1.127 +                (condp = (:relative-to token)
   1.128 +		  :block @(:start-col lb)
   1.129 +		  :current (get-column (getf :base)))))))
   1.130 +
   1.131 +(defmethod write-token :buffer-blob [^Writer this token]
   1.132 +  (.write (getf :base) ^String (:data token)))
   1.133 +
   1.134 +(defmethod write-token :nl-t [^Writer this token]
   1.135 +;  (prlabel wt @(:done-nl (:logical-block token)))
   1.136 +;  (prlabel wt (:type token) (= (:type token) :mandatory))
   1.137 +  (if (or (= (:type token) :mandatory)
   1.138 +           (and (not (= (:type token) :fill))
   1.139 +                @(:done-nl (:logical-block token))))
   1.140 +    (emit-nl this token)
   1.141 +    (if-let [^String tws (getf :trailing-white-space)]
   1.142 +      (.write (getf :base) tws)))
   1.143 +  (dosync (setf :trailing-white-space nil)))
   1.144 +
   1.145 +(defn- write-tokens [^Writer this tokens force-trailing-whitespace]
   1.146 +  (doseq [token tokens]
   1.147 +    (if-not (= (:type-tag token) :nl-t)
   1.148 +      (if-let [^String tws (getf :trailing-white-space)]
   1.149 +	(.write (getf :base) tws)))
   1.150 +    (write-token this token)
   1.151 +    (setf :trailing-white-space (:trailing-white-space token)))
   1.152 +  (let [^String tws (getf :trailing-white-space)] 
   1.153 +    (when (and force-trailing-whitespace tws)
   1.154 +      (.write (getf :base) tws)
   1.155 +      (setf :trailing-white-space nil))))
   1.156 +
   1.157 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.158 +;;; emit-nl? method defs for each type of new line. This makes
   1.159 +;;; the decision about whether to print this type of new line.
   1.160 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.161 +
   1.162 +
   1.163 +(defn- tokens-fit? [^Writer this tokens]
   1.164 +;;;  (prlabel tf? (get-column (getf :base) (buffer-length tokens))
   1.165 +  (let [maxcol (get-max-column (getf :base))]
   1.166 +    (or 
   1.167 +     (nil? maxcol) 
   1.168 +     (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol))))
   1.169 +
   1.170 +(defn- linear-nl? [this lb section]
   1.171 +;  (prlabel lnl? @(:done-nl lb) (tokens-fit? this section))
   1.172 +  (or @(:done-nl lb)
   1.173 +      (not (tokens-fit? this section))))
   1.174 +
   1.175 +(defn- miser-nl? [^Writer this lb section]
   1.176 +  (let [miser-width (get-miser-width this)
   1.177 +        maxcol (get-max-column (getf :base))]
   1.178 +    (and miser-width maxcol
   1.179 +         (>= @(:start-col lb) (- maxcol miser-width))
   1.180 +         (linear-nl? this lb section))))
   1.181 +
   1.182 +(defmulti emit-nl? (fn [t _ _ _] (:type t)))
   1.183 +
   1.184 +(defmethod emit-nl? :linear [newl this section _]
   1.185 +  (let [lb (:logical-block newl)]
   1.186 +    (linear-nl? this lb section)))
   1.187 +
   1.188 +(defmethod emit-nl? :miser [newl this section _]
   1.189 +  (let [lb (:logical-block newl)]
   1.190 +    (miser-nl? this lb section)))
   1.191 +
   1.192 +(defmethod emit-nl? :fill [newl this section subsection]
   1.193 +  (let [lb (:logical-block newl)]
   1.194 +    (or @(:intra-block-nl lb)
   1.195 +        (not (tokens-fit? this subsection))
   1.196 +        (miser-nl? this lb section))))
   1.197 +
   1.198 +(defmethod emit-nl? :mandatory [_ _ _ _]
   1.199 +  true)
   1.200 +
   1.201 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.202 +;;; Various support functions
   1.203 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.204 +
   1.205 +
   1.206 +(defn- get-section [buffer]
   1.207 +  (let [nl (first buffer) 
   1.208 +        lb (:logical-block nl)
   1.209 +        section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb)))
   1.210 +                                 (next buffer)))]
   1.211 +    [section (seq (drop (inc (count section)) buffer))])) 
   1.212 +
   1.213 +(defn- get-sub-section [buffer]
   1.214 +  (let [nl (first buffer) 
   1.215 +        lb (:logical-block nl)
   1.216 +        section (seq (take-while #(let [nl-lb (:logical-block %)]
   1.217 +                                    (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb)))))
   1.218 +                            (next buffer)))]
   1.219 +    section)) 
   1.220 +
   1.221 +(defn- update-nl-state [lb]
   1.222 +  (dosync
   1.223 +   (ref-set (:intra-block-nl lb) false)
   1.224 +   (ref-set (:done-nl lb) true)
   1.225 +   (loop [lb (:parent lb)]
   1.226 +     (if lb
   1.227 +       (do (ref-set (:done-nl lb) true)
   1.228 +           (ref-set (:intra-block-nl lb) true)
   1.229 +           (recur (:parent lb)))))))
   1.230 +
   1.231 +(defn emit-nl [^Writer this nl]
   1.232 +  (.write (getf :base) (int \newline))
   1.233 +  (dosync (setf :trailing-white-space nil))
   1.234 +  (let [lb (:logical-block nl)
   1.235 +        ^String prefix (:per-line-prefix lb)] 
   1.236 +    (if prefix 
   1.237 +      (.write (getf :base) prefix))
   1.238 +    (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix))
   1.239 +					  \space))] 
   1.240 +      (.write (getf :base) istr))
   1.241 +    (update-nl-state lb)))
   1.242 +
   1.243 +(defn- split-at-newline [tokens]
   1.244 +  (let [pre (seq (take-while #(not (nl-t? %)) tokens))]
   1.245 +    [pre (seq (drop (count pre) tokens))]))
   1.246 +
   1.247 +;;; Methods for showing token strings for debugging
   1.248 +
   1.249 +(defmulti tok :type-tag)
   1.250 +(defmethod tok :nl-t [token]
   1.251 +  (:type token))
   1.252 +(defmethod tok :buffer-blob [token]
   1.253 +  (str \" (:data token) (:trailing-white-space token) \"))
   1.254 +(defmethod tok :default [token]
   1.255 +  (:type-tag token))
   1.256 +(defn toks [toks] (map tok toks))
   1.257 +
   1.258 +;;; write-token-string is called when the set of tokens in the buffer
   1.259 +;;; is longer than the available space on the line
   1.260 +
   1.261 +(defn- write-token-string [this tokens]
   1.262 +  (let [[a b] (split-at-newline tokens)]
   1.263 +;;    (prlabel wts (toks a) (toks b))
   1.264 +    (if a (write-tokens this a false))
   1.265 +    (if b
   1.266 +      (let [[section remainder] (get-section b)
   1.267 +            newl (first b)]
   1.268 +;;         (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) 
   1.269 +        (let [do-nl (emit-nl? newl this section (get-sub-section b))
   1.270 +              result (if do-nl 
   1.271 +                       (do
   1.272 +;;                          (prlabel emit-nl (:type newl))
   1.273 +                         (emit-nl this newl)
   1.274 +                         (next b))
   1.275 +                       b)
   1.276 +              long-section (not (tokens-fit? this result))
   1.277 +              result (if long-section
   1.278 +                       (let [rem2 (write-token-string this section)]
   1.279 +;;;                              (prlabel recurse (toks rem2))
   1.280 +                         (if (= rem2 section)
   1.281 +                           (do ; If that didn't produce any output, it has no nls
   1.282 +                                        ; so we'll force it
   1.283 +                             (write-tokens this section false)
   1.284 +                             remainder)
   1.285 +                           (into [] (concat rem2 remainder))))
   1.286 +                       result)
   1.287 +;;              ff (prlabel wts (toks result))
   1.288 +              ] 
   1.289 +          result)))))
   1.290 +
   1.291 +(defn- write-line [^Writer this]
   1.292 +  (dosync
   1.293 +   (loop [buffer (getf :buffer)]
   1.294 +;;     (prlabel wl1 (toks buffer))
   1.295 +     (setf :buffer (into [] buffer))
   1.296 +     (if (not (tokens-fit? this buffer))
   1.297 +       (let [new-buffer (write-token-string this buffer)]
   1.298 +;;          (prlabel wl new-buffer)
   1.299 +         (if-not (identical? buffer new-buffer)
   1.300 +                 (recur new-buffer)))))))
   1.301 +
   1.302 +;;; Add a buffer token to the buffer and see if it's time to start
   1.303 +;;; writing
   1.304 +(defn- add-to-buffer [^Writer this token]
   1.305 +;  (prlabel a2b token)
   1.306 +  (dosync
   1.307 +   (setf :buffer (conj (getf :buffer) token))
   1.308 +   (if (not (tokens-fit? this (getf :buffer)))
   1.309 +     (write-line this))))
   1.310 +
   1.311 +;;; Write all the tokens that have been buffered
   1.312 +(defn- write-buffered-output [^Writer this]
   1.313 +  (write-line this)
   1.314 +  (if-let [buf (getf :buffer)]
   1.315 +    (do
   1.316 +      (write-tokens this buf true)
   1.317 +      (setf :buffer []))))
   1.318 +
   1.319 +;;; If there are newlines in the string, print the lines up until the last newline, 
   1.320 +;;; making the appropriate adjustments. Return the remainder of the string
   1.321 +(defn- write-initial-lines 
   1.322 +  [^Writer this ^String s] 
   1.323 +  (let [lines (.split s "\n" -1)]
   1.324 +    (if (= (count lines) 1)
   1.325 +      s
   1.326 +      (dosync 
   1.327 +       (let [^String prefix (:per-line-prefix (first (getf :logical-blocks)))
   1.328 +             ^String l (first lines)] 
   1.329 +         (if (= :buffering (getf :mode))
   1.330 +           (let [oldpos (getf :pos)
   1.331 +                 newpos (+ oldpos (count l))]
   1.332 +             (setf :pos newpos)
   1.333 +             (add-to-buffer this (make-buffer-blob l nil oldpos newpos))
   1.334 +             (write-buffered-output this))
   1.335 +           (.write (getf :base) l))
   1.336 +         (.write (getf :base) (int \newline))
   1.337 +         (doseq [^String l (next (butlast lines))]
   1.338 +           (.write (getf :base) l)
   1.339 +           (.write (getf :base) (int \newline))
   1.340 +           (if prefix
   1.341 +             (.write (getf :base) prefix)))
   1.342 +         (setf :buffering :writing)
   1.343 +         (last lines))))))
   1.344 +
   1.345 +
   1.346 +(defn write-white-space [^Writer this]
   1.347 +  (if-let [^String tws (getf :trailing-white-space)]
   1.348 +    (dosync
   1.349 +     (.write (getf :base) tws)
   1.350 +     (setf :trailing-white-space nil))))
   1.351 +
   1.352 +(defn- write-char [^Writer this ^Integer c]
   1.353 +  (if (= (getf :mode) :writing)
   1.354 +    (do 
   1.355 +      (write-white-space this)
   1.356 +      (.write (getf :base) c))
   1.357 +    (if (= c \newline)
   1.358 +      (write-initial-lines this "\n")
   1.359 +      (let [oldpos (getf :pos)
   1.360 +            newpos (inc oldpos)]
   1.361 +        (dosync
   1.362 +         (setf :pos newpos)
   1.363 +         (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos)))))))
   1.364 +
   1.365 +
   1.366 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.367 +;;; Initialize the pretty-writer instance
   1.368 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.369 +
   1.370 +
   1.371 +(defn pretty-writer [writer max-columns miser-width]
   1.372 +  (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))
   1.373 +        fields (ref {:pretty-writer true
   1.374 +                     :base (column-writer writer max-columns)
   1.375 +                     :logical-blocks lb 
   1.376 +                     :sections nil
   1.377 +                     :mode :writing
   1.378 +                     :buffer []
   1.379 +                     :buffer-block lb
   1.380 +                     :buffer-level 1
   1.381 +                     :miser-width miser-width
   1.382 +                     :trailing-white-space nil
   1.383 +                     :pos 0})]
   1.384 +    (proxy [Writer IDeref] []
   1.385 +      (deref [] fields)
   1.386 +
   1.387 +      (write 
   1.388 +       ([x]
   1.389 +          ;;     (prlabel write x (getf :mode))
   1.390 +          (condp = (class x)
   1.391 +            String 
   1.392 +            (let [^String s0 (write-initial-lines this x)
   1.393 +                  ^String s (.replaceFirst s0 "\\s+$" "")
   1.394 +                  white-space (.substring s0 (count s))
   1.395 +                  mode (getf :mode)]
   1.396 +              (dosync
   1.397 +               (if (= mode :writing)
   1.398 +                 (do
   1.399 +                   (write-white-space this)
   1.400 +                   (.write (getf :base) s)
   1.401 +                   (setf :trailing-white-space white-space))
   1.402 +                 (let [oldpos (getf :pos)
   1.403 +                       newpos (+ oldpos (count s0))]
   1.404 +                   (setf :pos newpos)
   1.405 +                   (add-to-buffer this (make-buffer-blob s white-space oldpos newpos))))))
   1.406 +
   1.407 +            Integer
   1.408 +            (write-char this x)
   1.409 +            Long
   1.410 +            (write-char this x))))
   1.411 +
   1.412 +      (flush []
   1.413 +             (if (= (getf :mode) :buffering)
   1.414 +               (dosync 
   1.415 +                (write-tokens this (getf :buffer) true)
   1.416 +                (setf :buffer []))
   1.417 +               (write-white-space this)))
   1.418 +
   1.419 +      (close []
   1.420 +             (.flush this)))))
   1.421 +
   1.422 +
   1.423 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.424 +;;; Methods for pretty-writer
   1.425 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.426 +
   1.427 +(defn start-block 
   1.428 +  [^Writer this 
   1.429 +   ^String prefix ^String per-line-prefix ^String suffix]
   1.430 +  (dosync 
   1.431 +   (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0)
   1.432 +                    (ref false) (ref false)
   1.433 +                    prefix per-line-prefix suffix)]
   1.434 +     (setf :logical-blocks lb)
   1.435 +     (if (= (getf :mode) :writing)
   1.436 +       (do
   1.437 +         (write-white-space this)
   1.438 +          (when-let [cb (getf :logical-block-callback)] (cb :start))
   1.439 +          (if prefix 
   1.440 +           (.write (getf :base) prefix))
   1.441 +         (let [col (get-column (getf :base))]
   1.442 +           (ref-set (:start-col lb) col)
   1.443 +           (ref-set (:indent lb) col)))
   1.444 +       (let [oldpos (getf :pos)
   1.445 +             newpos (+ oldpos (if prefix (count prefix) 0))]
   1.446 +         (setf :pos newpos)
   1.447 +         (add-to-buffer this (make-start-block-t lb oldpos newpos)))))))
   1.448 +
   1.449 +(defn end-block [^Writer this]
   1.450 +  (dosync
   1.451 +   (let [lb (getf :logical-blocks)
   1.452 +         ^String suffix (:suffix lb)]
   1.453 +     (if (= (getf :mode) :writing)
   1.454 +       (do
   1.455 +         (write-white-space this)
   1.456 +         (if suffix
   1.457 +           (.write (getf :base) suffix))
   1.458 +         (when-let [cb (getf :logical-block-callback)] (cb :end)))
   1.459 +       (let [oldpos (getf :pos)
   1.460 +             newpos (+ oldpos (if suffix (count suffix) 0))]
   1.461 +         (setf :pos newpos)
   1.462 +         (add-to-buffer this (make-end-block-t lb oldpos newpos))))
   1.463 +     (setf :logical-blocks (:parent lb)))))
   1.464 +
   1.465 +(defn nl [^Writer this type]
   1.466 +  (dosync 
   1.467 +   (setf :mode :buffering)
   1.468 +   (let [pos (getf :pos)]
   1.469 +     (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos)))))
   1.470 +
   1.471 +(defn indent [^Writer this relative-to offset]
   1.472 +  (dosync 
   1.473 +   (let [lb (getf :logical-blocks)]
   1.474 +     (if (= (getf :mode) :writing)
   1.475 +       (do
   1.476 +         (write-white-space this)
   1.477 +         (ref-set (:indent lb) 
   1.478 +                  (+ offset (condp = relative-to
   1.479 +			      :block @(:start-col lb)
   1.480 +			      :current (get-column (getf :base))))))
   1.481 +       (let [pos (getf :pos)]
   1.482 +         (add-to-buffer this (make-indent-t lb relative-to offset pos pos)))))))
   1.483 +
   1.484 +(defn get-miser-width [^Writer this]
   1.485 +  (getf :miser-width))
   1.486 +
   1.487 +(defn set-miser-width [^Writer this new-miser-width]
   1.488 +  (dosync (setf :miser-width new-miser-width)))
   1.489 +
   1.490 +(defn set-logical-block-callback [^Writer this f]
   1.491 +  (dosync (setf :logical-block-callback f)))