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