|
Java example source code file (pretty_writer.clj)
The pretty_writer.clj Java example source code;;; 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 [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)))))) (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))) Other Java examples (source code examples)Here is a short list of links related to this Java pretty_writer.clj source code file: |
... this post is sponsored by my books ... | |
#1 New Release! |
FP Best Seller |
Copyright 1998-2021 Alvin Alexander, alvinalexander.com
All Rights Reserved.
A percentage of advertising revenue from
pages under the /java/jwarehouse
URI on this website is
paid back to open source projects.