clojure.pprint.pretty_writer.clj Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of clojure Show documentation
Show all versions of clojure Show documentation
Clojure core environment and runtime library.
;;; 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 named by the argument (which should be a keyword)."
[sym]
`(~sym @@~'this))
(defmacro ^{:private true}
setf
"Set the value of the field SYM to NEW-VAL"
[sym 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))))))
(defmacro ^{:private true}
write-to-base
"Call .write on Writer (getf :base) with proper type-hinting to
avoid reflection."
[& args]
`(let [^Writer w# (getf :base)]
(.write w# ~@args)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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-to-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-to-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-to-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-to-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-to-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-to-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-to-base ^String (pp-newline))
(dosync (setf :trailing-white-space nil))
(let [lb (:logical-block nl)
^String prefix (:per-line-prefix lb)]
(if prefix
(write-to-base prefix))
(let [^String istr (apply str (repeat (- @(:indent lb) (count prefix))
\space))]
(write-to-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-to-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-to-base l)))
(write-to-base (int \newline))
(doseq [^String l (next (butlast lines))]
(write-to-base l)
(write-to-base ^String (pp-newline))
(if prefix
(write-to-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-to-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-to-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)))
([x off len]
(.write ^Writer this (subs (str x) off (+ off len)))))
(ppflush []
(if (= (getf :mode) :buffering)
(dosync
(write-tokens this (getf :buffer) true)
(setf :buffer []))
(write-white-space this)))
(flush []
(.ppflush ^PrettyFlush this)
(let [^Writer w (getf :base)]
(.flush w)))
(close []
(.flush ^Writer 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-to-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-to-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)))
© 2015 - 2025 Weber Informatics LLC | Privacy Policy