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