Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

file 446 lines (388 sloc) 17.177 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 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446
;; dispatch.clj -- part of the pretty printer for Clojure

;; by Tom Faulhaber
;; April 3, 2009

; Copyright (c) Tom Faulhaber, Feb 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 default dispatch tables for pretty printing code and
;; data.

(in-ns 'clojure.contrib.pprint)

(defn use-method
  "Installs a function as a new method of multimethod associated with dispatch-value. "
  [multifn dispatch-val func]
  (. multifn addMethod dispatch-val func))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementations of specific dispatch table entries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Handle forms that can be "back-translated" to reader macros
;;; Not all reader macros can be dealt with this way or at all.
;;; Macros that we can't deal with at all are:
;;; ; - The comment character is aborbed by the reader and never is part of the form
;;; ` - Is fully processed at read time into a lisp expression (which will contain concats
;;; and regular quotes).
;;; ~@ - Also fully eaten by the processing of ` and can't be used outside.
;;; , - is whitespace and is lost (like all other whitespace). Formats can generate commas
;;; where they deem them useful to help readability.
;;; #^ - Adding metadata completely disappears at read time and the data appears to be
;;; completely lost.
;;;
;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{})
;;; or directly by printing the objects using Clojure's built-in print functions (like
;;; :keyword, \char, or ""). The notable exception is #() which is special-cased.

