Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 404 lines (332 sloc) 15.647 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403
;;; pprint_base.clj -- part of the pretty printer for Clojure

; Copyright (c) Rich Hickey. 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.

;; Author: Tom Faulhaber
;; April 3, 2009


;; This module implements the generic pretty print functions and special variables

(in-ns 'clojure.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 ^:dynamic
 ^{:doc "Bind to true if you want write to use pretty printing", :added "1.2"}
 *print-pretty* true)

(defonce ^:dynamic ; 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.",
   :added "1.2"}
 *print-pprint-dispatch* nil)

(def ^:dynamic
 ^{: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.",
   :added "1.2"}
 *print-right-margin* 72)

(def ^:dynamic
 ^{: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.",
   :added "1.2"}
 *print-miser-width* 40)

;;; TODO implement output limiting
(def ^:dynamic
 ^{:private true,
   :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 ^:dynamic
 ^{:private true,
   :doc "Mark circular structures (N.B. This is not yet used)"}
 *print-circle* nil)

;;; TODO: should we just use *print-dup* here?
(def ^:dynamic
 ^{:private true,
   :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"}
 *print-shared* nil)

(def ^:dynamic
 ^{:doc "Don't print namespaces with symbols. This is particularly useful when
pretty printing the results of macro expansions"
   :added "1.2"}
 *print-suppress-namespaces* nil)

;;; TODO: support print-base and print-radix in cl-format
;;; TODO: support print-base and print-radix in rationals
(def ^:dynamic
 ^{: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* "
   :added "1.2"}
 *print-radix* nil)

(def ^:dynamic
 ^{:doc "The base to use for printing integers and rationals."
   :added "1.2"}
 *print-base* 10)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal variables that keep track of where we are in the
;; structure
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def ^:dynamic ^{ :private true } *current-level* 0)

(def ^:dynamic ^{ :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.pprint/*print-base*,
      ;;:case *print-case*,
      :circle 'clojure.pprint/*print-circle*,
      ;;:escape *print-escape*,
      ;;:gensym *print-gensym*,
      :length 'clojure.core/*print-length*,
      :level 'clojure.core/*print-level*,
      :lines 'clojure.pprint/*print-lines*,
      :miser-width 'clojure.pprint/*print-miser-width*,
      :dispatch 'clojure.pprint/*print-pprint-dispatch*,
      :pretty 'clojure.pprint/*print-pretty*,
      :radix 'clojure.pprint/*print-radix*,
      :readably 'clojure.core/*print-readably*,
      :right-margin 'clojure.pprint/*print-right-margin*,
      :suppress-namespaces 'clojure.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
       (.ppflush *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. "
  {:added "1.2"}
  [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
"
  {:added "1.2"}
  [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*."
  {:added "1.2"}
  ([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*)))
         (prn)))))

(defmacro pp
  "A convenience macro that pretty prints the last thing output. This is
exactly equivalent to (pprint *1)."
  {:added "1.2"}
  [] `(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.pprint.dispatch.clj."
  {:added "1.2"}
  [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."
  {:added "1.2"}
  [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.

This function is intended for use when writing custom dispatch functions.

Before the body, the caller can optionally specify options: :prefix, :per-line-prefix,
and :suffix."
  {:added "1.2", :arglists '[[options* body]]}
  [& args]
  (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
    `(do (if (#'clojure.pprint/level-exceeded)
           (.write ^java.io.Writer *out* "#")
           (do
             (push-thread-bindings {#'clojure.pprint/*current-level*
                                    (inc (var-get #'clojure.pprint/*current-level*))
                                    #'clojure.pprint/*current-length* 0})
             (try
              (#'clojure.pprint/start-block *out*
                           ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))
              ~@body
              (#'clojure.pprint/end-block *out*)
              (finally
               (pop-thread-bindings)))))
         nil)))

(defn pprint-newline
  "Print a conditional newline to a pretty printing stream. kind specifies if the
newline is :linear, :miser, :fill, or :mandatory.

This function is intended for use when writing custom dispatch functions.

Output is sent to *out* which must be a pretty printing writer."
  {:added "1.2"}
  [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.

This function is intended for use when writing custom dispatch functions.

Output is sent to *out* which must be a pretty printing writer."
  {:added "1.2"}
  [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.

This function is intended for use when writing custom dispatch functions.

Output is sent to *out* which must be a pretty printing writer.

THIS FUNCTION IS NOT YET IMPLEMENTED."
  {:added "1.2"}
  [kind colnum colinc]
  (check-enumerated-arg kind #{:line :section :line-relative :section-relative})
  (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Helpers for dispatch function writing
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- pll-mod-body [var-sym body]
  (letfn [(inner [form]
                 (if (seq? form)
                   (let [form (macroexpand form)]
                     (condp = (first form)
                       'loop* form
                       'recur (concat `(recur (inc ~var-sym)) (rest form))
                       (walk inner identity form)))
                   form))]
    (walk inner identity body)))

(defmacro print-length-loop
  "A version of loop that iterates at most *print-length* times. This is designed
for use in pretty-printer dispatch functions."
  {:added "1.3"}
  [bindings & body]
  (let [count-var (gensym "length-count")
        mod-body (pll-mod-body count-var body)]
    `(loop ~(apply vector count-var 0 bindings)
       (if (or (not *print-length*) (< ~count-var *print-length*))
         (do ~@mod-body)
         (.write ^java.io.Writer *out* "...")))))

nil
Something went wrong with that request. Please try again.