lasercutter: src/clojure/contrib/pprint/pprint

comparison src/clojure/contrib/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

comparison

equal deleted inserted replaced

-:35cf337adfcf
+:ef7dbbd6452c
+;;; pprint_base.clj -- part of the pretty printer for Clojure
+;; by Tom Faulhaber
+;; April 3, 2009
+;   Copyright (c) Tom Faulhaber, Jan 2009. 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.
+;; This module implements the generic pretty print functions and special variables
+(in-ns 'clojure.contrib.pprint)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Variables that control the pretty printer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core
+;;; TODO: use *print-dup* here (or is it supplanted by other variables?)
+;;; TODO: make dispatch items like "(let..." get counted in *print-length*
+;;; constructs
+(def
+^{ :doc "Bind to true if you want write to use pretty printing"}
+*print-pretty* true)
+(defonce ; If folks have added stuff here, don't overwrite
+^{ :doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch
+to modify."}
+*print-pprint-dispatch* nil)
+(def
+^{ :doc "Pretty printing will try to avoid anything going beyond this column.
+Set it to nil to have pprint let the line be arbitrarily long. This will ignore all
+non-mandatory newlines."}
+*print-right-margin* 72)
+(def
+^{ :doc "The column at which to enter miser style. Depending on the dispatch table,
+miser style add newlines in more places to try to keep lines short allowing for further
+levels of nesting."}
+*print-miser-width* 40)
+;;; TODO implement output limiting
+(def
+^{ :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"}
+*print-lines* nil)
+;;; TODO: implement circle and shared
+(def
+^{ :doc "Mark circular structures (N.B. This is not yet used)"}
+*print-circle* nil)
+;;; TODO: should we just use *print-dup* here?
+(def
+^{ :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"}
+*print-shared* nil)
+(def
+^{ :doc "Don't print namespaces with symbols. This is particularly useful when
+pretty printing the results of macro expansions"}
+*print-suppress-namespaces* nil)
+;;; TODO: support print-base and print-radix in cl-format
+;;; TODO: support print-base and print-radix in rationals
+(def
+^{ :doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8,
+or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the
+radix specifier is in the form #XXr where XX is the decimal value of *print-base* "}
+*print-radix* nil)
+(def
+^{ :doc "The base to use for printing integers and rationals."}
+*print-base* 10)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Internal variables that keep track of where we are in the
+;; structure
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def ^{ :private true } *current-level* 0)
+(def ^{ :private true } *current-length* nil)
+;; TODO: add variables for length, lines.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for the write function
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(declare format-simple-number)
+(def ^{:private true} orig-pr pr)
+(defn- pr-with-base [x]
+(if-let [s (format-simple-number x)]
+(print s)
+(orig-pr x)))
+(def ^{:private true} write-option-table
+{;:array            *print-array*
+:base             'clojure.contrib.pprint/*print-base*,
+;;:case             *print-case*,
+:circle           'clojure.contrib.pprint/*print-circle*,
+;;:escape           *print-escape*,
+;;:gensym           *print-gensym*,
+:length           'clojure.core/*print-length*,
+:level            'clojure.core/*print-level*,
+:lines            'clojure.contrib.pprint/*print-lines*,
+:miser-width      'clojure.contrib.pprint/*print-miser-width*,
+:dispatch         'clojure.contrib.pprint/*print-pprint-dispatch*,
+:pretty           'clojure.contrib.pprint/*print-pretty*,
+:radix            'clojure.contrib.pprint/*print-radix*,
+:readably         'clojure.core/*print-readably*,
+:right-margin     'clojure.contrib.pprint/*print-right-margin*,
+:suppress-namespaces 'clojure.contrib.pprint/*print-suppress-namespaces*})
+(defmacro ^{:private true} binding-map [amap & body]
+(let []
+`(do
+(. clojure.lang.Var (pushThreadBindings ~amap))
+(try
+~@body
+(finally
+(. clojure.lang.Var (popThreadBindings)))))))
+(defn- table-ize [t m]
+(apply hash-map (mapcat
+#(when-let [v (get t (key %))] [(find-var v) (val %)])
+m)))
+(defn- pretty-writer?
+"Return true iff x is a PrettyWriter"
+[x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x)))
+(defn- make-pretty-writer
+"Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width"
+[base-writer right-margin miser-width]
+(pretty-writer base-writer right-margin miser-width))
+(defmacro ^{:private true} with-pretty-writer [base-writer & body]
+`(let [base-writer# ~base-writer
+new-writer# (not (pretty-writer? base-writer#))]
+(binding [*out* (if new-writer#
+(make-pretty-writer base-writer# *print-right-margin* *print-miser-width*)
+base-writer#)]
+~@body
+(.flush *out*))))
+;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc.
+(defn write-out
+"Write an object to *out* subject to the current bindings of the printer control
+variables. Use the kw-args argument to override individual variables for this call (and
+any recursive calls).
+*out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility
+of the caller.
+This method is primarily intended for use by pretty print dispatch functions that
+already know that the pretty printer will have set up their environment appropriately.
+Normal library clients should use the standard \"write\" interface. "
+[object]
+(let [length-reached (and
+*current-length*
+*print-length*
+(>= *current-length* *print-length*))]
+(if-not *print-pretty*
+(pr object)
+(if length-reached
+(print "...")
+(do
+(if *current-length* (set! *current-length* (inc *current-length*)))
+(*print-pprint-dispatch* object))))
+length-reached))
+(defn write
+"Write an object subject to the current bindings of the printer control variables.
+Use the kw-args argument to override individual variables for this call (and any
+recursive calls). Returns the string result if :stream is nil or nil otherwise.
+The following keyword arguments can be passed with values:
+Keyword              Meaning                              Default value
+:stream              Writer for output or nil             true (indicates *out*)
+:base                Base to use for writing rationals    Current value of *print-base*
+:circle*             If true, mark circular structures    Current value of *print-circle*
+:length              Maximum elements to show in sublists Current value of *print-length*
+:level               Maximum depth                        Current value of *print-level*
+:lines*              Maximum lines of output              Current value of *print-lines*
+:miser-width         Width to enter miser mode            Current value of *print-miser-width*
+:dispatch            The pretty print dispatch function   Current value of *print-pprint-dispatch*
+:pretty              If true, do pretty printing          Current value of *print-pretty*
+:radix               If true, prepend a radix specifier   Current value of *print-radix*
+:readably*           If true, print readably              Current value of *print-readably*
+:right-margin        The column for the right margin      Current value of *print-right-margin*
+:suppress-namespaces If true, no namespaces in symbols    Current value of *print-suppress-namespaces*
+* = not yet supported
+"
+[object & kw-args]
+(let [options (merge {:stream true} (apply hash-map kw-args))]
+(binding-map (table-ize write-option-table options)
+(binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {})
+(let [optval (if (contains? options :stream)
+(:stream options)
+true)
+base-writer (condp = optval
+nil (java.io.StringWriter.)
+true *out*
+optval)]
+(if *print-pretty*
+(with-pretty-writer base-writer
+(write-out object))
+(binding [*out* base-writer]
+(pr object)))
+(if (nil? optval)
+(.toString ^java.io.StringWriter base-writer)))))))
+(defn pprint
+"Pretty print object to the optional output writer. If the writer is not provided,
+print the object to the currently bound value of *out*."
+([object] (pprint object *out*))
+([object writer]
+(with-pretty-writer writer
+(binding [*print-pretty* true]
+(binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {})
+(write-out object)))
+(if (not (= 0 (get-column *out*)))
+(.write *out* (int \newline))))))
+(defmacro pp
+"A convenience macro that pretty prints the last thing output. This is
+exactly equivalent to (pprint *1)."
+[] `(pprint *1))
+(defn set-pprint-dispatch
+"Set the pretty print dispatch function to a function matching (fn [obj] ...)
+where obj is the object to pretty print. That function will be called with *out* set
+to a pretty printing writer to which it should do its printing.
+For example functions, see *simple-dispatch* and *code-dispatch* in
+clojure.contrib.pprint.dispatch.clj."
+[function]
+(let [old-meta (meta #'*print-pprint-dispatch*)]
+(alter-var-root #'*print-pprint-dispatch* (constantly function))
+(alter-meta! #'*print-pprint-dispatch* (constantly old-meta)))
+nil)
+(defmacro with-pprint-dispatch
+"Execute body with the pretty print dispatch function bound to function."
+[function & body]
+`(binding [*print-pprint-dispatch* ~function]
+~@body))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for the functional interface to the pretty printer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defn- parse-lb-options [opts body]
+(loop [body body
+acc []]
+(if (opts (first body))
+(recur (drop 2 body) (concat acc (take 2 body)))
+[(apply hash-map acc) body])))
+(defn- check-enumerated-arg [arg choices]
+(if-not (choices arg)
+(throw
+(IllegalArgumentException.
+;; TODO clean up choices string
+(str "Bad argument: " arg ". It must be one of " choices)))))
+(defn level-exceeded []
+(and *print-level* (>= *current-level* *print-level*)))
+(defmacro pprint-logical-block
+"Execute the body as a pretty printing logical block with output to *out* which
+must be a pretty printing writer. When used from pprint or cl-format, this can be
+assumed.
+Before the body, the caller can optionally specify options: :prefix, :per-line-prefix,
+and :suffix."
+{:arglists '[[options* body]]}
+[& args]
+(let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
+`(do (if (level-exceeded)
+(.write ^java.io.Writer *out* "#")
+(binding [*current-level* (inc *current-level*)
+*current-length* 0]
+(start-block *out*
+~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))
+~@body
+(end-block *out*)))
+nil)))
+(defn pprint-newline
+"Print a conditional newline to a pretty printing stream. kind specifies if the
+newline is :linear, :miser, :fill, or :mandatory.
+Output is sent to *out* which must be a pretty printing writer."
+[kind]
+(check-enumerated-arg kind #{:linear :miser :fill :mandatory})
+(nl *out* kind))
+(defn pprint-indent
+"Create an indent at this point in the pretty printing stream. This defines how
+following lines are indented. relative-to can be either :block or :current depending
+whether the indent should be computed relative to the start of the logical block or
+the current column position. n is an offset.
+Output is sent to *out* which must be a pretty printing writer."
+[relative-to n]
+(check-enumerated-arg relative-to #{:block :current})
+(indent *out* relative-to n))
+;; TODO a real implementation for pprint-tab
+(defn pprint-tab
+"Tab at this point in the pretty printing stream. kind specifies whether the tab
+is :line, :section, :line-relative, or :section-relative.
+Colnum and colinc specify the target column and the increment to move the target
+forward if the output is already past the original target.
+Output is sent to *out* which must be a pretty printing writer.
+THIS FUNCTION IS NOT YET IMPLEMENTED."
+[kind colnum colinc]
+(check-enumerated-arg kind #{:line :section :line-relative :section-relative})
+(throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))
+nil

Mercurial > lasercutter

comparison src/clojure/contrib/pprint/pprint_base.clj @ 10:ef7dbbd6452c