1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/pprint/pprint_base.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,342 @@
     1.4 +;;; pprint_base.clj -- part of the pretty printer for Clojure
     1.5 +
     1.6 +;; by Tom Faulhaber
     1.7 +;; April 3, 2009
     1.8 +
     1.9 +;   Copyright (c) Tom Faulhaber, Jan 2009. All rights reserved.
    1.10 +;   The use and distribution terms for this software are covered by the
    1.11 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
    1.12 +;   which can be found in the file epl-v10.html at the root of this distribution.
    1.13 +;   By using this software in any fashion, you are agreeing to be bound by
    1.14 +;   the terms of this license.
    1.15 +;   You must not remove this notice, or any other, from this software.
    1.16 +
    1.17 +;; This module implements the generic pretty print functions and special variables
    1.18 +
    1.19 +(in-ns 'clojure.contrib.pprint)
    1.20 +
    1.21 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.22 +;; Variables that control the pretty printer
    1.23 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.24 +
    1.25 +;;;
    1.26 +;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core
    1.27 +;;; TODO: use *print-dup* here (or is it supplanted by other variables?)
    1.28 +;;; TODO: make dispatch items like "(let..." get counted in *print-length*
    1.29 +;;; constructs
    1.30 +
    1.31 +
    1.32 +(def
    1.33 + ^{ :doc "Bind to true if you want write to use pretty printing"}
    1.34 + *print-pretty* true)
    1.35 +
    1.36 +(defonce ; If folks have added stuff here, don't overwrite
    1.37 + ^{ :doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch
    1.38 +to modify."}
    1.39 + *print-pprint-dispatch* nil)
    1.40 +
    1.41 +(def
    1.42 + ^{ :doc "Pretty printing will try to avoid anything going beyond this column.
    1.43 +Set it to nil to have pprint let the line be arbitrarily long. This will ignore all 
    1.44 +non-mandatory newlines."}
    1.45 + *print-right-margin* 72)
    1.46 +
    1.47 +(def
    1.48 + ^{ :doc "The column at which to enter miser style. Depending on the dispatch table, 
    1.49 +miser style add newlines in more places to try to keep lines short allowing for further 
    1.50 +levels of nesting."}
    1.51 + *print-miser-width* 40)
    1.52 +
    1.53 +;;; TODO implement output limiting
    1.54 +(def
    1.55 + ^{ :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"}
    1.56 + *print-lines* nil)
    1.57 +
    1.58 +;;; TODO: implement circle and shared
    1.59 +(def
    1.60 + ^{ :doc "Mark circular structures (N.B. This is not yet used)"}
    1.61 + *print-circle* nil)
    1.62 +
    1.63 +;;; TODO: should we just use *print-dup* here?
    1.64 +(def
    1.65 + ^{ :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"}
    1.66 + *print-shared* nil)
    1.67 +
    1.68 +(def
    1.69 + ^{ :doc "Don't print namespaces with symbols. This is particularly useful when 
    1.70 +pretty printing the results of macro expansions"}
    1.71 + *print-suppress-namespaces* nil)
    1.72 +
    1.73 +;;; TODO: support print-base and print-radix in cl-format
    1.74 +;;; TODO: support print-base and print-radix in rationals
    1.75 +(def
    1.76 + ^{ :doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8, 
    1.77 +or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the 
    1.78 +radix specifier is in the form #XXr where XX is the decimal value of *print-base* "}
    1.79 + *print-radix* nil)
    1.80 +
    1.81 +(def
    1.82 + ^{ :doc "The base to use for printing integers and rationals."}
    1.83 + *print-base* 10)
    1.84 +
    1.85 +
    1.86 +
    1.87 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.88 +;; Internal variables that keep track of where we are in the 
    1.89 +;; structure
    1.90 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.91 +
    1.92 +(def ^{ :private true } *current-level* 0)
    1.93 +
    1.94 +(def ^{ :private true } *current-length* nil)
    1.95 +
    1.96 +;; TODO: add variables for length, lines.
    1.97 +
    1.98 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.99 +;; Support for the write function
   1.100 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.101 +
   1.102 +(declare format-simple-number)
   1.103 +
   1.104 +(def ^{:private true} orig-pr pr)
   1.105 +
   1.106 +(defn- pr-with-base [x]
   1.107 +  (if-let [s (format-simple-number x)]
   1.108 +    (print s)
   1.109 +    (orig-pr x)))
   1.110 +
   1.111 +(def ^{:private true} write-option-table
   1.112 +     {;:array            *print-array*
   1.113 +      :base             'clojure.contrib.pprint/*print-base*,
   1.114 +      ;;:case             *print-case*,
   1.115 +      :circle           'clojure.contrib.pprint/*print-circle*,
   1.116 +      ;;:escape           *print-escape*,
   1.117 +      ;;:gensym           *print-gensym*,
   1.118 +      :length           'clojure.core/*print-length*,
   1.119 +      :level            'clojure.core/*print-level*,
   1.120 +      :lines            'clojure.contrib.pprint/*print-lines*,
   1.121 +      :miser-width      'clojure.contrib.pprint/*print-miser-width*,
   1.122 +      :dispatch         'clojure.contrib.pprint/*print-pprint-dispatch*,
   1.123 +      :pretty           'clojure.contrib.pprint/*print-pretty*,
   1.124 +      :radix            'clojure.contrib.pprint/*print-radix*,
   1.125 +      :readably         'clojure.core/*print-readably*,
   1.126 +      :right-margin     'clojure.contrib.pprint/*print-right-margin*,
   1.127 +      :suppress-namespaces 'clojure.contrib.pprint/*print-suppress-namespaces*})
   1.128 +
   1.129 +
   1.130 +(defmacro ^{:private true} binding-map [amap & body]
   1.131 +  (let []
   1.132 +    `(do
   1.133 +       (. clojure.lang.Var (pushThreadBindings ~amap))
   1.134 +       (try
   1.135 +        ~@body
   1.136 +        (finally
   1.137 +         (. clojure.lang.Var (popThreadBindings)))))))
   1.138 +
   1.139 +(defn- table-ize [t m] 
   1.140 +  (apply hash-map (mapcat 
   1.141 +                   #(when-let [v (get t (key %))] [(find-var v) (val %)]) 
   1.142 +                   m)))
   1.143 +
   1.144 +(defn- pretty-writer? 
   1.145 +  "Return true iff x is a PrettyWriter"
   1.146 +  [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x)))
   1.147 +
   1.148 +(defn- make-pretty-writer 
   1.149 +  "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width"
   1.150 +  [base-writer right-margin miser-width]
   1.151 +  (pretty-writer base-writer right-margin miser-width))
   1.152 +
   1.153 +(defmacro ^{:private true} with-pretty-writer [base-writer & body]
   1.154 +  `(let [base-writer# ~base-writer
   1.155 +         new-writer# (not (pretty-writer? base-writer#))]
   1.156 +     (binding [*out* (if new-writer#
   1.157 +                      (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*)
   1.158 +                      base-writer#)]
   1.159 +       ~@body
   1.160 +       (.flush *out*))))
   1.161 +
   1.162 +
   1.163 +;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc.
   1.164 +(defn write-out 
   1.165 +  "Write an object to *out* subject to the current bindings of the printer control 
   1.166 +variables. Use the kw-args argument to override individual variables for this call (and 
   1.167 +any recursive calls).
   1.168 +
   1.169 +*out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility
   1.170 +of the caller.
   1.171 +
   1.172 +This method is primarily intended for use by pretty print dispatch functions that 
   1.173 +already know that the pretty printer will have set up their environment appropriately.
   1.174 +Normal library clients should use the standard \"write\" interface. "
   1.175 +  [object]
   1.176 +  (let [length-reached (and 
   1.177 +                        *current-length*
   1.178 +                        *print-length*
   1.179 +                        (>= *current-length* *print-length*))]
   1.180 +    (if-not *print-pretty*
   1.181 +      (pr object)
   1.182 +      (if length-reached
   1.183 +        (print "...")
   1.184 +        (do
   1.185 +          (if *current-length* (set! *current-length* (inc *current-length*)))
   1.186 +          (*print-pprint-dispatch* object))))
   1.187 +    length-reached))
   1.188 +
   1.189 +(defn write 
   1.190 +  "Write an object subject to the current bindings of the printer control variables.
   1.191 +Use the kw-args argument to override individual variables for this call (and any 
   1.192 +recursive calls). Returns the string result if :stream is nil or nil otherwise.
   1.193 +
   1.194 +The following keyword arguments can be passed with values:
   1.195 +  Keyword              Meaning                              Default value
   1.196 +  :stream              Writer for output or nil             true (indicates *out*)
   1.197 +  :base                Base to use for writing rationals    Current value of *print-base*
   1.198 +  :circle*             If true, mark circular structures    Current value of *print-circle*
   1.199 +  :length              Maximum elements to show in sublists Current value of *print-length*
   1.200 +  :level               Maximum depth                        Current value of *print-level*
   1.201 +  :lines*              Maximum lines of output              Current value of *print-lines*
   1.202 +  :miser-width         Width to enter miser mode            Current value of *print-miser-width*
   1.203 +  :dispatch            The pretty print dispatch function   Current value of *print-pprint-dispatch*
   1.204 +  :pretty              If true, do pretty printing          Current value of *print-pretty*
   1.205 +  :radix               If true, prepend a radix specifier   Current value of *print-radix*
   1.206 +  :readably*           If true, print readably              Current value of *print-readably*
   1.207 +  :right-margin        The column for the right margin      Current value of *print-right-margin*
   1.208 +  :suppress-namespaces If true, no namespaces in symbols    Current value of *print-suppress-namespaces*
   1.209 +
   1.210 +  * = not yet supported
   1.211 +"
   1.212 +  [object & kw-args]
   1.213 +  (let [options (merge {:stream true} (apply hash-map kw-args))]
   1.214 +    (binding-map (table-ize write-option-table options) 
   1.215 +      (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) 
   1.216 +        (let [optval (if (contains? options :stream) 
   1.217 +                       (:stream options)
   1.218 +                       true) 
   1.219 +              base-writer (condp = optval
   1.220 +                            nil (java.io.StringWriter.)
   1.221 +                            true *out*
   1.222 +                            optval)]
   1.223 +          (if *print-pretty*
   1.224 +            (with-pretty-writer base-writer
   1.225 +              (write-out object))
   1.226 +            (binding [*out* base-writer]
   1.227 +              (pr object)))
   1.228 +          (if (nil? optval) 
   1.229 +            (.toString ^java.io.StringWriter base-writer)))))))
   1.230 +
   1.231 +
   1.232 +(defn pprint 
   1.233 +  "Pretty print object to the optional output writer. If the writer is not provided, 
   1.234 +print the object to the currently bound value of *out*."
   1.235 +  ([object] (pprint object *out*)) 
   1.236 +  ([object writer]
   1.237 +     (with-pretty-writer writer
   1.238 +       (binding [*print-pretty* true]
   1.239 +         (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) 
   1.240 +           (write-out object)))
   1.241 +       (if (not (= 0 (get-column *out*)))
   1.242 +         (.write *out* (int \newline))))))
   1.243 +
   1.244 +(defmacro pp 
   1.245 +  "A convenience macro that pretty prints the last thing output. This is
   1.246 +exactly equivalent to (pprint *1)."
   1.247 +  [] `(pprint *1))
   1.248 +
   1.249 +(defn set-pprint-dispatch  
   1.250 +  "Set the pretty print dispatch function to a function matching (fn [obj] ...)
   1.251 +where obj is the object to pretty print. That function will be called with *out* set
   1.252 +to a pretty printing writer to which it should do its printing.
   1.253 +
   1.254 +For example functions, see *simple-dispatch* and *code-dispatch* in 
   1.255 +clojure.contrib.pprint.dispatch.clj."
   1.256 +  [function]
   1.257 +  (let [old-meta (meta #'*print-pprint-dispatch*)]
   1.258 +    (alter-var-root #'*print-pprint-dispatch* (constantly function))
   1.259 +    (alter-meta! #'*print-pprint-dispatch* (constantly old-meta)))
   1.260 +  nil)
   1.261 +
   1.262 +(defmacro with-pprint-dispatch 
   1.263 +  "Execute body with the pretty print dispatch function bound to function."
   1.264 +  [function & body]
   1.265 +  `(binding [*print-pprint-dispatch* ~function]
   1.266 +     ~@body))
   1.267 +
   1.268 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.269 +;; Support for the functional interface to the pretty printer
   1.270 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.271 +
   1.272 +(defn- parse-lb-options [opts body]
   1.273 +  (loop [body body
   1.274 +         acc []]
   1.275 +    (if (opts (first body))
   1.276 +      (recur (drop 2 body) (concat acc (take 2 body)))
   1.277 +      [(apply hash-map acc) body])))
   1.278 +
   1.279 +(defn- check-enumerated-arg [arg choices]
   1.280 +  (if-not (choices arg)
   1.281 +          (throw
   1.282 +           (IllegalArgumentException.
   1.283 +            ;; TODO clean up choices string
   1.284 +            (str "Bad argument: " arg ". It must be one of " choices)))))
   1.285 +
   1.286 +(defn level-exceeded []
   1.287 +  (and *print-level* (>= *current-level* *print-level*)))
   1.288 +
   1.289 +(defmacro pprint-logical-block 
   1.290 +  "Execute the body as a pretty printing logical block with output to *out* which 
   1.291 +must be a pretty printing writer. When used from pprint or cl-format, this can be 
   1.292 +assumed. 
   1.293 +
   1.294 +Before the body, the caller can optionally specify options: :prefix, :per-line-prefix, 
   1.295 +and :suffix."
   1.296 +  {:arglists '[[options* body]]}
   1.297 +  [& args]
   1.298 +  (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
   1.299 +    `(do (if (level-exceeded) 
   1.300 +           (.write ^java.io.Writer *out* "#")
   1.301 +           (binding [*current-level* (inc *current-level*)
   1.302 +                     *current-length* 0] 
   1.303 +             (start-block *out*
   1.304 +                          ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))
   1.305 +             ~@body
   1.306 +             (end-block *out*)))
   1.307 +         nil)))
   1.308 +
   1.309 +(defn pprint-newline
   1.310 +  "Print a conditional newline to a pretty printing stream. kind specifies if the 
   1.311 +newline is :linear, :miser, :fill, or :mandatory. 
   1.312 +
   1.313 +Output is sent to *out* which must be a pretty printing writer."
   1.314 +  [kind] 
   1.315 +  (check-enumerated-arg kind #{:linear :miser :fill :mandatory})
   1.316 +  (nl *out* kind))
   1.317 +
   1.318 +(defn pprint-indent 
   1.319 +  "Create an indent at this point in the pretty printing stream. This defines how 
   1.320 +following lines are indented. relative-to can be either :block or :current depending 
   1.321 +whether the indent should be computed relative to the start of the logical block or
   1.322 +the current column position. n is an offset. 
   1.323 +
   1.324 +Output is sent to *out* which must be a pretty printing writer."
   1.325 +  [relative-to n] 
   1.326 +  (check-enumerated-arg relative-to #{:block :current})
   1.327 +  (indent *out* relative-to n))
   1.328 +
   1.329 +;; TODO a real implementation for pprint-tab
   1.330 +(defn pprint-tab 
   1.331 +  "Tab at this point in the pretty printing stream. kind specifies whether the tab
   1.332 +is :line, :section, :line-relative, or :section-relative. 
   1.333 +
   1.334 +Colnum and colinc specify the target column and the increment to move the target
   1.335 +forward if the output is already past the original target.
   1.336 +
   1.337 +Output is sent to *out* which must be a pretty printing writer.
   1.338 +
   1.339 +THIS FUNCTION IS NOT YET IMPLEMENTED."
   1.340 +  [kind colnum colinc] 
   1.341 +  (check-enumerated-arg kind #{:line :section :line-relative :section-relative})
   1.342 +  (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))
   1.343 +
   1.344 +
   1.345 +nil