(def reader-macros
     {'quote "'", 'clojure.core/deref "@",
      'var "#'", 'clojure.core/unquote "~"})

(defn pprint-reader-macro [alis]
  (let [#^String macro-char (reader-macros (first alis))]
    (when (and macro-char (= 2 (count alis)))
      (.write #^java.io.Writer *out* macro-char)
      (write-out (second alis))
      true)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dispatch for the basic data types when interpreted
;; as data (as opposed to code).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; TODO: inline these formatter statements into funcs so that we
;;; are a little easier on the stack. (Or, do "real" compilation, a
;;; la Common Lisp)

;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))
(defn pprint-simple-list [alis]
  (pprint-logical-block :prefix "(" :suffix ")"
    (loop [alis (seq alis)]
      (when alis
(write-out (first alis))
(when (next alis)
(.write #^java.io.Writer *out* " ")
(pprint-newline :linear)
(recur (next alis)))))))

(defn pprint-list [alis]
  (if-not (pprint-reader-macro alis)
    (pprint-simple-list alis)))

;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>"))
(defn pprint-vector [avec]
  (pprint-logical-block :prefix "[" :suffix "]"
    (loop [aseq (seq avec)]
      (when aseq
(write-out (first aseq))
(when (next aseq)
(.write #^java.io.Writer *out* " ")
(pprint-newline :linear)
(recur (next aseq)))))))

(def pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>"))

;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
(defn pprint-map [amap]
  (pprint-logical-block :prefix "{" :suffix "}"
    (loop [aseq (seq amap)]
      (when aseq
(pprint-logical-block
          (write-out (ffirst aseq))
          (.write #^java.io.Writer *out* " ")
          (pprint-newline :linear)
          (write-out (fnext (first aseq))))
        (when (next aseq)
          (.write #^java.io.Writer *out* ", ")
          (pprint-newline :linear)
          (recur (next aseq)))))))

(def pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))
(defn pprint-ref [ref]
  (pprint-logical-block :prefix "#<Ref " :suffix ">"
    (write-out @ref)))
(defn pprint-atom [ref]
  (pprint-logical-block :prefix "#<Atom " :suffix ">"
    (write-out @ref)))
(defn pprint-agent [ref]
  (pprint-logical-block :prefix "#<Agent " :suffix ">"
    (write-out @ref)))

(defn pprint-simple-default [obj]
  (cond
    (.isArray (class obj)) (pprint-array obj)
    (and *print-suppress-namespaces* (symbol? obj)) (print (name obj))
    :else (pr obj)))


(defmulti
  *simple-dispatch*
  "The pretty print dispatch function for simple data structure format."
  {:arglists '[[object]]}
  class)

(use-method *simple-dispatch* clojure.lang.ISeq pprint-list)
(use-method *simple-dispatch* clojure.lang.IPersistentVector pprint-vector)
(use-method *simple-dispatch* clojure.lang.IPersistentMap pprint-map)
(use-method *simple-dispatch* clojure.lang.IPersistentSet pprint-set)
(use-method *simple-dispatch* clojure.lang.Ref pprint-ref)
(use-method *simple-dispatch* clojure.lang.Atom pprint-atom)
(use-method *simple-dispatch* clojure.lang.Agent pprint-agent)
(use-method *simple-dispatch* nil pr)
(use-method *simple-dispatch* :default pprint-simple-default)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Dispatch for the code table
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare pprint-simple-code-list)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Format something that looks like a simple def (sans metadata, since the reader
;;; won't give it to us now).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Format something that looks like a defn or defmacro
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Format the params and body of a defn with a single arity
(defn- single-defn [alis has-doc-str?]
  (if (seq alis)
    (do
      (if has-doc-str?
        ((formatter-out " ~_"))
        ((formatter-out " ~@_")))
      ((formatter-out "~{~w~^ ~_~}") alis))))

;;; Format the param and body sublists of a defn with multiple arities
(defn- multi-defn [alis has-doc-str?]
  (if (seq alis)
    ((formatter-out " ~_~{~w~^ ~_~}") alis)))

;;; TODO: figure out how to support capturing metadata in defns (we might need a
;;; special reader)
(defn pprint-defn [alis]
  (if (next alis)
    (let [[defn-sym defn-name & stuff] alis
          [doc-str stuff] (if (string? (first stuff))
                            [(first stuff) (next stuff)]
                            [nil stuff])
          [attr-map stuff] (if (map? (first stuff))
                             [(first stuff) (next stuff)]
                             [nil stuff])]
      (pprint-logical-block :prefix "(" :suffix ")"
        ((formatter-out "~w ~1I~@_~w") defn-sym defn-name)
        (if doc-str
          ((formatter-out " ~_~w") doc-str))
        (if attr-map
          ((formatter-out " ~_~w") attr-map))
        ;; Note: the multi-defn case will work OK for malformed defns too
        (cond
         (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
         :else (multi-defn stuff (or doc-str attr-map)))))
    (pprint-simple-code-list alis)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Format something with a binding form
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn pprint-binding-form [binding-vec]
  (pprint-logical-block :prefix "[" :suffix "]"
    (loop [binding binding-vec]
      (when (seq binding)
        (pprint-logical-block binding
          (write-out (first binding))
          (when (next binding)
            (.write #^java.io.Writer *out* " ")
            (pprint-newline :miser)
            (write-out (second binding))))
        (when (next (rest binding))
          (.write #^java.io.Writer *out* " ")
          (pprint-newline :linear)
          (recur (next (rest binding))))))))

(defn pprint-let [alis]
  (let [base-sym (first alis)]
    (pprint-logical-block :prefix "(" :suffix ")"
      (if (and (next alis) (vector? (second alis)))
        (do
          ((formatter-out "~w ~1I~@_") base-sym)
          (pprint-binding-form (second alis))
          ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis))))
        (pprint-simple-code-list alis)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Format something that looks like "if"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>"))

(defn pprint-cond [alis]
  (pprint-logical-block :prefix "(" :suffix ")"
    (pprint-indent :block 1)
    (write-out (first alis))
    (when (next alis)
      (.write #^java.io.Writer *out* " ")
      (pprint-newline :linear)
     (loop [alis (next alis)]
       (when alis
         (pprint-logical-block alis
          (write-out (first alis))
          (when (next alis)
            (.write #^java.io.Writer *out* " ")
            (pprint-newline :miser)
            (write-out (second alis))))
         (when (next (rest alis))
           (.write #^java.io.Writer *out* " ")
           (pprint-newline :linear)
           (recur (next (rest alis)))))))))

(defn pprint-condp [alis]
  (if (> (count alis) 3)
    (pprint-logical-block :prefix "(" :suffix ")"
      (pprint-indent :block 1)
      (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)
      (loop [alis (seq (drop 3 alis))]
        (when alis
          (pprint-logical-block alis
            (write-out (first alis))
            (when (next alis)
              (.write #^java.io.Writer *out* " ")
              (pprint-newline :miser)
              (write-out (second alis))))
          (when (next (rest alis))
            (.write #^java.io.Writer *out* " ")
            (pprint-newline :linear)
            (recur (next (rest alis)))))))
    (pprint-simple-code-list alis)))

;;; The map of symbols that are defined in an enclosing #() anonymous function
(def *symbol-map* {})

(defn pprint-anon-func [alis]
  (let [args (second alis)
        nlis (first (rest (rest alis)))]
    (if (vector? args)
      (binding [*symbol-map* (if (= 1 (count args))
                               {(first args) "%"}
                               (into {}
                                     (map
                                      #(vector %1 (str \% %2))
                                      args
                                      (range 1 (inc (count args))))))]
        ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis))
      (pprint-simple-code-list alis))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The master definitions for formatting lists in code (that is, (fn args...) or
;;; special forms).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is
;;; easier on the stack.

(defn pprint-simple-code-list [alis]
  (pprint-logical-block :prefix "(" :suffix ")"
    (pprint-indent :block 1)
    (loop [alis (seq alis)]
      (when alis
(write-out (first alis))
(when (next alis)
(.write #^java.io.Writer *out* " ")
(pprint-newline :linear)
(recur (next alis)))))))

;;; Take a map with symbols as keys and add versions with no namespace.
;;; That is, if ns/sym->val is in the map, add sym->val to the result.
(defn two-forms [amap]
  (into {}
        (mapcat
         identity
         (for [x amap]
           [x [(symbol (name (first x))) (second x)]]))))

(defn add-core-ns [amap]
  (let [core "clojure.core"]
    (into {}
          (map #(let [[s f] %]
                  (if (not (or (namespace s) (special-symbol? s)))
                    [(symbol core (name s)) f]
                    %))
               amap))))

(def *code-table*
     (two-forms
      (add-core-ns
       {'def pprint-hold-first, 'defonce pprint-hold-first,
'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn,
        'let pprint-let, 'loop pprint-let, 'binding pprint-let,
        'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let,
'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let,
'when-first pprint-let,
        'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if,
        'cond pprint-cond, 'condp pprint-condp,
        'fn* pprint-anon-func,
        '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first,
        'locking pprint-hold-first, 'struct pprint-hold-first,
        'struct-map pprint-hold-first,
        })))

(defn pprint-code-list [alis]
  (if-not (pprint-reader-macro alis)
    (if-let [special-form (*code-table* (first alis))]
      (special-form alis)
      (pprint-simple-code-list alis))))

(defn pprint-code-symbol [sym]
  (if-let [arg-num (sym *symbol-map*)]
    (print arg-num)
    (if *print-suppress-namespaces*
      (print (name sym))
      (pr sym))))

(defmulti
  *code-dispatch*
  "The pretty print dispatch function for pretty printing Clojure code."
  {:arglists '[[object]]}
  class)

(use-method *code-dispatch* clojure.lang.ISeq pprint-code-list)
(use-method *code-dispatch* clojure.lang.Symbol pprint-code-symbol)

;; The following are all exact copies of *simple-dispatch*
(use-method *code-dispatch* clojure.lang.IPersistentVector pprint-vector)
(use-method *code-dispatch* clojure.lang.IPersistentMap pprint-map)
(use-method *code-dispatch* clojure.lang.IPersistentSet pprint-set)
(use-method *code-dispatch* clojure.lang.Ref pprint-ref)
(use-method *code-dispatch* clojure.lang.Atom pprint-atom)
(use-method *code-dispatch* clojure.lang.Agent pprint-agent)
(use-method *code-dispatch* nil pr)
(use-method *code-dispatch* :default pprint-simple-default)

(set-pprint-dispatch *simple-dispatch*)


;;; For testing
(comment

(with-pprint-dispatch *code-dispatch*
  (pprint
   '(defn cl-format
      "An implementation of a Common Lisp compatible format function"
      [stream format-in & args]
      (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
            navigator (init-navigator args)]
        (execute-format stream compiled-format navigator)))))

(with-pprint-dispatch *code-dispatch*
  (pprint
   '(defn cl-format
      [stream format-in & args]
      (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
            navigator (init-navigator args)]
        (execute-format stream compiled-format navigator)))))

(with-pprint-dispatch *code-dispatch*
  (pprint
   '(defn- -write
      ([this x]
         (condp = (class x)
           String
           (let [s0 (write-initial-lines this x)
                 s (.replaceFirst s0 "\\s+$" "")
                 white-space (.substring s0 (count s))
                 mode (getf :mode)]
             (if (= mode :writing)
               (dosync
                (write-white-space this)
                (.col_write this s)
                (setf :trailing-white-space white-space))
               (add-to-buffer this (make-buffer-blob s white-space))))

           Integer
           (let [c #^Character x]
             (if (= (getf :mode) :writing)
               (do
                 (write-white-space this)
                 (.col_write this x))
               (if (= c (int \newline))
                 (write-initial-lines this "\n")
                 (add-to-buffer this (make-buffer-blob (str (char c)) nil))))))))))

(with-pprint-dispatch *code-dispatch*
  (pprint
   '(defn pprint-defn [writer alis]
      (if (next alis)
        (let [[defn-sym defn-name & stuff] alis
              [doc-str stuff] (if (string? (first stuff))
                                [(first stuff) (next stuff)]
                                [nil stuff])
              [attr-map stuff] (if (map? (first stuff))
                                 [(first stuff) (next stuff)]
                                 [nil stuff])]
          (pprint-logical-block writer :prefix "(" :suffix ")"
                                (cl-format true "~w ~1I~@_~w" defn-sym defn-name)
                                (if doc-str
                                  (cl-format true " ~_~w" doc-str))
                                (if attr-map
                                  (cl-format true " ~_~w" attr-map))
                                ;; Note: the multi-defn case will work OK for malformed defns too
                                (cond
                                  (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
                                  :else (multi-defn stuff (or doc-str attr-map)))))
        (pprint-simple-code-list writer alis)))))
)
nil
Something went wrong with that request. Please try again.