rlm@10: ;;; pretty_writer.clj -- part of the pretty printer for Clojure
rlm@10: 
rlm@10: ;   Copyright (c) Rich Hickey. All rights reserved.
rlm@10: ;   The use and distribution terms for this software are covered by the
rlm@10: ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
rlm@10: ;   which can be found in the file epl-v10.html at the root of this distribution.
rlm@10: ;   By using this software in any fashion, you are agreeing to be bound by
rlm@10: ;   the terms of this license.
rlm@10: ;   You must not remove this notice, or any other, from this software.
rlm@10: 
rlm@10: ;; Author: Tom Faulhaber
rlm@10: ;; April 3, 2009
rlm@10: ;; Revised to use proxy instead of gen-class April 2010
rlm@10: 
rlm@10: ;; This module implements a wrapper around a java.io.Writer which implements the
rlm@10: ;; core of the XP algorithm.
rlm@10: 
rlm@10: (in-ns 'clojure.pprint)
rlm@10: 
rlm@10: (import [clojure.lang IDeref]
rlm@10:         [java.io Writer])
rlm@10: 
rlm@10: ;; TODO: Support for tab directives
rlm@10: 
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;;; Forward declarations
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: (declare get-miser-width)
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;;; Macros to simplify dealing with types and classes. These are
rlm@10: ;;; really utilities, but I'm experimenting with them here.
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: (defmacro ^{:private true} 
rlm@10:   getf 
rlm@10:   "Get the value of the field a named by the argument (which should be a keyword)."
rlm@10:   [sym]
rlm@10:   `(~sym @@~'this))
rlm@10: 
rlm@10: (defmacro ^{:private true} 
rlm@10:   setf [sym new-val] 
rlm@10:   "Set the value of the field SYM to NEW-VAL"
rlm@10:   `(alter @~'this assoc ~sym ~new-val))
rlm@10: 
rlm@10: (defmacro ^{:private true} 
rlm@10:   deftype [type-name & fields]
rlm@10:   (let [name-str (name type-name)]
rlm@10:     `(do
rlm@10:        (defstruct ~type-name :type-tag ~@fields)
rlm@10:        (alter-meta! #'~type-name assoc :private true)
rlm@10:        (defn- ~(symbol (str "make-" name-str)) 
rlm@10:          [& vals#] (apply struct ~type-name ~(keyword name-str) vals#))
rlm@10:        (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str))))))
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;;; The data structures used by pretty-writer
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: (defstruct ^{:private true} logical-block
rlm@10:            :parent :section :start-col :indent
rlm@10:            :done-nl :intra-block-nl
rlm@10:            :prefix :per-line-prefix :suffix
rlm@10:            :logical-block-callback)
rlm@10: 
rlm@10: (defn- ancestor? [parent child]
rlm@10:   (loop [child (:parent child)]
rlm@10:     (cond 
rlm@10:      (nil? child) false
rlm@10:      (identical? parent child) true
rlm@10:      :else (recur (:parent child)))))
rlm@10: 
rlm@10: (defstruct ^{:private true} section :parent)
rlm@10: 
rlm@10: (defn- buffer-length [l] 
rlm@10:   (let [l (seq l)]
rlm@10:     (if l 
rlm@10:       (- (:end-pos (last l)) (:start-pos (first l)))
rlm@10:       0)))
rlm@10: 
rlm@10: ; A blob of characters (aka a string)
rlm@10: (deftype buffer-blob :data :trailing-white-space :start-pos :end-pos)
rlm@10: 
rlm@10: ; A newline
rlm@10: (deftype nl-t :type :logical-block :start-pos :end-pos)
rlm@10: 
rlm@10: (deftype start-block-t :logical-block :start-pos :end-pos)
rlm@10: 
rlm@10: (deftype end-block-t :logical-block :start-pos :end-pos)
rlm@10: 
rlm@10: (deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos)
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;;; Functions to write tokens in the output buffer
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: (declare emit-nl)
rlm@10: 
rlm@10: (defmulti ^{:private true} write-token #(:type-tag %2))
rlm@10: (defmethod write-token :start-block-t [^Writer this token]
rlm@10:    (when-let [cb (getf :logical-block-callback)] (cb :start))
rlm@10:    (let [lb (:logical-block token)]
rlm@10:     (dosync
rlm@10:      (when-let [^String prefix (:prefix lb)] 
rlm@10:        (.write (getf :base) prefix))
rlm@10:      (let [col (get-column (getf :base))]
rlm@10:        (ref-set (:start-col lb) col)
rlm@10:        (ref-set (:indent lb) col)))))
rlm@10: 
rlm@10: (defmethod write-token :end-block-t [^Writer this token]
rlm@10:   (when-let [cb (getf :logical-block-callback)] (cb :end))
rlm@10:   (when-let [^String suffix (:suffix (:logical-block token))] 
rlm@10:     (.write (getf :base) suffix)))
rlm@10: 
rlm@10: (defmethod write-token :indent-t [^Writer this token]
rlm@10:   (let [lb (:logical-block token)]
rlm@10:     (ref-set (:indent lb) 
rlm@10:              (+ (:offset token)
rlm@10:                 (condp = (:relative-to token)
rlm@10: 		  :block @(:start-col lb)
rlm@10: 		  :current (get-column (getf :base)))))))
rlm@10: 
rlm@10: (defmethod write-token :buffer-blob [^Writer this token]
rlm@10:   (.write (getf :base) ^String (:data token)))
rlm@10: 
rlm@10: (defmethod write-token :nl-t [^Writer this token]
rlm@10: ;  (prlabel wt @(:done-nl (:logical-block token)))
rlm@10: ;  (prlabel wt (:type token) (= (:type token) :mandatory))
rlm@10:   (if (or (= (:type token) :mandatory)
rlm@10:            (and (not (= (:type token) :fill))
rlm@10:                 @(:done-nl (:logical-block token))))
rlm@10:     (emit-nl this token)
rlm@10:     (if-let [^String tws (getf :trailing-white-space)]
rlm@10:       (.write (getf :base) tws)))
rlm@10:   (dosync (setf :trailing-white-space nil)))
rlm@10: 
rlm@10: (defn- write-tokens [^Writer this tokens force-trailing-whitespace]
rlm@10:   (doseq [token tokens]
rlm@10:     (if-not (= (:type-tag token) :nl-t)
rlm@10:       (if-let [^String tws (getf :trailing-white-space)]
rlm@10: 	(.write (getf :base) tws)))
rlm@10:     (write-token this token)
rlm@10:     (setf :trailing-white-space (:trailing-white-space token)))
rlm@10:   (let [^String tws (getf :trailing-white-space)] 
rlm@10:     (when (and force-trailing-whitespace tws)
rlm@10:       (.write (getf :base) tws)
rlm@10:       (setf :trailing-white-space nil))))
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;;; emit-nl? method defs for each type of new line. This makes
rlm@10: ;;; the decision about whether to print this type of new line.
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: 
rlm@10: (defn- tokens-fit? [^Writer this tokens]
rlm@10: ;;;  (prlabel tf? (get-column (getf :base) (buffer-length tokens))
rlm@10:   (let [maxcol (get-max-column (getf :base))]
rlm@10:     (or 
rlm@10:      (nil? maxcol) 
rlm@10:      (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol))))
rlm@10: 
rlm@10: (defn- linear-nl? [this lb section]
rlm@10: ;  (prlabel lnl? @(:done-nl lb) (tokens-fit? this section))
rlm@10:   (or @(:done-nl lb)
rlm@10:       (not (tokens-fit? this section))))
rlm@10: 
rlm@10: (defn- miser-nl? [^Writer this lb section]
rlm@10:   (let [miser-width (get-miser-width this)
rlm@10:         maxcol (get-max-column (getf :base))]
rlm@10:     (and miser-width maxcol
rlm@10:          (>= @(:start-col lb) (- maxcol miser-width))
rlm@10:          (linear-nl? this lb section))))
rlm@10: 
rlm@10: (defmulti ^{:private true} emit-nl? (fn [t _ _ _] (:type t)))
rlm@10: 
rlm@10: (defmethod emit-nl? :linear [newl this section _]
rlm@10:   (let [lb (:logical-block newl)]
rlm@10:     (linear-nl? this lb section)))
rlm@10: 
rlm@10: (defmethod emit-nl? :miser [newl this section _]
rlm@10:   (let [lb (:logical-block newl)]
rlm@10:     (miser-nl? this lb section)))
rlm@10: 
rlm@10: (defmethod emit-nl? :fill [newl this section subsection]
rlm@10:   (let [lb (:logical-block newl)]
rlm@10:     (or @(:intra-block-nl lb)
rlm@10:         (not (tokens-fit? this subsection))
rlm@10:         (miser-nl? this lb section))))
rlm@10: 
rlm@10: (defmethod emit-nl? :mandatory [_ _ _ _]
rlm@10:   true)
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;;; Various support functions
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: 
rlm@10: (defn- get-section [buffer]
rlm@10:   (let [nl (first buffer) 
rlm@10:         lb (:logical-block nl)
rlm@10:         section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb)))
rlm@10:                                  (next buffer)))]
rlm@10:     [section (seq (drop (inc (count section)) buffer))])) 
rlm@10: 
rlm@10: (defn- get-sub-section [buffer]
rlm@10:   (let [nl (first buffer) 
rlm@10:         lb (:logical-block nl)
rlm@10:         section (seq (take-while #(let [nl-lb (:logical-block %)]
rlm@10:                                     (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb)))))
rlm@10:                             (next buffer)))]
rlm@10:     section)) 
rlm@10: 
rlm@10: (defn- update-nl-state [lb]
rlm@10:   (dosync
rlm@10:    (ref-set (:intra-block-nl lb) false)
rlm@10:    (ref-set (:done-nl lb) true)
rlm@10:    (loop [lb (:parent lb)]
rlm@10:      (if lb
rlm@10:        (do (ref-set (:done-nl lb) true)
rlm@10:            (ref-set (:intra-block-nl lb) true)
rlm@10:            (recur (:parent lb)))))))
rlm@10: 
rlm@10: (defn- emit-nl [^Writer this nl]
rlm@10:   (.write (getf :base) (int \newline))
rlm@10:   (dosync (setf :trailing-white-space nil))
rlm@10:   (let [lb (:logical-block nl)
rlm@10:         ^String prefix (:per-line-prefix lb)] 
rlm@10:     (if prefix 
rlm@10:       (.write (getf :base) prefix))
rlm@10:     (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix))
rlm@10: 					  \space))] 
rlm@10:       (.write (getf :base) istr))
rlm@10:     (update-nl-state lb)))
rlm@10: 
rlm@10: (defn- split-at-newline [tokens]
rlm@10:   (let [pre (seq (take-while #(not (nl-t? %)) tokens))]
rlm@10:     [pre (seq (drop (count pre) tokens))]))
rlm@10: 
rlm@10: ;;; Methods for showing token strings for debugging
rlm@10: 
rlm@10: (defmulti ^{:private true} tok :type-tag)
rlm@10: (defmethod tok :nl-t [token]
rlm@10:   (:type token))
rlm@10: (defmethod tok :buffer-blob [token]
rlm@10:   (str \" (:data token) (:trailing-white-space token) \"))
rlm@10: (defmethod tok :default [token]
rlm@10:   (:type-tag token))
rlm@10: (defn- toks [toks] (map tok toks))
rlm@10: 
rlm@10: ;;; write-token-string is called when the set of tokens in the buffer
rlm@10: ;;; is longer than the available space on the line
rlm@10: 
rlm@10: (defn- write-token-string [this tokens]
rlm@10:   (let [[a b] (split-at-newline tokens)]
rlm@10: ;;    (prlabel wts (toks a) (toks b))
rlm@10:     (if a (write-tokens this a false))
rlm@10:     (if b
rlm@10:       (let [[section remainder] (get-section b)
rlm@10:             newl (first b)]
rlm@10: ;;         (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) 
rlm@10:         (let [do-nl (emit-nl? newl this section (get-sub-section b))
rlm@10:               result (if do-nl 
rlm@10:                        (do
rlm@10: ;;                          (prlabel emit-nl (:type newl))
rlm@10:                          (emit-nl this newl)
rlm@10:                          (next b))
rlm@10:                        b)
rlm@10:               long-section (not (tokens-fit? this result))
rlm@10:               result (if long-section
rlm@10:                        (let [rem2 (write-token-string this section)]
rlm@10: ;;;                              (prlabel recurse (toks rem2))
rlm@10:                          (if (= rem2 section)
rlm@10:                            (do ; If that didn't produce any output, it has no nls
rlm@10:                                         ; so we'll force it
rlm@10:                              (write-tokens this section false)
rlm@10:                              remainder)
rlm@10:                            (into [] (concat rem2 remainder))))
rlm@10:                        result)
rlm@10: ;;              ff (prlabel wts (toks result))
rlm@10:               ] 
rlm@10:           result)))))
rlm@10: 
rlm@10: (defn- write-line [^Writer this]
rlm@10:   (dosync
rlm@10:    (loop [buffer (getf :buffer)]
rlm@10: ;;     (prlabel wl1 (toks buffer))
rlm@10:      (setf :buffer (into [] buffer))
rlm@10:      (if (not (tokens-fit? this buffer))
rlm@10:        (let [new-buffer (write-token-string this buffer)]
rlm@10: ;;          (prlabel wl new-buffer)
rlm@10:          (if-not (identical? buffer new-buffer)
rlm@10:                  (recur new-buffer)))))))
rlm@10: 
rlm@10: ;;; Add a buffer token to the buffer and see if it's time to start
rlm@10: ;;; writing
rlm@10: (defn- add-to-buffer [^Writer this token]
rlm@10: ;  (prlabel a2b token)
rlm@10:   (dosync
rlm@10:    (setf :buffer (conj (getf :buffer) token))
rlm@10:    (if (not (tokens-fit? this (getf :buffer)))
rlm@10:      (write-line this))))
rlm@10: 
rlm@10: ;;; Write all the tokens that have been buffered
rlm@10: (defn- write-buffered-output [^Writer this]
rlm@10:   (write-line this)
rlm@10:   (if-let [buf (getf :buffer)]
rlm@10:     (do
rlm@10:       (write-tokens this buf true)
rlm@10:       (setf :buffer []))))
rlm@10: 
rlm@10: ;;; If there are newlines in the string, print the lines up until the last newline, 
rlm@10: ;;; making the appropriate adjustments. Return the remainder of the string
rlm@10: (defn- write-initial-lines 
rlm@10:   [^Writer this ^String s] 
rlm@10:   (let [lines (.split s "\n" -1)]
rlm@10:     (if (= (count lines) 1)
rlm@10:       s
rlm@10:       (dosync 
rlm@10:        (let [^String prefix (:per-line-prefix (first (getf :logical-blocks)))
rlm@10:              ^String l (first lines)] 
rlm@10:          (if (= :buffering (getf :mode))
rlm@10:            (let [oldpos (getf :pos)
rlm@10:                  newpos (+ oldpos (count l))]
rlm@10:              (setf :pos newpos)
rlm@10:              (add-to-buffer this (make-buffer-blob l nil oldpos newpos))
rlm@10:              (write-buffered-output this))
rlm@10:            (.write (getf :base) l))
rlm@10:          (.write (getf :base) (int \newline))
rlm@10:          (doseq [^String l (next (butlast lines))]
rlm@10:            (.write (getf :base) l)
rlm@10:            (.write (getf :base) (int \newline))
rlm@10:            (if prefix
rlm@10:              (.write (getf :base) prefix)))
rlm@10:          (setf :buffering :writing)
rlm@10:          (last lines))))))
rlm@10: 
rlm@10: 
rlm@10: (defn- write-white-space [^Writer this]
rlm@10:   (if-let [^String tws (getf :trailing-white-space)]
rlm@10:     (dosync
rlm@10:      (.write (getf :base) tws)
rlm@10:      (setf :trailing-white-space nil))))
rlm@10: 
rlm@10: (defn- p-write-char [^Writer this ^Integer c]
rlm@10:   (if (= (getf :mode) :writing)
rlm@10:     (do 
rlm@10:       (write-white-space this)
rlm@10:       (.write (getf :base) c))
rlm@10:     (if (= c \newline)
rlm@10:       (write-initial-lines this "\n")
rlm@10:       (let [oldpos (getf :pos)
rlm@10:             newpos (inc oldpos)]
rlm@10:         (dosync
rlm@10:          (setf :pos newpos)
rlm@10:          (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos)))))))
rlm@10: 
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;;; Initialize the pretty-writer instance
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: 
rlm@10: (defn- pretty-writer [writer max-columns miser-width]
rlm@10:   (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))
rlm@10:         fields (ref {:pretty-writer true
rlm@10:                      :base (column-writer writer max-columns)
rlm@10:                      :logical-blocks lb 
rlm@10:                      :sections nil
rlm@10:                      :mode :writing
rlm@10:                      :buffer []
rlm@10:                      :buffer-block lb
rlm@10:                      :buffer-level 1
rlm@10:                      :miser-width miser-width
rlm@10:                      :trailing-white-space nil
rlm@10:                      :pos 0})]
rlm@10:     (proxy [Writer IDeref] []
rlm@10:       (deref [] fields)
rlm@10: 
rlm@10:       (write 
rlm@10:        ([x]
rlm@10:           ;;     (prlabel write x (getf :mode))
rlm@10:           (condp = (class x)
rlm@10:             String 
rlm@10:             (let [^String s0 (write-initial-lines this x)
rlm@10:                   ^String s (.replaceFirst s0 "\\s+$" "")
rlm@10:                   white-space (.substring s0 (count s))
rlm@10:                   mode (getf :mode)]
rlm@10:               (dosync
rlm@10:                (if (= mode :writing)
rlm@10:                  (do
rlm@10:                    (write-white-space this)
rlm@10:                    (.write (getf :base) s)
rlm@10:                    (setf :trailing-white-space white-space))
rlm@10:                  (let [oldpos (getf :pos)
rlm@10:                        newpos (+ oldpos (count s0))]
rlm@10:                    (setf :pos newpos)
rlm@10:                    (add-to-buffer this (make-buffer-blob s white-space oldpos newpos))))))
rlm@10: 
rlm@10:             Integer
rlm@10:             (p-write-char this x))))
rlm@10: 
rlm@10:       (flush []
rlm@10:              (if (= (getf :mode) :buffering)
rlm@10:                (dosync 
rlm@10:                 (write-tokens this (getf :buffer) true)
rlm@10:                 (setf :buffer []))
rlm@10:                (write-white-space this)))
rlm@10: 
rlm@10:       (close []
rlm@10:              (.flush this)))))
rlm@10: 
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;;; Methods for pretty-writer
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: (defn- start-block 
rlm@10:   [^Writer this 
rlm@10:    ^String prefix ^String per-line-prefix ^String suffix]
rlm@10:   (dosync 
rlm@10:    (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0)
rlm@10:                     (ref false) (ref false)
rlm@10:                     prefix per-line-prefix suffix)]
rlm@10:      (setf :logical-blocks lb)
rlm@10:      (if (= (getf :mode) :writing)
rlm@10:        (do
rlm@10:          (write-white-space this)
rlm@10:           (when-let [cb (getf :logical-block-callback)] (cb :start))
rlm@10:           (if prefix 
rlm@10:            (.write (getf :base) prefix))
rlm@10:          (let [col (get-column (getf :base))]
rlm@10:            (ref-set (:start-col lb) col)
rlm@10:            (ref-set (:indent lb) col)))
rlm@10:        (let [oldpos (getf :pos)
rlm@10:              newpos (+ oldpos (if prefix (count prefix) 0))]
rlm@10:          (setf :pos newpos)
rlm@10:          (add-to-buffer this (make-start-block-t lb oldpos newpos)))))))
rlm@10: 
rlm@10: (defn- end-block [^Writer this]
rlm@10:   (dosync
rlm@10:    (let [lb (getf :logical-blocks)
rlm@10:          ^String suffix (:suffix lb)]
rlm@10:      (if (= (getf :mode) :writing)
rlm@10:        (do
rlm@10:          (write-white-space this)
rlm@10:          (if suffix
rlm@10:            (.write (getf :base) suffix))
rlm@10:          (when-let [cb (getf :logical-block-callback)] (cb :end)))
rlm@10:        (let [oldpos (getf :pos)
rlm@10:              newpos (+ oldpos (if suffix (count suffix) 0))]
rlm@10:          (setf :pos newpos)
rlm@10:          (add-to-buffer this (make-end-block-t lb oldpos newpos))))
rlm@10:      (setf :logical-blocks (:parent lb)))))
rlm@10: 
rlm@10: (defn- nl [^Writer this type]
rlm@10:   (dosync 
rlm@10:    (setf :mode :buffering)
rlm@10:    (let [pos (getf :pos)]
rlm@10:      (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos)))))
rlm@10: 
rlm@10: (defn- indent [^Writer this relative-to offset]
rlm@10:   (dosync 
rlm@10:    (let [lb (getf :logical-blocks)]
rlm@10:      (if (= (getf :mode) :writing)
rlm@10:        (do
rlm@10:          (write-white-space this)
rlm@10:          (ref-set (:indent lb) 
rlm@10:                   (+ offset (condp = relative-to
rlm@10: 			      :block @(:start-col lb)
rlm@10: 			      :current (get-column (getf :base))))))
rlm@10:        (let [pos (getf :pos)]
rlm@10:          (add-to-buffer this (make-indent-t lb relative-to offset pos pos)))))))
rlm@10: 
rlm@10: (defn- get-miser-width [^Writer this]
rlm@10:   (getf :miser-width))
rlm@10: 
rlm@10: (defn- set-miser-width [^Writer this new-miser-width]
rlm@10:   (dosync (setf :miser-width new-miser-width)))
rlm@10: 
rlm@10: (defn- set-logical-block-callback [^Writer this f]
rlm@10:   (dosync (setf :logical-block-callback f)))