1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/pprint/dispatch.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,447 @@
     1.4 +;; dispatch.clj -- part of the pretty printer for Clojure
     1.5 +
     1.6 +;; by Tom Faulhaber
     1.7 +;; April 3, 2009
     1.8 +
     1.9 +;   Copyright (c) Tom Faulhaber, Feb 2009. All rights reserved.
    1.10 +;   The use and distribution terms for this software are covered by the
    1.11 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
    1.12 +;   which can be found in the file epl-v10.html at the root of this distribution.
    1.13 +;   By using this software in any fashion, you are agreeing to be bound by
    1.14 +;   the terms of this license.
    1.15 +;   You must not remove this notice, or any other, from this software.
    1.16 +
    1.17 +;; This module implements the default dispatch tables for pretty printing code and
    1.18 +;; data.
    1.19 +
    1.20 +(in-ns 'clojure.contrib.pprint)
    1.21 +
    1.22 +(defn use-method
    1.23 +  "Installs a function as a new method of multimethod associated with dispatch-value. "
    1.24 +  [multifn dispatch-val func]
    1.25 +  (. multifn addMethod dispatch-val func))
    1.26 +
    1.27 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.28 +;; Implementations of specific dispatch table entries
    1.29 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.30 +
    1.31 +;;; Handle forms that can be "back-translated" to reader macros
    1.32 +;;; Not all reader macros can be dealt with this way or at all. 
    1.33 +;;; Macros that we can't deal with at all are:
    1.34 +;;; ;  - The comment character is aborbed by the reader and never is part of the form
    1.35 +;;; `  - Is fully processed at read time into a lisp expression (which will contain concats
    1.36 +;;;      and regular quotes).
    1.37 +;;; ~@ - Also fully eaten by the processing of ` and can't be used outside.
    1.38 +;;; ,  - is whitespace and is lost (like all other whitespace). Formats can generate commas
    1.39 +;;;      where they deem them useful to help readability.
    1.40 +;;; ^ - Adding metadata completely disappears at read time and the data appears to be
    1.41 +;;;      completely lost.
    1.42 +;;;
    1.43 +;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{})
    1.44 +;;; or directly by printing the objects using Clojure's built-in print functions (like
    1.45 +;;; :keyword, \char, or ""). The notable exception is #() which is special-cased.
    1.46 +
    1.47 +(def reader-macros
    1.48 +     {'quote "'", 'clojure.core/deref "@", 
    1.49 +      'var "#'", 'clojure.core/unquote "~"})
    1.50 +
    1.51 +(defn pprint-reader-macro [alis]
    1.52 +  (let [^String macro-char (reader-macros (first alis))]
    1.53 +    (when (and macro-char (= 2 (count alis)))
    1.54 +      (.write ^java.io.Writer *out* macro-char)
    1.55 +      (write-out (second alis))
    1.56 +      true)))
    1.57 +
    1.58 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.59 +;; Dispatch for the basic data types when interpreted
    1.60 +;; as data (as opposed to code).
    1.61 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.62 +
    1.63 +;;; TODO: inline these formatter statements into funcs so that we
    1.64 +;;; are a little easier on the stack. (Or, do "real" compilation, a
    1.65 +;;; la Common Lisp)
    1.66 +
    1.67 +;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))
    1.68 +(defn pprint-simple-list [alis]
    1.69 +  (pprint-logical-block :prefix "(" :suffix ")"
    1.70 +    (loop [alis (seq alis)]
    1.71 +      (when alis
    1.72 +	(write-out (first alis))
    1.73 +	(when (next alis)
    1.74 +	  (.write ^java.io.Writer *out* " ")
    1.75 +	  (pprint-newline :linear)
    1.76 +	  (recur (next alis)))))))
    1.77 +
    1.78 +(defn pprint-list [alis]
    1.79 +  (if-not (pprint-reader-macro alis)
    1.80 +    (pprint-simple-list alis)))
    1.81 +
    1.82 +;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>"))
    1.83 +(defn pprint-vector [avec]
    1.84 +  (pprint-logical-block :prefix "[" :suffix "]"
    1.85 +    (loop [aseq (seq avec)]
    1.86 +      (when aseq
    1.87 +	(write-out (first aseq))
    1.88 +	(when (next aseq)
    1.89 +	  (.write ^java.io.Writer *out* " ")
    1.90 +	  (pprint-newline :linear)
    1.91 +	  (recur (next aseq)))))))
    1.92 +
    1.93 +(def pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>"))
    1.94 +
    1.95 +;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
    1.96 +(defn pprint-map [amap]
    1.97 +  (pprint-logical-block :prefix "{" :suffix "}"
    1.98 +    (loop [aseq (seq amap)]
    1.99 +      (when aseq
   1.100 +	(pprint-logical-block 
   1.101 +          (write-out (ffirst aseq))
   1.102 +          (.write ^java.io.Writer *out* " ")
   1.103 +          (pprint-newline :linear)
   1.104 +          (write-out (fnext (first aseq))))
   1.105 +        (when (next aseq)
   1.106 +          (.write ^java.io.Writer *out* ", ")
   1.107 +          (pprint-newline :linear)
   1.108 +          (recur (next aseq)))))))
   1.109 +
   1.110 +(def pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))
   1.111 +(defn pprint-ref [ref]
   1.112 +  (pprint-logical-block  :prefix "#<Ref " :suffix ">"
   1.113 +    (write-out @ref)))
   1.114 +(defn pprint-atom [ref]
   1.115 +  (pprint-logical-block :prefix "#<Atom " :suffix ">"
   1.116 +    (write-out @ref)))
   1.117 +(defn pprint-agent [ref]
   1.118 +  (pprint-logical-block :prefix "#<Agent " :suffix ">"
   1.119 +    (write-out @ref)))
   1.120 +
   1.121 +(defn pprint-simple-default [obj]
   1.122 +  (cond 
   1.123 +    (.isArray (class obj)) (pprint-array obj)
   1.124 +    (and *print-suppress-namespaces* (symbol? obj)) (print (name obj))
   1.125 +    :else (pr obj)))
   1.126 +
   1.127 +
   1.128 +(defmulti 
   1.129 +  *simple-dispatch*
   1.130 +  "The pretty print dispatch function for simple data structure format."
   1.131 +  {:arglists '[[object]]} 
   1.132 +  class)
   1.133 +
   1.134 +(use-method *simple-dispatch* clojure.lang.ISeq pprint-list)
   1.135 +(use-method *simple-dispatch* clojure.lang.IPersistentVector pprint-vector)
   1.136 +(use-method *simple-dispatch* clojure.lang.IPersistentMap pprint-map)
   1.137 +(use-method *simple-dispatch* clojure.lang.IPersistentSet pprint-set)
   1.138 +(use-method *simple-dispatch* clojure.lang.Ref pprint-ref)
   1.139 +(use-method *simple-dispatch* clojure.lang.Atom pprint-atom)
   1.140 +(use-method *simple-dispatch* clojure.lang.Agent pprint-agent)
   1.141 +(use-method *simple-dispatch* nil pr)
   1.142 +(use-method *simple-dispatch* :default pprint-simple-default)
   1.143 +
   1.144 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.145 +;;; Dispatch for the code table
   1.146 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.147 +
   1.148 +(declare pprint-simple-code-list)
   1.149 +
   1.150 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.151 +;;; Format something that looks like a simple def (sans metadata, since the reader
   1.152 +;;; won't give it to us now).
   1.153 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.154 +
   1.155 +(def pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>"))
   1.156 +
   1.157 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.158 +;;; Format something that looks like a defn or defmacro
   1.159 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.160 +
   1.161 +;;; Format the params and body of a defn with a single arity
   1.162 +(defn- single-defn [alis has-doc-str?]
   1.163 +  (if (seq alis)
   1.164 +    (do
   1.165 +      (if has-doc-str?
   1.166 +        ((formatter-out " ~_"))
   1.167 +        ((formatter-out " ~@_")))
   1.168 +      ((formatter-out "~{~w~^ ~_~}") alis))))
   1.169 +
   1.170 +;;; Format the param and body sublists of a defn with multiple arities
   1.171 +(defn- multi-defn [alis has-doc-str?]
   1.172 +  (if (seq alis)
   1.173 +    ((formatter-out " ~_~{~w~^ ~_~}") alis)))
   1.174 +
   1.175 +;;; TODO: figure out how to support capturing metadata in defns (we might need a 
   1.176 +;;; special reader)
   1.177 +(defn pprint-defn [alis]
   1.178 +  (if (next alis) 
   1.179 +    (let [[defn-sym defn-name & stuff] alis
   1.180 +          [doc-str stuff] (if (string? (first stuff))
   1.181 +                            [(first stuff) (next stuff)]
   1.182 +                            [nil stuff])
   1.183 +          [attr-map stuff] (if (map? (first stuff))
   1.184 +                             [(first stuff) (next stuff)]
   1.185 +                             [nil stuff])]
   1.186 +      (pprint-logical-block :prefix "(" :suffix ")"
   1.187 +        ((formatter-out "~w ~1I~@_~w") defn-sym defn-name)
   1.188 +        (if doc-str
   1.189 +          ((formatter-out " ~_~w") doc-str))
   1.190 +        (if attr-map
   1.191 +          ((formatter-out " ~_~w") attr-map))
   1.192 +        ;; Note: the multi-defn case will work OK for malformed defns too
   1.193 +        (cond
   1.194 +         (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
   1.195 +         :else (multi-defn stuff (or doc-str attr-map)))))
   1.196 +    (pprint-simple-code-list alis)))
   1.197 +
   1.198 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.199 +;;; Format something with a binding form
   1.200 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.201 +
   1.202 +(defn pprint-binding-form [binding-vec]
   1.203 +  (pprint-logical-block :prefix "[" :suffix "]"
   1.204 +    (loop [binding binding-vec]
   1.205 +      (when (seq binding)
   1.206 +        (pprint-logical-block binding
   1.207 +          (write-out (first binding))
   1.208 +          (when (next binding)
   1.209 +            (.write ^java.io.Writer *out* " ")
   1.210 +            (pprint-newline :miser)
   1.211 +            (write-out (second binding))))
   1.212 +        (when (next (rest binding))
   1.213 +          (.write ^java.io.Writer *out* " ")
   1.214 +          (pprint-newline :linear)
   1.215 +          (recur (next (rest binding))))))))
   1.216 +
   1.217 +(defn pprint-let [alis]
   1.218 +  (let [base-sym (first alis)]
   1.219 +    (pprint-logical-block :prefix "(" :suffix ")"
   1.220 +      (if (and (next alis) (vector? (second alis)))
   1.221 +        (do
   1.222 +          ((formatter-out "~w ~1I~@_") base-sym)
   1.223 +          (pprint-binding-form (second alis))
   1.224 +          ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis))))
   1.225 +        (pprint-simple-code-list alis)))))
   1.226 +
   1.227 +
   1.228 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.229 +;;; Format something that looks like "if"
   1.230 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.231 +
   1.232 +(def pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>"))
   1.233 +
   1.234 +(defn pprint-cond [alis]
   1.235 +  (pprint-logical-block :prefix "(" :suffix ")"
   1.236 +    (pprint-indent :block 1)
   1.237 +    (write-out (first alis))
   1.238 +    (when (next alis)
   1.239 +      (.write ^java.io.Writer *out* " ")
   1.240 +      (pprint-newline :linear)
   1.241 +     (loop [alis (next alis)]
   1.242 +       (when alis
   1.243 +         (pprint-logical-block alis
   1.244 +          (write-out (first alis))
   1.245 +          (when (next alis)
   1.246 +            (.write ^java.io.Writer *out* " ")
   1.247 +            (pprint-newline :miser)
   1.248 +            (write-out (second alis))))
   1.249 +         (when (next (rest alis))
   1.250 +           (.write ^java.io.Writer *out* " ")
   1.251 +           (pprint-newline :linear)
   1.252 +           (recur (next (rest alis)))))))))
   1.253 +
   1.254 +(defn pprint-condp [alis]
   1.255 +  (if (> (count alis) 3) 
   1.256 +    (pprint-logical-block :prefix "(" :suffix ")"
   1.257 +      (pprint-indent :block 1)
   1.258 +      (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)
   1.259 +      (loop [alis (seq (drop 3 alis))]
   1.260 +        (when alis
   1.261 +          (pprint-logical-block alis
   1.262 +            (write-out (first alis))
   1.263 +            (when (next alis)
   1.264 +              (.write ^java.io.Writer *out* " ")
   1.265 +              (pprint-newline :miser)
   1.266 +              (write-out (second alis))))
   1.267 +          (when (next (rest alis))
   1.268 +            (.write ^java.io.Writer *out* " ")
   1.269 +            (pprint-newline :linear)
   1.270 +            (recur (next (rest alis)))))))
   1.271 +    (pprint-simple-code-list alis)))
   1.272 +
   1.273 +;;; The map of symbols that are defined in an enclosing #() anonymous function
   1.274 +(def *symbol-map* {})
   1.275 +
   1.276 +(defn pprint-anon-func [alis]
   1.277 +  (let [args (second alis)
   1.278 +        nlis (first (rest (rest alis)))]
   1.279 +    (if (vector? args)
   1.280 +      (binding [*symbol-map* (if (= 1 (count args)) 
   1.281 +                               {(first args) "%"}
   1.282 +                               (into {} 
   1.283 +                                     (map 
   1.284 +                                      #(vector %1 (str \% %2)) 
   1.285 +                                      args 
   1.286 +                                      (range 1 (inc (count args))))))]
   1.287 +        ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis))
   1.288 +      (pprint-simple-code-list alis))))
   1.289 +
   1.290 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.291 +;;; The master definitions for formatting lists in code (that is, (fn args...) or
   1.292 +;;; special forms).
   1.293 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.294 +
   1.295 +;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is
   1.296 +;;; easier on the stack.
   1.297 +
   1.298 +(defn pprint-simple-code-list [alis]
   1.299 +  (pprint-logical-block :prefix "(" :suffix ")"
   1.300 +    (pprint-indent :block 1)
   1.301 +    (loop [alis (seq alis)]
   1.302 +      (when alis
   1.303 +	(write-out (first alis))
   1.304 +	(when (next alis)
   1.305 +	  (.write ^java.io.Writer *out* " ")
   1.306 +	  (pprint-newline :linear)
   1.307 +	  (recur (next alis)))))))
   1.308 +
   1.309 +;;; Take a map with symbols as keys and add versions with no namespace.
   1.310 +;;; That is, if ns/sym->val is in the map, add sym->val to the result.
   1.311 +(defn two-forms [amap]
   1.312 +  (into {} 
   1.313 +        (mapcat 
   1.314 +         identity 
   1.315 +         (for [x amap] 
   1.316 +           [x [(symbol (name (first x))) (second x)]]))))
   1.317 +
   1.318 +(defn add-core-ns [amap]
   1.319 +  (let [core "clojure.core"]
   1.320 +    (into {}
   1.321 +          (map #(let [[s f] %] 
   1.322 +                  (if (not (or (namespace s) (special-symbol? s)))
   1.323 +                    [(symbol core (name s)) f]
   1.324 +                    %))
   1.325 +               amap))))
   1.326 +
   1.327 +(def *code-table*
   1.328 +     (two-forms
   1.329 +      (add-core-ns
   1.330 +       {'def pprint-hold-first, 'defonce pprint-hold-first, 
   1.331 +	'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn,
   1.332 +        'let pprint-let, 'loop pprint-let, 'binding pprint-let,
   1.333 +        'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let,
   1.334 +	'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let,
   1.335 +	'when-first pprint-let,
   1.336 +        'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if,
   1.337 +        'cond pprint-cond, 'condp pprint-condp,
   1.338 +        'fn* pprint-anon-func,
   1.339 +        '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first,
   1.340 +        'locking pprint-hold-first, 'struct pprint-hold-first,
   1.341 +        'struct-map pprint-hold-first, 
   1.342 +        })))
   1.343 +
   1.344 +(defn pprint-code-list [alis]
   1.345 +  (if-not (pprint-reader-macro alis) 
   1.346 +    (if-let [special-form (*code-table* (first alis))]
   1.347 +      (special-form alis)
   1.348 +      (pprint-simple-code-list alis))))
   1.349 +
   1.350 +(defn pprint-code-symbol [sym] 
   1.351 +  (if-let [arg-num (sym *symbol-map*)]
   1.352 +    (print arg-num)
   1.353 +    (if *print-suppress-namespaces* 
   1.354 +      (print (name sym))
   1.355 +      (pr sym))))
   1.356 +
   1.357 +(defmulti 
   1.358 +  *code-dispatch*
   1.359 +  "The pretty print dispatch function for pretty printing Clojure code."
   1.360 +  {:arglists '[[object]]} 
   1.361 +  class)
   1.362 +
   1.363 +(use-method *code-dispatch* clojure.lang.ISeq pprint-code-list)
   1.364 +(use-method *code-dispatch* clojure.lang.Symbol pprint-code-symbol)
   1.365 +
   1.366 +;; The following are all exact copies of *simple-dispatch*
   1.367 +(use-method *code-dispatch* clojure.lang.IPersistentVector pprint-vector)
   1.368 +(use-method *code-dispatch* clojure.lang.IPersistentMap pprint-map)
   1.369 +(use-method *code-dispatch* clojure.lang.IPersistentSet pprint-set)
   1.370 +(use-method *code-dispatch* clojure.lang.Ref pprint-ref)
   1.371 +(use-method *code-dispatch* clojure.lang.Atom pprint-atom)
   1.372 +(use-method *code-dispatch* clojure.lang.Agent pprint-agent)
   1.373 +(use-method *code-dispatch* nil pr)
   1.374 +(use-method *code-dispatch* :default pprint-simple-default)
   1.375 +
   1.376 +(set-pprint-dispatch *simple-dispatch*)
   1.377 +
   1.378 +
   1.379 +;;; For testing
   1.380 +(comment
   1.381 +
   1.382 +(with-pprint-dispatch *code-dispatch* 
   1.383 +  (pprint 
   1.384 +   '(defn cl-format 
   1.385 +      "An implementation of a Common Lisp compatible format function"
   1.386 +      [stream format-in & args]
   1.387 +      (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
   1.388 +            navigator (init-navigator args)]
   1.389 +        (execute-format stream compiled-format navigator)))))
   1.390 +
   1.391 +(with-pprint-dispatch *code-dispatch* 
   1.392 +  (pprint 
   1.393 +   '(defn cl-format 
   1.394 +      [stream format-in & args]
   1.395 +      (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
   1.396 +            navigator (init-navigator args)]
   1.397 +        (execute-format stream compiled-format navigator)))))
   1.398 +
   1.399 +(with-pprint-dispatch *code-dispatch* 
   1.400 +  (pprint
   1.401 +   '(defn- -write 
   1.402 +      ([this x]
   1.403 +         (condp = (class x)
   1.404 +           String 
   1.405 +           (let [s0 (write-initial-lines this x)
   1.406 +                 s (.replaceFirst s0 "\\s+$" "")
   1.407 +                 white-space (.substring s0 (count s))
   1.408 +                 mode (getf :mode)]
   1.409 +             (if (= mode :writing)
   1.410 +               (dosync
   1.411 +                (write-white-space this)
   1.412 +                (.col_write this s)
   1.413 +                (setf :trailing-white-space white-space))
   1.414 +               (add-to-buffer this (make-buffer-blob s white-space))))
   1.415 +
   1.416 +           Integer
   1.417 +           (let [c ^Character x]
   1.418 +             (if (= (getf :mode) :writing)
   1.419 +               (do 
   1.420 +                 (write-white-space this)
   1.421 +                 (.col_write this x))
   1.422 +               (if (= c (int \newline))
   1.423 +                 (write-initial-lines this "\n")
   1.424 +                 (add-to-buffer this (make-buffer-blob (str (char c)) nil))))))))))
   1.425 +
   1.426 +(with-pprint-dispatch *code-dispatch* 
   1.427 +  (pprint 
   1.428 +   '(defn pprint-defn [writer alis]
   1.429 +      (if (next alis) 
   1.430 +        (let [[defn-sym defn-name & stuff] alis
   1.431 +              [doc-str stuff] (if (string? (first stuff))
   1.432 +                                [(first stuff) (next stuff)]
   1.433 +                                [nil stuff])
   1.434 +              [attr-map stuff] (if (map? (first stuff))
   1.435 +                                 [(first stuff) (next stuff)]
   1.436 +                                 [nil stuff])]
   1.437 +          (pprint-logical-block writer :prefix "(" :suffix ")"
   1.438 +                                (cl-format true "~w ~1I~@_~w" defn-sym defn-name)
   1.439 +                                (if doc-str
   1.440 +                                  (cl-format true " ~_~w" doc-str))
   1.441 +                                (if attr-map
   1.442 +                                  (cl-format true " ~_~w" attr-map))
   1.443 +                                ;; Note: the multi-defn case will work OK for malformed defns too
   1.444 +                                (cond
   1.445 +                                  (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
   1.446 +                                  :else (multi-defn stuff (or doc-str attr-map)))))
   1.447 +        (pprint-simple-code-list writer alis)))))
   1.448 +)
   1.449 +nil
   1.450 +