  pretty_writer.clj -- part of the pretty printer for Clojure

  by  
  April 3 , 2009
  Revised to use proxy instead of gen - class April 2010

    Copyright ( c )   , Jan 2009 . All rights reserved .
;   The use and distribution terms for this software are covered by the
;   Eclipse Public License 1.0 (-1.0.php)
;   which can be found in the file epl-v10.html at the root of this distribution.
;   By using this software in any fashion, you are agreeing to be bound by
;   the terms of this license.
;   You must not remove this notice, or any other, from this software.

;; This module implements a wrapper around a java.io.Writer which implements the
  core of the XP algorithm .

(ns clojure.contrib.pprint.pretty-writer
  (:refer-clojure :exclude (deftype))
  (:use clojure.contrib.pprint.utilities)
  (:use [clojure.contrib.pprint.column-writer
         :only (column-writer get-column get-max-column)])
  (:import
   [clojure.lang IDeref]
   [java.io Writer]))

;; TODO: Support for tab directives


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Forward declarations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare get-miser-width)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  Macros to simplify dealing with types and classes . These are
;;; really utilities, but I'm experimenting with them here.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro #^{:private true} 
  getf 
  "Get the value of the field a named by the argument (which should be a keyword)."
  [sym]
  `(~sym @@~'this))

(defmacro #^{:private true} 
  setf [sym new-val] 
  "Set the value of the field SYM to NEW-VAL"
  `(alter @~'this assoc ~sym ~new-val))

(defmacro #^{:private true} 
  deftype [type-name & fields]
  (let [name-str (name type-name)]
    `(do
       (defstruct ~type-name :type-tag ~@fields)
       (defn- ~(symbol (str "make-" name-str)) 
         [& vals#] (apply struct ~type-name ~(keyword name-str) vals#))
       (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The data structures used by pretty-writer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct #^{:private true} logical-block
           :parent :section :start-col :indent
           :done-nl :intra-block-nl
           :prefix :per-line-prefix :suffix
           :logical-block-callback)

(defn ancestor? [parent child]
  (loop [child (:parent child)]
    (cond 
     (nil? child) false
     (identical? parent child) true
     :else (recur (:parent child)))))

(defstruct #^{:private true} section :parent)

(defn buffer-length [l] 
  (let [l (seq l)]
    (if l 
      (- (:end-pos (last l)) (:start-pos (first l)))
      0)))

; A blob of characters (aka a string)
(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos)

; A newline
(deftype nl-t :type :logical-block :start-pos :end-pos)

(deftype start-block-t :logical-block :start-pos :end-pos)

(deftype end-block-t :logical-block :start-pos :end-pos)

(deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions to write tokens in the output buffer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare emit-nl)

(defmulti write-token #(:type-tag %2))
(defmethod write-token :start-block-t [#^Writer this token]
   (when-let [cb (getf :logical-block-callback)] (cb :start))
   (let [lb (:logical-block token)]
    (dosync
     (when-let [#^String prefix (:prefix lb)] 
       (.write (getf :base) prefix))
     (let [col (get-column (getf :base))]
       (ref-set (:start-col lb) col)
       (ref-set (:indent lb) col)))))

(defmethod write-token :end-block-t [#^Writer this token]
  (when-let [cb (getf :logical-block-callback)] (cb :end))
  (when-let [#^String suffix (:suffix (:logical-block token))] 
    (.write (getf :base) suffix)))

(defmethod write-token :indent-t [#^Writer this token]
  (let [lb (:logical-block token)]
    (ref-set (:indent lb) 
             (+ (:offset token)
                (condp = (:relative-to token)
		  :block @(:start-col lb)
		  :current (get-column (getf :base)))))))

(defmethod write-token :buffer-blob [#^Writer this token]
  (.write (getf :base) #^String (:data token)))

(defmethod write-token :nl-t [#^Writer this token]
   ( prlabel wt @(:done - nl (: logical - block token ) ) )
;  (prlabel wt (:type token) (= (:type token) :mandatory))
  (if (or (= (:type token) :mandatory)
           (and (not (= (:type token) :fill))
                @(:done-nl (:logical-block token))))
    (emit-nl this token)
    (if-let [#^String tws (getf :trailing-white-space)]
      (.write (getf :base) tws)))
  (dosync (setf :trailing-white-space nil)))

(defn- write-tokens [#^Writer this tokens force-trailing-whitespace]
  (doseq [token tokens]
    (if-not (= (:type-tag token) :nl-t)
      (if-let [#^String tws (getf :trailing-white-space)]
	(.write (getf :base) tws)))
    (write-token this token)
    (setf :trailing-white-space (:trailing-white-space token)))
  (let [#^String tws (getf :trailing-white-space)] 
    (when (and force-trailing-whitespace tws)
      (.write (getf :base) tws)
      (setf :trailing-white-space nil))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; emit-nl? method defs for each type of new line. This makes
;;; the decision about whether to print this type of new line.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defn- tokens-fit? [#^Writer this tokens]
   ( prlabel tf ? ( get - column ( getf : base ) ( buffer - length tokens ) )
  (let [maxcol (get-max-column (getf :base))]
    (or 
     (nil? maxcol) 
     (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol))))

(defn- linear-nl? [this lb section]
;  (prlabel lnl? @(:done-nl lb) (tokens-fit? this section))
  (or @(:done-nl lb)
      (not (tokens-fit? this section))))

(defn- miser-nl? [#^Writer this lb section]
  (let [miser-width (get-miser-width this)
        maxcol (get-max-column (getf :base))]
    (and miser-width maxcol
         (>= @(:start-col lb) (- maxcol miser-width))
         (linear-nl? this lb section))))

(defmulti emit-nl? (fn [t _ _ _] (:type t)))

(defmethod emit-nl? :linear [newl this section _]
  (let [lb (:logical-block newl)]
    (linear-nl? this lb section)))

(defmethod emit-nl? :miser [newl this section _]
  (let [lb (:logical-block newl)]
    (miser-nl? this lb section)))

(defmethod emit-nl? :fill [newl this section subsection]
  (let [lb (:logical-block newl)]
    (or @(:intra-block-nl lb)
        (not (tokens-fit? this subsection))
        (miser-nl? this lb section))))

(defmethod emit-nl? :mandatory [_ _ _ _]
  true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Various support functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defn- get-section [buffer]
  (let [nl (first buffer) 
        lb (:logical-block nl)
        section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb)))
                                 (next buffer)))]
    [section (seq (drop (inc (count section)) buffer))])) 

(defn- get-sub-section [buffer]
  (let [nl (first buffer) 
        lb (:logical-block nl)
        section (seq (take-while #(let [nl-lb (:logical-block %)]
                                    (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb)))))
                            (next buffer)))]
    section)) 

(defn- update-nl-state [lb]
  (dosync
   (ref-set (:intra-block-nl lb) false)
   (ref-set (:done-nl lb) true)
   (loop [lb (:parent lb)]
     (if lb
       (do (ref-set (:done-nl lb) true)
           (ref-set (:intra-block-nl lb) true)
           (recur (:parent lb)))))))

(defn emit-nl [#^Writer this nl]
  (.write (getf :base) (int \newline))
  (dosync (setf :trailing-white-space nil))
  (let [lb (:logical-block nl)
        #^String prefix (:per-line-prefix lb)] 
    (if prefix 
      (.write (getf :base) prefix))
    (let [#^String istr (apply str (repeat (- @(:indent lb) (count prefix))
					  \space))] 
      (.write (getf :base) istr))
    (update-nl-state lb)))

(defn- split-at-newline [tokens]
  (let [pre (seq (take-while #(not (nl-t? %)) tokens))]
    [pre (seq (drop (count pre) tokens))]))

;;; Methods for showing token strings for debugging

(defmulti tok :type-tag)
(defmethod tok :nl-t [token]
  (:type token))
(defmethod tok :buffer-blob [token]
  (str \" (:data token) (:trailing-white-space token) \"))
(defmethod tok :default [token]
  (:type-tag token))
(defn toks [toks] (map tok toks))

;;; write-token-string is called when the set of tokens in the buffer
;;; is longer than the available space on the line

(defn- write-token-string [this tokens]
  (let [[a b] (split-at-newline tokens)]
     ( prlabel wts ( toks a ) ( toks b ) )
    (if a (write-tokens this a false))
    (if b
      (let [[section remainder] (get-section b)
            newl (first b)]
          ( prlabel wts ( toks section ) ) ( prlabel wts (:   ) ) ( prlabel wts ( toks remainder ) )
        (let [do-nl (emit-nl? newl this section (get-sub-section b))
              result (if do-nl 
                       (do
                           ( prlabel emit - nl (:   ) )
                         (emit-nl this newl)
                         (next b))
                       b)
              long-section (not (tokens-fit? this result))
              result (if long-section
                       (let [rem2 (write-token-string this section)]
                               ( prlabel recurse ( toks rem2 ) )
                         (if (= rem2 section)
  If that did n't produce any output , it has no nls
                                        ; so we'll force it
                             (write-tokens this section false)
                             remainder)
                           (into [] (concat rem2 remainder))))
                       result)
               ff ( prlabel wts ( toks result ) )
              ] 
          result)))))

(defn- write-line [#^Writer this]
  (dosync
   (loop [buffer (getf :buffer)]
;;     (prlabel wl1 (toks buffer))
     (setf :buffer (into [] buffer))
     (if (not (tokens-fit? this buffer))
       (let [new-buffer (write-token-string this buffer)]
;;          (prlabel wl new-buffer)
         (if-not (identical? buffer new-buffer)
                 (recur new-buffer)))))))

;;; Add a buffer token to the buffer and see if it's time to start
;;; writing
(defn- add-to-buffer [#^Writer this token]
;  (prlabel a2b token)
  (dosync
   (setf :buffer (conj (getf :buffer) token))
   (if (not (tokens-fit? this (getf :buffer)))
     (write-line this))))

;;; Write all the tokens that have been buffered
(defn- write-buffered-output [#^Writer this]
  (write-line this)
  (if-let [buf (getf :buffer)]
    (do
      (write-tokens this buf true)
      (setf :buffer []))))

;;; If there are newlines in the string, print the lines up until the last newline, 
;;; making the appropriate adjustments. Return the remainder of the string
(defn- write-initial-lines 
  [#^Writer this #^String s] 
  (let [lines (.split s "\n" -1)]
    (if (= (count lines) 1)
      s
      (dosync 
       (let [#^String prefix (:per-line-prefix (first (getf :logical-blocks)))
             #^String l (first lines)] 
         (if (= :buffering (getf :mode))
           (let [oldpos (getf :pos)
                 newpos (+ oldpos (count l))]
             (setf :pos newpos)
             (add-to-buffer this (make-buffer-blob l nil oldpos newpos))
             (write-buffered-output this))
           (.write (getf :base) l))
         (.write (getf :base) (int \newline))
         (doseq [#^String l (next (butlast lines))]
           (.write (getf :base) l)
           (.write (getf :base) (int \newline))
           (if prefix
             (.write (getf :base) prefix)))
         (setf :buffering :writing)
         (last lines))))))


(defn write-white-space [#^Writer this]
  (if-let [#^String tws (getf :trailing-white-space)]
    (dosync
     (.write (getf :base) tws)
     (setf :trailing-white-space nil))))

(defn- write-char [#^Writer this #^Integer c]
  (if (= (getf :mode) :writing)
    (do 
      (write-white-space this)
      (.write (getf :base) c))
    (if (= c \newline)
      (write-initial-lines this "\n")
      (let [oldpos (getf :pos)
            newpos (inc oldpos)]
        (dosync
         (setf :pos newpos)
         (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  Initialize the pretty - writer instance
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defn pretty-writer [writer max-columns miser-width]
  (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))
        fields (ref {:pretty-writer true
                     :base (column-writer writer max-columns)
                     :logical-blocks lb 
                     :sections nil
                     :mode :writing
                     :buffer []
                     :buffer-block lb
                     :buffer-level 1
                     :miser-width miser-width
                     :trailing-white-space nil
                     :pos 0})]
    (proxy [Writer IDeref] []
      (deref [] fields)

      (write 
       ([x]
      ( prlabel write x ( getf : mode ) )
          (condp = (class x)
            String 
            (let [#^String s0 (write-initial-lines this x)
                  #^String s (.replaceFirst s0 "\\s+$" "")
                  white-space (.substring s0 (count s))
                  mode (getf :mode)]
              (dosync
               (if (= mode :writing)
                 (do
                   (write-white-space this)
                   (.write (getf :base) s)
                   (setf :trailing-white-space white-space))
                 (let [oldpos (getf :pos)
                       newpos (+ oldpos (count s0))]
                   (setf :pos newpos)
                   (add-to-buffer this (make-buffer-blob s white-space oldpos newpos))))))

            Integer
            (write-char this x)
            Long
            (write-char this x))))

      (flush []
             (if (= (getf :mode) :buffering)
               (dosync 
                (write-tokens this (getf :buffer) true)
                (setf :buffer []))
               (write-white-space this)))

      (close []
             (.flush this)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Methods for pretty-writer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn start-block 
  [#^Writer this 
   #^String prefix #^String per-line-prefix #^String suffix]
  (dosync 
   (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0)
                    (ref false) (ref false)
                    prefix per-line-prefix suffix)]
     (setf :logical-blocks lb)
     (if (= (getf :mode) :writing)
       (do
         (write-white-space this)
          (when-let [cb (getf :logical-block-callback)] (cb :start))
          (if prefix 
           (.write (getf :base) prefix))
         (let [col (get-column (getf :base))]
           (ref-set (:start-col lb) col)
           (ref-set (:indent lb) col)))
       (let [oldpos (getf :pos)
             newpos (+ oldpos (if prefix (count prefix) 0))]
         (setf :pos newpos)
         (add-to-buffer this (make-start-block-t lb oldpos newpos)))))))

(defn end-block [#^Writer this]
  (dosync
   (let [lb (getf :logical-blocks)
         #^String suffix (:suffix lb)]
     (if (= (getf :mode) :writing)
       (do
         (write-white-space this)
         (if suffix
           (.write (getf :base) suffix))
         (when-let [cb (getf :logical-block-callback)] (cb :end)))
       (let [oldpos (getf :pos)
             newpos (+ oldpos (if suffix (count suffix) 0))]
         (setf :pos newpos)
         (add-to-buffer this (make-end-block-t lb oldpos newpos))))
     (setf :logical-blocks (:parent lb)))))

(defn nl [#^Writer this type]
  (dosync 
   (setf :mode :buffering)
   (let [pos (getf :pos)]
     (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos)))))

(defn indent [#^Writer this relative-to offset]
  (dosync 
   (let [lb (getf :logical-blocks)]
     (if (= (getf :mode) :writing)
       (do
         (write-white-space this)
         (ref-set (:indent lb) 
                  (+ offset (condp = relative-to
			      :block @(:start-col lb)
			      :current (get-column (getf :base))))))
       (let [pos (getf :pos)]
         (add-to-buffer this (make-indent-t lb relative-to offset pos pos)))))))

(defn get-miser-width [#^Writer this]
  (getf :miser-width))

(defn set-miser-width [#^Writer this new-miser-width]
  (dosync (setf :miser-width new-miser-width)))

(defn set-logical-block-callback [#^Writer this f]
  (dosync (setf :logical-block-callback f)))

   The use and distribution terms for this software are covered by the
   Eclipse Public License 1.0 (-1.0.php)
   which can be found in the file epl-v10.html at the root of this distribution.
   By using this software in any fashion, you are agreeing to be bound by
   the terms of this license.
   You must not remove this notice, or any other, from this software.
 This module implements a wrapper around a java.io.Writer which implements the
 TODO: Support for tab directives

 Forward declarations


 really utilities, but I'm experimenting with them here.


 The data structures used by pretty-writer

 A blob of characters (aka a string)
 A newline

 Functions to write tokens in the output buffer

  (prlabel wt (:type token) (= (:type token) :mandatory))

 emit-nl? method defs for each type of new line. This makes
 the decision about whether to print this type of new line.

  (prlabel lnl? @(:done-nl lb) (tokens-fit? this section))

 Various support functions

 Methods for showing token strings for debugging
 write-token-string is called when the set of tokens in the buffer
 is longer than the available space on the line
 so we'll force it
     (prlabel wl1 (toks buffer))
          (prlabel wl new-buffer)
 Add a buffer token to the buffer and see if it's time to start
 writing
  (prlabel a2b token)
 Write all the tokens that have been buffered
 If there are newlines in the string, print the lines up until the last newline, 
 making the appropriate adjustments. Return the remainder of the string



 Methods for pretty-writer

  pretty_writer.clj -- part of the pretty printer for Clojure

  by  
  April 3 , 2009
  Revised to use proxy instead of gen - class April 2010

    Copyright ( c )   , Jan 2009 . All rights reserved .

  core of the XP algorithm .

(ns clojure.contrib.pprint.pretty-writer
  (:refer-clojure :exclude (deftype))
  (:use clojure.contrib.pprint.utilities)
  (:use [clojure.contrib.pprint.column-writer
         :only (column-writer get-column get-max-column)])
  (:import
   [clojure.lang IDeref]
   [java.io Writer]))




(declare get-miser-width)

  Macros to simplify dealing with types and classes . These are

(defmacro #^{:private true} 
  getf 
  "Get the value of the field a named by the argument (which should be a keyword)."
  [sym]
  `(~sym @@~'this))

(defmacro #^{:private true} 
  setf [sym new-val] 
  "Set the value of the field SYM to NEW-VAL"
  `(alter @~'this assoc ~sym ~new-val))

(defmacro #^{:private true} 
  deftype [type-name & fields]
  (let [name-str (name type-name)]
    `(do
       (defstruct ~type-name :type-tag ~@fields)
       (defn- ~(symbol (str "make-" name-str)) 
         [& vals#] (apply struct ~type-name ~(keyword name-str) vals#))
       (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str))))))


(defstruct #^{:private true} logical-block
           :parent :section :start-col :indent
           :done-nl :intra-block-nl
           :prefix :per-line-prefix :suffix
           :logical-block-callback)

(defn ancestor? [parent child]
  (loop [child (:parent child)]
    (cond 
     (nil? child) false
     (identical? parent child) true
     :else (recur (:parent child)))))

(defstruct #^{:private true} section :parent)

(defn buffer-length [l] 
  (let [l (seq l)]
    (if l 
      (- (:end-pos (last l)) (:start-pos (first l)))
      0)))

(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos)

(deftype nl-t :type :logical-block :start-pos :end-pos)

(deftype start-block-t :logical-block :start-pos :end-pos)

(deftype end-block-t :logical-block :start-pos :end-pos)

(deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos)


(declare emit-nl)

(defmulti write-token #(:type-tag %2))
(defmethod write-token :start-block-t [#^Writer this token]
   (when-let [cb (getf :logical-block-callback)] (cb :start))
   (let [lb (:logical-block token)]
    (dosync
     (when-let [#^String prefix (:prefix lb)] 
       (.write (getf :base) prefix))
     (let [col (get-column (getf :base))]
       (ref-set (:start-col lb) col)
       (ref-set (:indent lb) col)))))

(defmethod write-token :end-block-t [#^Writer this token]
  (when-let [cb (getf :logical-block-callback)] (cb :end))
  (when-let [#^String suffix (:suffix (:logical-block token))] 
    (.write (getf :base) suffix)))

(defmethod write-token :indent-t [#^Writer this token]
  (let [lb (:logical-block token)]
    (ref-set (:indent lb) 
             (+ (:offset token)
                (condp = (:relative-to token)
		  :block @(:start-col lb)
		  :current (get-column (getf :base)))))))

(defmethod write-token :buffer-blob [#^Writer this token]
  (.write (getf :base) #^String (:data token)))

(defmethod write-token :nl-t [#^Writer this token]
   ( prlabel wt @(:done - nl (: logical - block token ) ) )
  (if (or (= (:type token) :mandatory)
           (and (not (= (:type token) :fill))
                @(:done-nl (:logical-block token))))
    (emit-nl this token)
    (if-let [#^String tws (getf :trailing-white-space)]
      (.write (getf :base) tws)))
  (dosync (setf :trailing-white-space nil)))

(defn- write-tokens [#^Writer this tokens force-trailing-whitespace]
  (doseq [token tokens]
    (if-not (= (:type-tag token) :nl-t)
      (if-let [#^String tws (getf :trailing-white-space)]
	(.write (getf :base) tws)))
    (write-token this token)
    (setf :trailing-white-space (:trailing-white-space token)))
  (let [#^String tws (getf :trailing-white-space)] 
    (when (and force-trailing-whitespace tws)
      (.write (getf :base) tws)
      (setf :trailing-white-space nil))))



(defn- tokens-fit? [#^Writer this tokens]
   ( prlabel tf ? ( get - column ( getf : base ) ( buffer - length tokens ) )
  (let [maxcol (get-max-column (getf :base))]
    (or 
     (nil? maxcol) 
     (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol))))

(defn- linear-nl? [this lb section]
  (or @(:done-nl lb)
      (not (tokens-fit? this section))))

(defn- miser-nl? [#^Writer this lb section]
  (let [miser-width (get-miser-width this)
        maxcol (get-max-column (getf :base))]
    (and miser-width maxcol
         (>= @(:start-col lb) (- maxcol miser-width))
         (linear-nl? this lb section))))

(defmulti emit-nl? (fn [t _ _ _] (:type t)))

(defmethod emit-nl? :linear [newl this section _]
  (let [lb (:logical-block newl)]
    (linear-nl? this lb section)))

(defmethod emit-nl? :miser [newl this section _]
  (let [lb (:logical-block newl)]
    (miser-nl? this lb section)))

(defmethod emit-nl? :fill [newl this section subsection]
  (let [lb (:logical-block newl)]
    (or @(:intra-block-nl lb)
        (not (tokens-fit? this subsection))
        (miser-nl? this lb section))))

(defmethod emit-nl? :mandatory [_ _ _ _]
  true)



(defn- get-section [buffer]
  (let [nl (first buffer) 
        lb (:logical-block nl)
        section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb)))
                                 (next buffer)))]
    [section (seq (drop (inc (count section)) buffer))])) 

(defn- get-sub-section [buffer]
  (let [nl (first buffer) 
        lb (:logical-block nl)
        section (seq (take-while #(let [nl-lb (:logical-block %)]
                                    (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb)))))
                            (next buffer)))]
    section)) 

(defn- update-nl-state [lb]
  (dosync
   (ref-set (:intra-block-nl lb) false)
   (ref-set (:done-nl lb) true)
   (loop [lb (:parent lb)]
     (if lb
       (do (ref-set (:done-nl lb) true)
           (ref-set (:intra-block-nl lb) true)
           (recur (:parent lb)))))))

(defn emit-nl [#^Writer this nl]
  (.write (getf :base) (int \newline))
  (dosync (setf :trailing-white-space nil))
  (let [lb (:logical-block nl)
        #^String prefix (:per-line-prefix lb)] 
    (if prefix 
      (.write (getf :base) prefix))
    (let [#^String istr (apply str (repeat (- @(:indent lb) (count prefix))
					  \space))] 
      (.write (getf :base) istr))
    (update-nl-state lb)))

(defn- split-at-newline [tokens]
  (let [pre (seq (take-while #(not (nl-t? %)) tokens))]
    [pre (seq (drop (count pre) tokens))]))


(defmulti tok :type-tag)
(defmethod tok :nl-t [token]
  (:type token))
(defmethod tok :buffer-blob [token]
  (str \" (:data token) (:trailing-white-space token) \"))
(defmethod tok :default [token]
  (:type-tag token))
(defn toks [toks] (map tok toks))


(defn- write-token-string [this tokens]
  (let [[a b] (split-at-newline tokens)]
     ( prlabel wts ( toks a ) ( toks b ) )
    (if a (write-tokens this a false))
    (if b
      (let [[section remainder] (get-section b)
            newl (first b)]
          ( prlabel wts ( toks section ) ) ( prlabel wts (:   ) ) ( prlabel wts ( toks remainder ) )
        (let [do-nl (emit-nl? newl this section (get-sub-section b))
              result (if do-nl 
                       (do
                           ( prlabel emit - nl (:   ) )
                         (emit-nl this newl)
                         (next b))
                       b)
              long-section (not (tokens-fit? this result))
              result (if long-section
                       (let [rem2 (write-token-string this section)]
                               ( prlabel recurse ( toks rem2 ) )
                         (if (= rem2 section)
  If that did n't produce any output , it has no nls
                             (write-tokens this section false)
                             remainder)
                           (into [] (concat rem2 remainder))))
                       result)
               ff ( prlabel wts ( toks result ) )
              ] 
          result)))))

(defn- write-line [#^Writer this]
  (dosync
   (loop [buffer (getf :buffer)]
     (setf :buffer (into [] buffer))
     (if (not (tokens-fit? this buffer))
       (let [new-buffer (write-token-string this buffer)]
         (if-not (identical? buffer new-buffer)
                 (recur new-buffer)))))))

(defn- add-to-buffer [#^Writer this token]
  (dosync
   (setf :buffer (conj (getf :buffer) token))
   (if (not (tokens-fit? this (getf :buffer)))
     (write-line this))))

(defn- write-buffered-output [#^Writer this]
  (write-line this)
  (if-let [buf (getf :buffer)]
    (do
      (write-tokens this buf true)
      (setf :buffer []))))

(defn- write-initial-lines 
  [#^Writer this #^String s] 
  (let [lines (.split s "\n" -1)]
    (if (= (count lines) 1)
      s
      (dosync 
       (let [#^String prefix (:per-line-prefix (first (getf :logical-blocks)))
             #^String l (first lines)] 
         (if (= :buffering (getf :mode))
           (let [oldpos (getf :pos)
                 newpos (+ oldpos (count l))]
             (setf :pos newpos)
             (add-to-buffer this (make-buffer-blob l nil oldpos newpos))
             (write-buffered-output this))
           (.write (getf :base) l))
         (.write (getf :base) (int \newline))
         (doseq [#^String l (next (butlast lines))]
           (.write (getf :base) l)
           (.write (getf :base) (int \newline))
           (if prefix
             (.write (getf :base) prefix)))
         (setf :buffering :writing)
         (last lines))))))


(defn write-white-space [#^Writer this]
  (if-let [#^String tws (getf :trailing-white-space)]
    (dosync
     (.write (getf :base) tws)
     (setf :trailing-white-space nil))))

(defn- write-char [#^Writer this #^Integer c]
  (if (= (getf :mode) :writing)
    (do 
      (write-white-space this)
      (.write (getf :base) c))
    (if (= c \newline)
      (write-initial-lines this "\n")
      (let [oldpos (getf :pos)
            newpos (inc oldpos)]
        (dosync
         (setf :pos newpos)
         (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos)))))))


  Initialize the pretty - writer instance


(defn pretty-writer [writer max-columns miser-width]
  (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))
        fields (ref {:pretty-writer true
                     :base (column-writer writer max-columns)
                     :logical-blocks lb 
                     :sections nil
                     :mode :writing
                     :buffer []
                     :buffer-block lb
                     :buffer-level 1
                     :miser-width miser-width
                     :trailing-white-space nil
                     :pos 0})]
    (proxy [Writer IDeref] []
      (deref [] fields)

      (write 
       ([x]
      ( prlabel write x ( getf : mode ) )
          (condp = (class x)
            String 
            (let [#^String s0 (write-initial-lines this x)
                  #^String s (.replaceFirst s0 "\\s+$" "")
                  white-space (.substring s0 (count s))
                  mode (getf :mode)]
              (dosync
               (if (= mode :writing)
                 (do
                   (write-white-space this)
                   (.write (getf :base) s)
                   (setf :trailing-white-space white-space))
                 (let [oldpos (getf :pos)
                       newpos (+ oldpos (count s0))]
                   (setf :pos newpos)
                   (add-to-buffer this (make-buffer-blob s white-space oldpos newpos))))))

            Integer
            (write-char this x)
            Long
            (write-char this x))))

      (flush []
             (if (= (getf :mode) :buffering)
               (dosync 
                (write-tokens this (getf :buffer) true)
                (setf :buffer []))
               (write-white-space this)))

      (close []
             (.flush this)))))



(defn start-block 
  [#^Writer this 
   #^String prefix #^String per-line-prefix #^String suffix]
  (dosync 
   (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0)
                    (ref false) (ref false)
                    prefix per-line-prefix suffix)]
     (setf :logical-blocks lb)
     (if (= (getf :mode) :writing)
       (do
         (write-white-space this)
          (when-let [cb (getf :logical-block-callback)] (cb :start))
          (if prefix 
           (.write (getf :base) prefix))
         (let [col (get-column (getf :base))]
           (ref-set (:start-col lb) col)
           (ref-set (:indent lb) col)))
       (let [oldpos (getf :pos)
             newpos (+ oldpos (if prefix (count prefix) 0))]
         (setf :pos newpos)
         (add-to-buffer this (make-start-block-t lb oldpos newpos)))))))

(defn end-block [#^Writer this]
  (dosync
   (let [lb (getf :logical-blocks)
         #^String suffix (:suffix lb)]
     (if (= (getf :mode) :writing)
       (do
         (write-white-space this)
         (if suffix
           (.write (getf :base) suffix))
         (when-let [cb (getf :logical-block-callback)] (cb :end)))
       (let [oldpos (getf :pos)
             newpos (+ oldpos (if suffix (count suffix) 0))]
         (setf :pos newpos)
         (add-to-buffer this (make-end-block-t lb oldpos newpos))))
     (setf :logical-blocks (:parent lb)))))

(defn nl [#^Writer this type]
  (dosync 
   (setf :mode :buffering)
   (let [pos (getf :pos)]
     (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos)))))

(defn indent [#^Writer this relative-to offset]
  (dosync 
   (let [lb (getf :logical-blocks)]
     (if (= (getf :mode) :writing)
       (do
         (write-white-space this)
         (ref-set (:indent lb) 
                  (+ offset (condp = relative-to
			      :block @(:start-col lb)
			      :current (get-column (getf :base))))))
       (let [pos (getf :pos)]
         (add-to-buffer this (make-indent-t lb relative-to offset pos pos)))))))

(defn get-miser-width [#^Writer this]
  (getf :miser-width))

(defn set-miser-width [#^Writer this new-miser-width]
  (dosync (setf :miser-width new-miser-width)))

(defn set-logical-block-callback [#^Writer this f]
  (dosync (setf :logical-block-callback f)))
