;; dispatch.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 default dispatch tables for pretty printing code and

 ;; data.

 

 (in-ns 'clojure.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 ^{:private true} 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 ^{:private true} 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 ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))

 

 ;;; TODO: don't block on promise (currently impossible)

 

 (def ^{:private true} 

      type-map {"core$future_call" "Future",

                "core$promise" "Promise"})

 

 (defn- map-ref-type 

   "Map ugly type names to something simpler"

   [name]

   (or (when-let [match (re-find #"^[^$]+\$[^$]+" name)]

         (type-map match))

       name))

 

 (defn- pprint-ideref [o]

   (let [prefix (format "#<%s@%x%s: "

                        (map-ref-type (.getSimpleName (class o)))

                        (System/identityHashCode o)

                        (if (and (instance? clojure.lang.Agent o)

                                 (agent-error o))

                          " FAILED"

                          ""))]

     (pprint-logical-block  :prefix prefix :suffix ">"

                            (pprint-indent :block (-> (count prefix) (- 2) -))

                            (pprint-newline :linear)

                            (write-out (cond 

                                        (and (future? o) (not (future-done? o))) :pending

                                        :else @o)))))

 

 (def ^{:private true} pprint-pqueue (formatter-out "~<<-(~;~@{~w~^ ~_~}~;)-<~:>"))

 

 (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."

   {:added "1.2" :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.PersistentQueue pprint-pqueue)

 (use-method simple-dispatch clojure.lang.IDeref pprint-ideref)

 (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 ^{:private true} 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 ^{:private true} 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 ^{:private true} *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 ^{:private true} *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."

   {:added "1.2" :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.PersistentQueue pprint-pqueue)

 (use-method code-dispatch clojure.lang.IDeref pprint-ideref)

 (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