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

;   Copyright (c) Rich Hickey. All rights reserved.
;   The use and distribution terms for this software are covered by the
;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-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.

;; Author: Tom Faulhaber
;; April 3, 2009
;; Revised to use proxy instead of gen-class April 2010

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

(in-ns 'clojure.pprint)

(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)
       (alter-meta! #'~type-name assoc :private true)
       (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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def ^:private pp-newline (memoize #(System/getProperty "line.separator")))

(declare emit-nl)

(defmulti ^{:private true} 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 ^{:private true} 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) (pp-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 ^{:private true} 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 (:type newl)) (prlabel wts (toks remainder)) 
        (let [do-nl (emit-nl? newl this section (get-sub-section b))
              result (if do-nl 
                       (do
;;                          (prlabel emit-nl (:type newl))
                         (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)
                           (do ; If that didn'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 []))))

(defn- write-white-space [^Writer this]
  (when-let [^String tws (getf :trailing-white-space)]
    ; (prlabel wws (str "*" tws "*"))
    (.write (getf :base) tws)
    (dosync
     (setf :trailing-white-space nil))))

;;; 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))
           (do
             (write-white-space this)
             (.write (getf :base) l)))
         (.write (getf :base) (int \newline))
         (doseq [^String l (next (butlast lines))]
           (.write (getf :base) l)
           (.write (getf :base) (pp-newline))
           (if prefix
             (.write (getf :base) prefix)))
         (setf :buffering :writing)
         (last lines))))))


(defn- p-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 PrettyFlush] []
      (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
            (p-write-char this x)
            Long
            (p-write-char this x))))

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

      (flush []
             (.ppflush this)
             (.flush (getf :base)))

      (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)))
