path: root/src/clojure/contrib/pprint/PrettyWriter.clj

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

;; by Tom Faulhaber
;; April 3, 2009

;   Copyright (c) Tom Faulhaber, Jan 2009. 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.

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

(ns clojure.contrib.pprint.PrettyWriter
  (:use clojure.contrib.pprint.utilities)
  (:gen-class
   :extends clojure.contrib.pprint.ColumnWriter
   :init init
   :constructors {[java.io.Writer Integer Object] [java.io.Writer Integer]}
   :methods [[startBlock [String String String] void]
             [endBlock [] void]
             [newline [clojure.lang.Keyword] void]
             [indent [clojure.lang.Keyword Integer] void]
             [getMiserWidth [] Object]
             [setMiserWidth [Object] void]
             [setLogicalBlockCallback [clojure.lang.IFn] void]]
   :exposes-methods {write col-write}
   :state pwstate))

;; TODO: Support for tab directives

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 @(.pwstate ~'this)))

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

(defmacro 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 PrettyWriter
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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 :type :logical-block :start-pos :end-pos)

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

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

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Initialize the PrettyWriter instance
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- -init 
  [writer max-columns miser-width]
  [[writer max-columns] 
   (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))]
     (ref {:logical-blocks lb 
           :sections nil
           :mode :writing
           :buffer []
           :buffer-block lb
           :buffer-level 1
           :miser-width miser-width
           :trailing-white-space nil
           :pos 0}))])

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

(declare emit-nl)

(defmulti write-token #(:type-tag %2))
(defmethod write-token :start-block [#^clojure.contrib.pprint.PrettyWriter this token]
   (when-let [cb (getf :logical-block-callback)] (cb :start))
   (let [lb (:logical-block token)]
    (dosync
     (when-let [#^String prefix (:prefix lb)] 
       (.col-write this prefix))
     (let [col (.getColumn this)]
       (ref-set (:start-col lb) col)
       (ref-set (:indent lb) col)))))

(defmethod write-token :end-block [#^clojure.contrib.pprint.PrettyWriter this token]
  (when-let [cb (getf :logical-block-callback)] (cb :end))
  (when-let [#^String suffix (:suffix (:logical-block token))] 
    (.col-write this suffix)))

(defmethod write-token :indent [#^clojure.contrib.pprint.PrettyWriter this token]
  (let [lb (:logical-block token)]
    (ref-set (:indent lb) 
             (+ (:offset token)
                (condp = (:relative-to token)
		  :block @(:start-col lb)
		  :current (.getColumn this))))))

(defmethod write-token :buffer-blob [#^clojure.contrib.pprint.PrettyWriter this token]
  (.col-write this #^String (:data token)))

(defmethod write-token :nl [#^clojure.contrib.pprint.PrettyWriter 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)]
      (.col-write this tws)))
  (dosync (setf :trailing-white-space nil)))

(defn- write-tokens [#^clojure.contrib.pprint.PrettyWriter this tokens force-trailing-whitespace]
  (doseq [token tokens]
    (if-not (= (:type-tag token) :nl)
      (if-let [#^String tws (getf :trailing-white-space)]
	(.col-write this 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)
      (.col-write this 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? [#^clojure.contrib.pprint.PrettyWriter this tokens]
;;;  (prlabel tf? (.getColumn this) (buffer-length tokens))
  (let [maxcol (.getMaxColumn this)]
    (or 
     (nil? maxcol) 
     (< (+ (.getColumn this) (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? [#^clojure.contrib.pprint.PrettyWriter this lb section]
  (let [miser-width (.getMiserWidth this)
        maxcol (.getMaxColumn this)]
    (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?