|
Java example source code file (dispatch.clj)
The dispatch.clj Java example source code;; 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. " [^clojure.lang.MultiFn 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 absorbed 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 ")" (print-length-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 "]" (print-length-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 "}" (print-length-loop [aseq (seq amap)] (when aseq (pprint-logical-block (write-out (ffirst aseq)) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (set! *current-length* 0) ; always print both parts of the [k v] pair (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~^ ~:_~}~;}~:>")) (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 (and (instance? clojure.lang.IPending o) (not (.isRealized ^clojure.lang.IPending o))) :not-delivered :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.Var pprint-simple-default) (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 the namespace ("ns") macro. This is quite complicated because of all the ;;; different forms supported and because programmers can choose lists or vectors ;;; in various places. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- brackets "Figure out which kind of brackets to use" [form] (if (vector? form) ["[" "]"] ["(" ")"])) (defn- pprint-ns-reference "Pretty print a single reference (import, use, etc.) from a namespace decl" [reference] (if (sequential? reference) (let [[start end] (brackets reference) [keyw & args] reference] (pprint-logical-block :prefix start :suffix end ((formatter-out "~w~:i") keyw) (loop [args args] (when (seq args) ((formatter-out " ")) (let [arg (first args)] (if (sequential? arg) (let [[start end] (brackets arg)] (pprint-logical-block :prefix start :suffix end (if (and (= (count arg) 3) (keyword? (second arg))) (let [[ns kw lis] arg] ((formatter-out "~w ~w ") ns kw) (if (sequential? lis) ((formatter-out (if (vector? lis) "~<[~;~@{~w~^ ~:_~}~;]~:>" "~<(~;~@{~w~^ ~:_~}~;)~:>")) lis) (write-out lis))) (apply (formatter-out "~w ~:i~@{~w~^ ~:_~}") arg))) (when (next args) ((formatter-out "~_")))) (do (write-out arg) (when (next args) ((formatter-out "~:_")))))) (recur (next args)))))) (when reference (write-out reference)))) (defn- pprint-ns "The pretty print dispatch chunk for the ns macro" [alis] (if (next alis) (let [[ns-sym ns-name & stuff] alis [doc-str stuff] (if (string? (first stuff)) [(first stuff) (next stuff)] [nil stuff]) [attr-map references] (if (map? (first stuff)) [(first stuff) (next stuff)] [nil stuff])] (pprint-logical-block :prefix "(" :suffix ")" ((formatter-out "~w ~1I~@_~w") ns-sym ns-name) (when (or doc-str attr-map (seq references)) ((formatter-out "~@:_"))) (when doc-str (cl-format true "\"~a\"~:[~;~:@_~]" doc-str (or attr-map (seq references)))) (when attr-map ((formatter-out "~w~:[~;~:@_~]") attr-map (seq references))) (loop [references references] (pprint-ns-reference (first references)) (when-let [references (next references)] (pprint-newline :linear) (recur references))))) (write-out alis))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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 "]" (print-length-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) (print-length-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) (print-length-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 ^:dynamic ^{: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) (print-length-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 ^:dynamic ^{: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, 'ns pprint-ns }))) (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 Other Java examples (source code examples)Here is a short list of links related to this Java dispatch.clj source code file: |
... this post is sponsored by my books ... | |
#1 New Release! |
FP Best Seller |
Copyright 1998-2021 Alvin Alexander, alvinalexander.com
All Rights Reserved.
A percentage of advertising revenue from
pages under the /java/jwarehouse
URI on this website is
paid back to open source projects.