Mercurial > lasercutter

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

     2 

     3 ;; by Tom Faulhaber

     4 ;; April 3, 2009

     5 ;; Revised to use proxy instead of gen-class April 2010

     6 

     7 ;   Copyright (c) Tom Faulhaber, Jan 2009. All rights reserved.

     8 ;   The use and distribution terms for this software are covered by the

     9 ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)

    10 ;   which can be found in the file epl-v10.html at the root of this distribution.

    11 ;   By using this software in any fashion, you are agreeing to be bound by

    12 ;   the terms of this license.

    13 ;   You must not remove this notice, or any other, from this software.

    14 

    15 ;; This module implements a wrapper around a java.io.Writer which implements the

    16 ;; core of the XP algorithm.

    17 

    18 (ns clojure.contrib.pprint.pretty-writer

    19   (:refer-clojure :exclude (deftype))

    20   (:use clojure.contrib.pprint.utilities)

    21   (:use [clojure.contrib.pprint.column-writer

    22          :only (column-writer get-column get-max-column)])

    23   (:import

    24    [clojure.lang IDeref]

    25    [java.io Writer]))

    26 

    27 ;; TODO: Support for tab directives

    28 

    29 

    30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    31 ;;; Forward declarations

    32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    33 

    34 (declare get-miser-width)

    35 

    36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    37 ;;; Macros to simplify dealing with types and classes. These are

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

    39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    40 

    41 (defmacro ^{:private true} 

    42   getf 

    43   "Get the value of the field a named by the argument (which should be a keyword)."

    44   [sym]

    45   `(~sym @@~'this))

    46 

    47 (defmacro ^{:private true} 

    48   setf [sym new-val] 

    49   "Set the value of the field SYM to NEW-VAL"

    50   `(alter @~'this assoc ~sym ~new-val))

    51 

    52 (defmacro ^{:private true} 

    53   deftype [type-name & fields]

    54   (let [name-str (name type-name)]

    55     `(do

    56        (defstruct ~type-name :type-tag ~@fields)

    57        (defn- ~(symbol (str "make-" name-str)) 

    58          [& vals#] (apply struct ~type-name ~(keyword name-str) vals#))

    59        (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str))))))

    60 

    61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

    63 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    64 

    65 (defstruct ^{:private true} logical-block

    66            :parent :section :start-col :indent

    67            :done-nl :intra-block-nl

    68            :prefix :per-line-prefix :suffix

    69            :logical-block-callback)

    70 

    71 (defn ancestor? [parent child]

    72   (loop [child (:parent child)]

    73     (cond 

    74      (nil? child) false

    75      (identical? parent child) true

    76      :else (recur (:parent child)))))

    77 

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

    79 

    80 (defn buffer-length [l] 

    81   (let [l (seq l)]

    82     (if l 

    83       (- (:end-pos (last l)) (:start-pos (first l)))

    84       0)))

    85 

    86 ; A blob of characters (aka a string)

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

    88 

    89 ; A newline

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

    91 

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

    93 

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

    95 

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

    97 

    98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

   100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   101 

   102 (declare emit-nl)

   103 

   104 (defmulti write-token #(:type-tag %2))

   105 (defmethod write-token :start-block-t [^Writer this token]

   106    (when-let [cb (getf :logical-block-callback)] (cb :start))

   107    (let [lb (:logical-block token)]

   108     (dosync

   109      (when-let [^String prefix (:prefix lb)] 

   110        (.write (getf :base) prefix))

   111      (let [col (get-column (getf :base))]

   112        (ref-set (:start-col lb) col)

   113        (ref-set (:indent lb) col)))))

   114 

   115 (defmethod write-token :end-block-t [^Writer this token]

   116   (when-let [cb (getf :logical-block-callback)] (cb :end))

   117   (when-let [^String suffix (:suffix (:logical-block token))] 

   118     (.write (getf :base) suffix)))

   119 

   120 (defmethod write-token :indent-t [^Writer this token]

   121   (let [lb (:logical-block token)]

   122     (ref-set (:indent lb) 

   123              (+ (:offset token)

   124                 (condp = (:relative-to token)

   125 		  :block @(:start-col lb)

   126 		  :current (get-column (getf :base)))))))

   127 

   128 (defmethod write-token :buffer-blob [^Writer this token]

   129   (.write (getf :base) ^String (:data token)))

   130 

   131 (defmethod write-token :nl-t [^Writer this token]

   132 ;  (prlabel wt @(:done-nl (:logical-block token)))

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

   134   (if (or (= (:type token) :mandatory)

   135            (and (not (= (:type token) :fill))

   136                 @(:done-nl (:logical-block token))))

   137     (emit-nl this token)

   138     (if-let [^String tws (getf :trailing-white-space)]

   139       (.write (getf :base) tws)))

   140   (dosync (setf :trailing-white-space nil)))

   141 

   142 (defn- write-tokens [^Writer this tokens force-trailing-whitespace]

   143   (doseq [token tokens]

   144     (if-not (= (:type-tag token) :nl-t)

   145       (if-let [^String tws (getf :trailing-white-space)]

   146 	(.write (getf :base) tws)))

   147     (write-token this token)

   148     (setf :trailing-white-space (:trailing-white-space token)))

   149   (let [^String tws (getf :trailing-white-space)] 

   150     (when (and force-trailing-whitespace tws)

   151       (.write (getf :base) tws)

   152       (setf :trailing-white-space nil))))

   153 

   154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   155 ;;; emit-nl? method defs for each type of new line. This makes

   156 ;;; the decision about whether to print this type of new line.

   157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   158 

   159 

   160 (defn- tokens-fit? [^Writer this tokens]

   161 ;;;  (prlabel tf? (get-column (getf :base) (buffer-length tokens))

   162   (let [maxcol (get-max-column (getf :base))]

   163     (or 

   164      (nil? maxcol) 

   165      (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol))))

   166 

   167 (defn- linear-nl? [this lb section]

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

   169   (or @(:done-nl lb)

   170       (not (tokens-fit? this section))))

   171 

   172 (defn- miser-nl? [^Writer this lb section]

   173   (let [miser-width (get-miser-width this)

   174         maxcol (get-max-column (getf :base))]

   175     (and miser-width maxcol

   176          (>= @(:start-col lb) (- maxcol miser-width))

   177          (linear-nl? this lb section))))

   178 

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

   180 

   181 (defmethod emit-nl? :linear [newl this section _]

   182   (let [lb (:logical-block newl)]

   183     (linear-nl? this lb section)))

   184 

   185 (defmethod emit-nl? :miser [newl this section _]

   186   (let [lb (:logical-block newl)]

   187     (miser-nl? this lb section)))

   188 

   189 (defmethod emit-nl? :fill [newl this section subsection]

   190   (let [lb (:logical-block newl)]

   191     (or @(:intra-block-nl lb)

   192         (not (tokens-fit? this subsection))

   193         (miser-nl? this lb section))))

   194 

   195 (defmethod emit-nl? :mandatory [_ _ _ _]

   196   true)

   197 

   198 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   199 ;;; Various support functions

   200 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   201 

   202 

   203 (defn- get-section [buffer]

   204   (let [nl (first buffer) 

   205         lb (:logical-block nl)

   206         section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb)))

   207                                  (next buffer)))]

   208     [section (seq (drop (inc (count section)) buffer))])) 

   209 

   210 (defn- get-sub-section [buffer]

   211   (let [nl (first buffer) 

   212         lb (:logical-block nl)

   213         section (seq (take-while #(let [nl-lb (:logical-block %)]

   214                                     (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb)))))

   215                             (next buffer)))]

   216     section)) 

   217 

   218 (defn- update-nl-state [lb]

   219   (dosync

   220    (ref-set (:intra-block-nl lb) false)

   221    (ref-set (:done-nl lb) true)

   222    (loop [lb (:parent lb)]

   223      (if lb

   224        (do (ref-set (:done-nl lb) true)

   225            (ref-set (:intra-block-nl lb) true)

   226            (recur (:parent lb)))))))

   227 

   228 (defn emit-nl [^Writer this nl]

   229   (.write (getf :base) (int \newline))

   230   (dosync (setf :trailing-white-space nil))

   231   (let [lb (:logical-block nl)

   232         ^String prefix (:per-line-prefix lb)] 

   233     (if prefix 

   234       (.write (getf :base) prefix))

   235     (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix))

   236 					  \space))] 

   237       (.write (getf :base) istr))

   238     (update-nl-state lb)))

   239 

   240 (defn- split-at-newline [tokens]

   241   (let [pre (seq (take-while #(not (nl-t? %)) tokens))]

   242     [pre (seq (drop (count pre) tokens))]))

   243 

   244 ;;; Methods for showing token strings for debugging

   245 

   246 (defmulti tok :type-tag)

   247 (defmethod tok :nl-t [token]

   248   (:type token))

   249 (defmethod tok :buffer-blob [token]

   250   (str \" (:data token) (:trailing-white-space token) \"))

   251 (defmethod tok :default [token]

   252   (:type-tag token))

   253 (defn toks [toks] (map tok toks))

   254 

   255 ;;; write-token-string is called when the set of tokens in the buffer

   256 ;;; is longer than the available space on the line

   257 

   258 (defn- write-token-string [this tokens]

   259   (let [[a b] (split-at-newline tokens)]

   260 ;;    (prlabel wts (toks a) (toks b))

   261     (if a (write-tokens this a false))

   262     (if b

   263       (let [[section remainder] (get-section b)

   264             newl (first b)]

   265 ;;         (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) 

   266         (let [do-nl (emit-nl? newl this section (get-sub-section b))

   267               result (if do-nl 

   268                        (do

   269 ;;                          (prlabel emit-nl (:type newl))

   270                          (emit-nl this newl)

   271                          (next b))

   272                        b)

   273               long-section (not (tokens-fit? this result))

   274               result (if long-section

   275                        (let [rem2 (write-token-string this section)]

   276 ;;;                              (prlabel recurse (toks rem2))

   277                          (if (= rem2 section)

   278                            (do ; If that didn't produce any output, it has no nls

   279                                         ; so we'll force it

   280                              (write-tokens this section false)

   281                              remainder)

   282                            (into [] (concat rem2 remainder))))

   283                        result)

   284 ;;              ff (prlabel wts (toks result))

   285               ] 

   286           result)))))

   287 

   288 (defn- write-line [^Writer this]

   289   (dosync

   290    (loop [buffer (getf :buffer)]

   291 ;;     (prlabel wl1 (toks buffer))

   292      (setf :buffer (into [] buffer))

   293      (if (not (tokens-fit? this buffer))

   294        (let [new-buffer (write-token-string this buffer)]

   295 ;;          (prlabel wl new-buffer)

   296          (if-not (identical? buffer new-buffer)

   297                  (recur new-buffer)))))))

   298 

   299 ;;; Add a buffer token to the buffer and see if it's time to start

   300 ;;; writing

   301 (defn- add-to-buffer [^Writer this token]

   302 ;  (prlabel a2b token)

   303   (dosync

   304    (setf :buffer (conj (getf :buffer) token))

   305    (if (not (tokens-fit? this (getf :buffer)))

   306      (write-line this))))

   307 

   308 ;;; Write all the tokens that have been buffered

   309 (defn- write-buffered-output [^Writer this]

   310   (write-line this)

   311   (if-let [buf (getf :buffer)]

   312     (do

   313       (write-tokens this buf true)

   314       (setf :buffer []))))

   315 

   316 ;;; If there are newlines in the string, print the lines up until the last newline, 

   317 ;;; making the appropriate adjustments. Return the remainder of the string

   318 (defn- write-initial-lines 

   319   [^Writer this ^String s] 

   320   (let [lines (.split s "\n" -1)]

   321     (if (= (count lines) 1)

   322       s

   323       (dosync 

   324        (let [^String prefix (:per-line-prefix (first (getf :logical-blocks)))

   325              ^String l (first lines)] 

   326          (if (= :buffering (getf :mode))

   327            (let [oldpos (getf :pos)

   328                  newpos (+ oldpos (count l))]

   329              (setf :pos newpos)

   330              (add-to-buffer this (make-buffer-blob l nil oldpos newpos))

   331              (write-buffered-output this))

   332            (.write (getf :base) l))

   333          (.write (getf :base) (int \newline))

   334          (doseq [^String l (next (butlast lines))]

   335            (.write (getf :base) l)

   336            (.write (getf :base) (int \newline))

   337            (if prefix

   338              (.write (getf :base) prefix)))

   339          (setf :buffering :writing)

   340          (last lines))))))

   341 

   342 

   343 (defn write-white-space [^Writer this]

   344   (if-let [^String tws (getf :trailing-white-space)]

   345     (dosync

   346      (.write (getf :base) tws)

   347      (setf :trailing-white-space nil))))

   348 

   349 (defn- write-char [^Writer this ^Integer c]

   350   (if (= (getf :mode) :writing)

   351     (do 

   352       (write-white-space this)

   353       (.write (getf :base) c))

   354     (if (= c \newline)

   355       (write-initial-lines this "\n")

   356       (let [oldpos (getf :pos)

   357             newpos (inc oldpos)]

   358         (dosync

   359          (setf :pos newpos)

   360          (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos)))))))

   361 

   362 

   363 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   364 ;;; Initialize the pretty-writer instance

   365 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   366 

   367 

   368 (defn pretty-writer [writer max-columns miser-width]

   369   (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))

   370         fields (ref {:pretty-writer true

   371                      :base (column-writer writer max-columns)

   372                      :logical-blocks lb 

   373                      :sections nil

   374                      :mode :writing

   375                      :buffer []

   376                      :buffer-block lb

   377                      :buffer-level 1

   378                      :miser-width miser-width

   379                      :trailing-white-space nil

   380                      :pos 0})]

   381     (proxy [Writer IDeref] []

   382       (deref [] fields)

   383 

   384       (write 

   385        ([x]

   386           ;;     (prlabel write x (getf :mode))

   387           (condp = (class x)

   388             String 

   389             (let [^String s0 (write-initial-lines this x)

   390                   ^String s (.replaceFirst s0 "\\s+$" "")

   391                   white-space (.substring s0 (count s))

   392                   mode (getf :mode)]

   393               (dosync

   394                (if (= mode :writing)

   395                  (do

   396                    (write-white-space this)

   397                    (.write (getf :base) s)

   398                    (setf :trailing-white-space white-space))

   399                  (let [oldpos (getf :pos)

   400                        newpos (+ oldpos (count s0))]

   401                    (setf :pos newpos)

   402                    (add-to-buffer this (make-buffer-blob s white-space oldpos newpos))))))

   403 

   404             Integer

   405             (write-char this x)

   406             Long

   407             (write-char this x))))

   408 

   409       (flush []

   410              (if (= (getf :mode) :buffering)

   411                (dosync 

   412                 (write-tokens this (getf :buffer) true)

   413                 (setf :buffer []))

   414                (write-white-space this)))

   415 

   416       (close []

   417              (.flush this)))))

   418 

   419 

   420 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   421 ;;; Methods for pretty-writer

   422 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   423 

   424 (defn start-block 

   425   [^Writer this 

   426    ^String prefix ^String per-line-prefix ^String suffix]

   427   (dosync 

   428    (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0)

   429                     (ref false) (ref false)

   430                     prefix per-line-prefix suffix)]

   431      (setf :logical-blocks lb)

   432      (if (= (getf :mode) :writing)

   433        (do

   434          (write-white-space this)

   435           (when-let [cb (getf :logical-block-callback)] (cb :start))

   436           (if prefix 

   437            (.write (getf :base) prefix))

   438          (let [col (get-column (getf :base))]

   439            (ref-set (:start-col lb) col)

   440            (ref-set (:indent lb) col)))

   441        (let [oldpos (getf :pos)

   442              newpos (+ oldpos (if prefix (count prefix) 0))]

   443          (setf :pos newpos)

   444          (add-to-buffer this (make-start-block-t lb oldpos newpos)))))))

   445 

   446 (defn end-block [^Writer this]

   447   (dosync

   448    (let [lb (getf :logical-blocks)

   449          ^String suffix (:suffix lb)]

   450      (if (= (getf :mode) :writing)

   451        (do

   452          (write-white-space this)

   453          (if suffix

   454            (.write (getf :base) suffix))

   455          (when-let [cb (getf :logical-block-callback)] (cb :end)))

   456        (let [oldpos (getf :pos)

   457              newpos (+ oldpos (if suffix (count suffix) 0))]

   458          (setf :pos newpos)

   459          (add-to-buffer this (make-end-block-t lb oldpos newpos))))

   460      (setf :logical-blocks (:parent lb)))))

   461 

   462 (defn nl [^Writer this type]

   463   (dosync 

   464    (setf :mode :buffering)

   465    (let [pos (getf :pos)]

   466      (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos)))))

   467 

   468 (defn indent [^Writer this relative-to offset]

   469   (dosync 

   470    (let [lb (getf :logical-blocks)]

   471      (if (= (getf :mode) :writing)

   472        (do

   473          (write-white-space this)

   474          (ref-set (:indent lb) 

   475                   (+ offset (condp = relative-to

   476 			      :block @(:start-col lb)

   477 			      :current (get-column (getf :base))))))

   478        (let [pos (getf :pos)]

   479          (add-to-buffer this (make-indent-t lb relative-to offset pos pos)))))))

   480 

   481 (defn get-miser-width [^Writer this]

   482   (getf :miser-width))

   483 

   484 (defn set-miser-width [^Writer this new-miser-width]

   485   (dosync (setf :miser-width new-miser-width)))

   486 

   487 (defn set-logical-block-callback [^Writer this f]

   488   (dosync (setf :logical-block-callback f)))
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children