Mercurial > lasercutter

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

     2 

     3 ;   Copyright (c) Rich Hickey. All rights reserved.

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

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

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

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

     8 ;   the terms of this license.

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

    10 

    11 ;; Author: Tom Faulhaber

    12 ;; April 3, 2009

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

    14 

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

    16 ;; core of the XP algorithm.

    17 

    18 (in-ns 'clojure.pprint)

    19 

    20 (import [clojure.lang IDeref]

    21         [java.io Writer])

    22 

    23 ;; TODO: Support for tab directives

    24 

    25 

    26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    27 ;;; Forward declarations

    28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    29 

    30 (declare get-miser-width)

    31 

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

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

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

    35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    36 

    37 (defmacro ^{:private true} 

    38   getf 

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

    40   [sym]

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

    42 

    43 (defmacro ^{:private true} 

    44   setf [sym new-val] 

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

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

    47 

    48 (defmacro ^{:private true} 

    49   deftype [type-name & fields]

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

    51     `(do

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

    53        (alter-meta! #'~type-name assoc :private true)

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

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

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

    57 

    58 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

    60 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    61 

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

    63            :parent :section :start-col :indent

    64            :done-nl :intra-block-nl

    65            :prefix :per-line-prefix :suffix

    66            :logical-block-callback)

    67 

    68 (defn- ancestor? [parent child]

    69   (loop [child (:parent child)]

    70     (cond 

    71      (nil? child) false

    72      (identical? parent child) true

    73      :else (recur (:parent child)))))

    74 

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

    76 

    77 (defn- buffer-length [l] 

    78   (let [l (seq l)]

    79     (if l 

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

    81       0)))

    82 

    83 ; A blob of characters (aka a string)

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

    85 

    86 ; A newline

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

    88 

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

    90 

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

    92 

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

    94 

    95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

    97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    98 

    99 (declare emit-nl)

   100 

   101 (defmulti ^{:private true} write-token #(:type-tag %2))

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

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

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

   105     (dosync

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

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

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

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

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

   111 

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

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

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

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

   116 

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

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

   119     (ref-set (:indent lb) 

   120              (+ (:offset token)

   121                 (condp = (:relative-to token)

   122 		  :block @(:start-col lb)

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

   124 

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

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

   127 

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

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

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

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

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

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

   134     (emit-nl this token)

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

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

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

   138 

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

   140   (doseq [token tokens]

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

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

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

   144     (write-token this token)

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

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

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

   148       (.write (getf :base) tws)

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

   150 

   151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

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

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

   155 

   156 

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

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

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

   160     (or 

   161      (nil? maxcol) 

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

   163 

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

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

   166   (or @(:done-nl lb)

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

   168 

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

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

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

   172     (and miser-width maxcol

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

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

   175 

   176 (defmulti ^{:private true} emit-nl? (fn [t _ _ _] (:type t)))

   177 

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

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

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

   181 

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

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

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

   185 

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

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

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

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

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

   191 

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

   193   true)

   194 

   195 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   196 ;;; Various support functions

   197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   198 

   199 

   200 (defn- get-section [buffer]

   201   (let [nl (first buffer) 

   202         lb (:logical-block nl)

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

   204                                  (next buffer)))]

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

   206 

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

   208   (let [nl (first buffer) 

   209         lb (:logical-block nl)

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

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

   212                             (next buffer)))]

   213     section)) 

   214 

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

   216   (dosync

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

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

   219    (loop [lb (:parent lb)]

   220      (if lb

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

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

   223            (recur (:parent lb)))))))

   224 

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

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

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

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

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

   230     (if prefix 

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

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

   233 					  \space))] 

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

   235     (update-nl-state lb)))

   236 

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

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

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

   240 

   241 ;;; Methods for showing token strings for debugging

   242 

   243 (defmulti ^{:private true} tok :type-tag)

   244 (defmethod tok :nl-t [token]

   245   (:type token))

   246 (defmethod tok :buffer-blob [token]

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

   248 (defmethod tok :default [token]

   249   (:type-tag token))

   250 (defn- toks [toks] (map tok toks))

   251 

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

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

   254 

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

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

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

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

   259     (if b

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

   261             newl (first b)]

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

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

   264               result (if do-nl 

   265                        (do

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

   267                          (emit-nl this newl)

   268                          (next b))

   269                        b)

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

   271               result (if long-section

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

   273 ;;;                              (prlabel recurse (toks rem2))

   274                          (if (= rem2 section)

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

   276                                         ; so we'll force it

   277                              (write-tokens this section false)

   278                              remainder)

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

   280                        result)

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

   282               ] 

   283           result)))))

   284 

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

   286   (dosync

   287    (loop [buffer (getf :buffer)]

   288 ;;     (prlabel wl1 (toks buffer))

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

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

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

   292 ;;          (prlabel wl new-buffer)

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

   294                  (recur new-buffer)))))))

   295 

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

   297 ;;; writing

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

   299 ;  (prlabel a2b token)

   300   (dosync

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

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

   303      (write-line this))))

   304 

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

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

   307   (write-line this)

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

   309     (do

   310       (write-tokens this buf true)

   311       (setf :buffer []))))

   312 

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

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

   315 (defn- write-initial-lines 

   316   [^Writer this ^String s] 

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

   318     (if (= (count lines) 1)

   319       s

   320       (dosync 

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

   322              ^String l (first lines)] 

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

   324            (let [oldpos (getf :pos)

   325                  newpos (+ oldpos (count l))]

   326              (setf :pos newpos)

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

   328              (write-buffered-output this))

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

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

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

   332            (.write (getf :base) l)

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

   334            (if prefix

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

   336          (setf :buffering :writing)

   337          (last lines))))))

   338 

   339 

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

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

   342     (dosync

   343      (.write (getf :base) tws)

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

   345 

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

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

   348     (do 

   349       (write-white-space this)

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

   351     (if (= c \newline)

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

   353       (let [oldpos (getf :pos)

   354             newpos (inc oldpos)]

   355         (dosync

   356          (setf :pos newpos)

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

   358 

   359 

   360 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   361 ;;; Initialize the pretty-writer instance

   362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   363 

   364 

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

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

   367         fields (ref {:pretty-writer true

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

   369                      :logical-blocks lb 

   370                      :sections nil

   371                      :mode :writing

   372                      :buffer []

   373                      :buffer-block lb

   374                      :buffer-level 1

   375                      :miser-width miser-width

   376                      :trailing-white-space nil

   377                      :pos 0})]

   378     (proxy [Writer IDeref] []

   379       (deref [] fields)

   380 

   381       (write 

   382        ([x]

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

   384           (condp = (class x)

   385             String 

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

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

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

   389                   mode (getf :mode)]

   390               (dosync

   391                (if (= mode :writing)

   392                  (do

   393                    (write-white-space this)

   394                    (.write (getf :base) s)

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

   396                  (let [oldpos (getf :pos)

   397                        newpos (+ oldpos (count s0))]

   398                    (setf :pos newpos)

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

   400 

   401             Integer

   402             (p-write-char this x))))

   403 

   404       (flush []

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

   406                (dosync 

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

   408                 (setf :buffer []))

   409                (write-white-space this)))

   410 

   411       (close []

   412              (.flush this)))))

   413 

   414 

   415 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   416 ;;; Methods for pretty-writer

   417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   418 

   419 (defn- start-block 

   420   [^Writer this 

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

   422   (dosync 

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

   424                     (ref false) (ref false)

   425                     prefix per-line-prefix suffix)]

   426      (setf :logical-blocks lb)

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

   428        (do

   429          (write-white-space this)

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

   431           (if prefix 

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

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

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

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

   436        (let [oldpos (getf :pos)

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

   438          (setf :pos newpos)

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

   440 

   441 (defn- end-block [^Writer this]

   442   (dosync

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

   444          ^String suffix (:suffix lb)]

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

   446        (do

   447          (write-white-space this)

   448          (if suffix

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

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

   451        (let [oldpos (getf :pos)

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

   453          (setf :pos newpos)

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

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

   456 

   457 (defn- nl [^Writer this type]

   458   (dosync 

   459    (setf :mode :buffering)

   460    (let [pos (getf :pos)]

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

   462 

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

   464   (dosync 

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

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

   467        (do

   468          (write-white-space this)

   469          (ref-set (:indent lb) 

   470                   (+ offset (condp = relative-to

   471 			      :block @(:start-col lb)

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

   473        (let [pos (getf :pos)]

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

   475 

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

   477   (getf :miser-width))

   478 

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

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

   481 

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

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