lasercutter: src/clojure/contrib/pprint/dispatch.clj comparison

comparison src/clojure/contrib/pprint/dispatch.clj @ 10:ef7dbbd6452c

added clojure source goodness

author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children

comparison

equal deleted inserted replaced

-:35cf337adfcf
+:ef7dbbd6452c
+;; 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

Mercurial > lasercutter

comparison src/clojure/contrib/pprint/dispatch.clj @ 10:ef7dbbd6452c