Mercurial > lasercutter
view src/clojure/pprint/pprint_base.clj @ 10:ef7dbbd6452c
added clojure source goodness
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 21 Aug 2010 06:25:44 -0400 |
parents | |
children |
line wrap: on
line source
1 ;;; pprint_base.clj -- part of the pretty printer for Clojure3 ; Copyright (c) Rich Hickey. All rights reserved.4 ; The use and distribution terms for this software are covered by the5 ; 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 by8 ; the terms of this license.9 ; You must not remove this notice, or any other, from this software.11 ;; Author: Tom Faulhaber12 ;; April 3, 200915 ;; This module implements the generic pretty print functions and special variables17 (in-ns 'clojure.pprint)19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;20 ;; Variables that control the pretty printer21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;23 ;;;24 ;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core25 ;;; TODO: use *print-dup* here (or is it supplanted by other variables?)26 ;;; TODO: make dispatch items like "(let..." get counted in *print-length*27 ;;; constructs30 (def31 ^{:doc "Bind to true if you want write to use pretty printing", :added "1.2"}32 *print-pretty* true)34 (defonce ; If folks have added stuff here, don't overwrite35 ^{:doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch36 to modify.",37 :added "1.2"}38 *print-pprint-dispatch* nil)40 (def41 ^{:doc "Pretty printing will try to avoid anything going beyond this column.42 Set it to nil to have pprint let the line be arbitrarily long. This will ignore all43 non-mandatory newlines.",44 :added "1.2"}45 *print-right-margin* 72)47 (def48 ^{:doc "The column at which to enter miser style. Depending on the dispatch table,49 miser style add newlines in more places to try to keep lines short allowing for further50 levels of nesting.",51 :added "1.2"}52 *print-miser-width* 40)54 ;;; TODO implement output limiting55 (def56 ^{:private true,57 :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"}58 *print-lines* nil)60 ;;; TODO: implement circle and shared61 (def62 ^{:private true,63 :doc "Mark circular structures (N.B. This is not yet used)"}64 *print-circle* nil)66 ;;; TODO: should we just use *print-dup* here?67 (def68 ^{:private true,69 :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"}70 *print-shared* nil)72 (def73 ^{:doc "Don't print namespaces with symbols. This is particularly useful when74 pretty printing the results of macro expansions"75 :added "1.2"}76 *print-suppress-namespaces* nil)78 ;;; TODO: support print-base and print-radix in cl-format79 ;;; TODO: support print-base and print-radix in rationals80 (def81 ^{:doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8,82 or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the83 radix specifier is in the form #XXr where XX is the decimal value of *print-base* "84 :added "1.2"}85 *print-radix* nil)87 (def88 ^{:doc "The base to use for printing integers and rationals."89 :added "1.2"}90 *print-base* 10)94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;95 ;; Internal variables that keep track of where we are in the96 ;; structure97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;99 (def ^{ :private true } *current-level* 0)101 (def ^{ :private true } *current-length* nil)103 ;; TODO: add variables for length, lines.105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;106 ;; Support for the write function107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;109 (declare format-simple-number)111 (def ^{:private true} orig-pr pr)113 (defn- pr-with-base [x]114 (if-let [s (format-simple-number x)]115 (print s)116 (orig-pr x)))118 (def ^{:private true} write-option-table119 {;:array *print-array*120 :base 'clojure.pprint/*print-base*,121 ;;:case *print-case*,122 :circle 'clojure.pprint/*print-circle*,123 ;;:escape *print-escape*,124 ;;:gensym *print-gensym*,125 :length 'clojure.core/*print-length*,126 :level 'clojure.core/*print-level*,127 :lines 'clojure.pprint/*print-lines*,128 :miser-width 'clojure.pprint/*print-miser-width*,129 :dispatch 'clojure.pprint/*print-pprint-dispatch*,130 :pretty 'clojure.pprint/*print-pretty*,131 :radix 'clojure.pprint/*print-radix*,132 :readably 'clojure.core/*print-readably*,133 :right-margin 'clojure.pprint/*print-right-margin*,134 :suppress-namespaces 'clojure.pprint/*print-suppress-namespaces*})137 (defmacro ^{:private true} binding-map [amap & body]138 (let []139 `(do140 (. clojure.lang.Var (pushThreadBindings ~amap))141 (try142 ~@body143 (finally144 (. clojure.lang.Var (popThreadBindings)))))))146 (defn- table-ize [t m]147 (apply hash-map (mapcat148 #(when-let [v (get t (key %))] [(find-var v) (val %)])149 m)))151 (defn- pretty-writer?152 "Return true iff x is a PrettyWriter"153 [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x)))155 (defn- make-pretty-writer156 "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width"157 [base-writer right-margin miser-width]158 (pretty-writer base-writer right-margin miser-width))160 (defmacro ^{:private true} with-pretty-writer [base-writer & body]161 `(let [base-writer# ~base-writer162 new-writer# (not (pretty-writer? base-writer#))]163 (binding [*out* (if new-writer#164 (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*)165 base-writer#)]166 ~@body167 (.flush *out*))))170 ;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc.171 (defn write-out172 "Write an object to *out* subject to the current bindings of the printer control173 variables. Use the kw-args argument to override individual variables for this call (and174 any recursive calls).176 *out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility177 of the caller.179 This method is primarily intended for use by pretty print dispatch functions that180 already know that the pretty printer will have set up their environment appropriately.181 Normal library clients should use the standard \"write\" interface. "182 {:added "1.2"}183 [object]184 (let [length-reached (and185 *current-length*186 *print-length*187 (>= *current-length* *print-length*))]188 (if-not *print-pretty*189 (pr object)190 (if length-reached191 (print "...")192 (do193 (if *current-length* (set! *current-length* (inc *current-length*)))194 (*print-pprint-dispatch* object))))195 length-reached))197 (defn write198 "Write an object subject to the current bindings of the printer control variables.199 Use the kw-args argument to override individual variables for this call (and any200 recursive calls). Returns the string result if :stream is nil or nil otherwise.202 The following keyword arguments can be passed with values:203 Keyword Meaning Default value204 :stream Writer for output or nil true (indicates *out*)205 :base Base to use for writing rationals Current value of *print-base*206 :circle* If true, mark circular structures Current value of *print-circle*207 :length Maximum elements to show in sublists Current value of *print-length*208 :level Maximum depth Current value of *print-level*209 :lines* Maximum lines of output Current value of *print-lines*210 :miser-width Width to enter miser mode Current value of *print-miser-width*211 :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch*212 :pretty If true, do pretty printing Current value of *print-pretty*213 :radix If true, prepend a radix specifier Current value of *print-radix*214 :readably* If true, print readably Current value of *print-readably*215 :right-margin The column for the right margin Current value of *print-right-margin*216 :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces*218 * = not yet supported219 "220 {:added "1.2"}221 [object & kw-args]222 (let [options (merge {:stream true} (apply hash-map kw-args))]223 (binding-map (table-ize write-option-table options)224 (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {})225 (let [optval (if (contains? options :stream)226 (:stream options)227 true)228 base-writer (condp = optval229 nil (java.io.StringWriter.)230 true *out*231 optval)]232 (if *print-pretty*233 (with-pretty-writer base-writer234 (write-out object))235 (binding [*out* base-writer]236 (pr object)))237 (if (nil? optval)238 (.toString ^java.io.StringWriter base-writer)))))))241 (defn pprint242 "Pretty print object to the optional output writer. If the writer is not provided,243 print the object to the currently bound value of *out*."244 {:added "1.2"}245 ([object] (pprint object *out*))246 ([object writer]247 (with-pretty-writer writer248 (binding [*print-pretty* true]249 (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {})250 (write-out object)))251 (if (not (= 0 (get-column *out*)))252 (.write *out* (int \newline))))))254 (defmacro pp255 "A convenience macro that pretty prints the last thing output. This is256 exactly equivalent to (pprint *1)."257 {:added "1.2"}258 [] `(pprint *1))260 (defn set-pprint-dispatch261 "Set the pretty print dispatch function to a function matching (fn [obj] ...)262 where obj is the object to pretty print. That function will be called with *out* set263 to a pretty printing writer to which it should do its printing.265 For example functions, see simple-dispatch and code-dispatch in266 clojure.pprint.dispatch.clj."267 {:added "1.2"}268 [function]269 (let [old-meta (meta #'*print-pprint-dispatch*)]270 (alter-var-root #'*print-pprint-dispatch* (constantly function))271 (alter-meta! #'*print-pprint-dispatch* (constantly old-meta)))272 nil)274 (defmacro with-pprint-dispatch275 "Execute body with the pretty print dispatch function bound to function."276 {:added "1.2"}277 [function & body]278 `(binding [*print-pprint-dispatch* ~function]279 ~@body))281 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;282 ;; Support for the functional interface to the pretty printer283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;285 (defn- parse-lb-options [opts body]286 (loop [body body287 acc []]288 (if (opts (first body))289 (recur (drop 2 body) (concat acc (take 2 body)))290 [(apply hash-map acc) body])))292 (defn- check-enumerated-arg [arg choices]293 (if-not (choices arg)294 (throw295 (IllegalArgumentException.296 ;; TODO clean up choices string297 (str "Bad argument: " arg ". It must be one of " choices)))))299 (defn- level-exceeded []300 (and *print-level* (>= *current-level* *print-level*)))302 (defmacro pprint-logical-block303 "Execute the body as a pretty printing logical block with output to *out* which304 must be a pretty printing writer. When used from pprint or cl-format, this can be305 assumed.307 This function is intended for use when writing custom dispatch functions.309 Before the body, the caller can optionally specify options: :prefix, :per-line-prefix,310 and :suffix."311 {:added "1.2", :arglists '[[options* body]]}312 [& args]313 (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]314 `(do (if (#'clojure.pprint/level-exceeded)315 (.write ^java.io.Writer *out* "#")316 (do317 (push-thread-bindings {#'clojure.pprint/*current-level*318 (inc (var-get #'clojure.pprint/*current-level*))319 #'clojure.pprint/*current-length* 0})320 (try321 (#'clojure.pprint/start-block *out*322 ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))323 ~@body324 (#'clojure.pprint/end-block *out*)325 (finally326 (pop-thread-bindings)))))327 nil)))329 (defn pprint-newline330 "Print a conditional newline to a pretty printing stream. kind specifies if the331 newline is :linear, :miser, :fill, or :mandatory.333 This function is intended for use when writing custom dispatch functions.335 Output is sent to *out* which must be a pretty printing writer."336 {:added "1.2"}337 [kind]338 (check-enumerated-arg kind #{:linear :miser :fill :mandatory})339 (nl *out* kind))341 (defn pprint-indent342 "Create an indent at this point in the pretty printing stream. This defines how343 following lines are indented. relative-to can be either :block or :current depending344 whether the indent should be computed relative to the start of the logical block or345 the current column position. n is an offset.347 This function is intended for use when writing custom dispatch functions.349 Output is sent to *out* which must be a pretty printing writer."350 {:added "1.2"}351 [relative-to n]352 (check-enumerated-arg relative-to #{:block :current})353 (indent *out* relative-to n))355 ;; TODO a real implementation for pprint-tab356 (defn pprint-tab357 "Tab at this point in the pretty printing stream. kind specifies whether the tab358 is :line, :section, :line-relative, or :section-relative.360 Colnum and colinc specify the target column and the increment to move the target361 forward if the output is already past the original target.363 This function is intended for use when writing custom dispatch functions.365 Output is sent to *out* which must be a pretty printing writer.367 THIS FUNCTION IS NOT YET IMPLEMENTED."368 {:added "1.2"}369 [kind colnum colinc]370 (check-enumerated-arg kind #{:line :section :line-relative :section-relative})371 (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))374 nil