Mercurial > lasercutter

     1 ;; dispatch.clj -- part of the pretty printer for Clojure

     2 

     3 ;; by Tom Faulhaber

     4 ;; April 3, 2009

     5 

     6 ;   Copyright (c) Tom Faulhaber, Feb 2009. All rights reserved.

     7 ;   The use and distribution terms for this software are covered by the

     8 ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)

     9 ;   which can be found in the file epl-v10.html at the root of this distribution.

    10 ;   By using this software in any fashion, you are agreeing to be bound by

    11 ;   the terms of this license.

    12 ;   You must not remove this notice, or any other, from this software.

    13 

    14 ;; This module implements the default dispatch tables for pretty printing code and

    15 ;; data.

    16 

    17 (in-ns 'clojure.contrib.pprint)

    18 

    19 (defn use-method

    20   "Installs a function as a new method of multimethod associated with dispatch-value. "

    21   [multifn dispatch-val func]

    22   (. multifn addMethod dispatch-val func))

    23 

    24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    25 ;; Implementations of specific dispatch table entries

    26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    27 

    28 ;;; Handle forms that can be "back-translated" to reader macros

    29 ;;; Not all reader macros can be dealt with this way or at all. 

    30 ;;; Macros that we can't deal with at all are:

    31 ;;; ;  - The comment character is aborbed by the reader and never is part of the form

    32 ;;; `  - Is fully processed at read time into a lisp expression (which will contain concats

    33 ;;;      and regular quotes).

    34 ;;; ~@ - Also fully eaten by the processing of ` and can't be used outside.

    35 ;;; ,  - is whitespace and is lost (like all other whitespace). Formats can generate commas

    36 ;;;      where they deem them useful to help readability.

    37 ;;; ^ - Adding metadata completely disappears at read time and the data appears to be

    38 ;;;      completely lost.

    39 ;;;

    40 ;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{})

    41 ;;; or directly by printing the objects using Clojure's built-in print functions (like

    42 ;;; :keyword, \char, or ""). The notable exception is #() which is special-cased.

    43 

    44 (def reader-macros

    45      {'quote "'", 'clojure.core/deref "@", 

    46       'var "#'", 'clojure.core/unquote "~"})

    47 

    48 (defn pprint-reader-macro [alis]

    49   (let [^String macro-char (reader-macros (first alis))]

    50     (when (and macro-char (= 2 (count alis)))

    51       (.write ^java.io.Writer *out* macro-char)

    52       (write-out (second alis))

    53       true)))

    54 

    55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    56 ;; Dispatch for the basic data types when interpreted

    57 ;; as data (as opposed to code).

    58 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    59 

    60 ;;; TODO: inline these formatter statements into funcs so that we

    61 ;;; are a little easier on the stack. (Or, do "real" compilation, a

    62 ;;; la Common Lisp)

    63 

    64 ;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))

    65 (defn pprint-simple-list [alis]

    66   (pprint-logical-block :prefix "(" :suffix ")"

    67     (loop [alis (seq alis)]

    68       (when alis

    69 	(write-out (first alis))

    70 	(when (next alis)

    71 	  (.write ^java.io.Writer *out* " ")

    72 	  (pprint-newline :linear)

    73 	  (recur (next alis)))))))

    74 

    75 (defn pprint-list [alis]

    76   (if-not (pprint-reader-macro alis)

    77     (pprint-simple-list alis)))

    78 

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

    80 (defn pprint-vector [avec]

    81   (pprint-logical-block :prefix "[" :suffix "]"

    82     (loop [aseq (seq avec)]

    83       (when aseq

    84 	(write-out (first aseq))

    85 	(when (next aseq)

    86 	  (.write ^java.io.Writer *out* " ")

    87 	  (pprint-newline :linear)

    88 	  (recur (next aseq)))))))

    89 

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

    91 

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

    93 (defn pprint-map [amap]

    94   (pprint-logical-block :prefix "{" :suffix "}"

    95     (loop [aseq (seq amap)]

    96       (when aseq

    97 	(pprint-logical-block 

    98           (write-out (ffirst aseq))

    99           (.write ^java.io.Writer *out* " ")

   100           (pprint-newline :linear)

   101           (write-out (fnext (first aseq))))

   102         (when (next aseq)

   103           (.write ^java.io.Writer *out* ", ")

   104           (pprint-newline :linear)

   105           (recur (next aseq)))))))

   106 

   107 (def pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))

   108 (defn pprint-ref [ref]

   109   (pprint-logical-block  :prefix "#<Ref " :suffix ">"

   110     (write-out @ref)))

   111 (defn pprint-atom [ref]

   112   (pprint-logical-block :prefix "#<Atom " :suffix ">"

   113     (write-out @ref)))

   114 (defn pprint-agent [ref]

   115   (pprint-logical-block :prefix "#<Agent " :suffix ">"

   116     (write-out @ref)))

   117 

   118 (defn pprint-simple-default [obj]

   119   (cond 

   120     (.isArray (class obj)) (pprint-array obj)

   121     (and *print-suppress-namespaces* (symbol? obj)) (print (name obj))

   122     :else (pr obj)))

   123 

   124 

   125 (defmulti 

   126   *simple-dispatch*

   127   "The pretty print dispatch function for simple data structure format."

   128   {:arglists '[[object]]} 

   129   class)

   130 

   131 (use-method *simple-dispatch* clojure.lang.ISeq pprint-list)

   132 (use-method *simple-dispatch* clojure.lang.IPersistentVector pprint-vector)

   133 (use-method *simple-dispatch* clojure.lang.IPersistentMap pprint-map)

   134 (use-method *simple-dispatch* clojure.lang.IPersistentSet pprint-set)

   135 (use-method *simple-dispatch* clojure.lang.Ref pprint-ref)

   136 (use-method *simple-dispatch* clojure.lang.Atom pprint-atom)

   137 (use-method *simple-dispatch* clojure.lang.Agent pprint-agent)

   138 (use-method *simple-dispatch* nil pr)

   139 (use-method *simple-dispatch* :default pprint-simple-default)

   140 

   141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   142 ;;; Dispatch for the code table

   143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   144 

   145 (declare pprint-simple-code-list)

   146 

   147 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   148 ;;; Format something that looks like a simple def (sans metadata, since the reader

   149 ;;; won't give it to us now).

   150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   151 

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

   153 

   154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

   156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   157 

   158 ;;; Format the params and body of a defn with a single arity

   159 (defn- single-defn [alis has-doc-str?]

   160   (if (seq alis)

   161     (do

   162       (if has-doc-str?

   163         ((formatter-out " ~_"))

   164         ((formatter-out " ~@_")))

   165       ((formatter-out "~{~w~^ ~_~}") alis))))

   166 

   167 ;;; Format the param and body sublists of a defn with multiple arities

   168 (defn- multi-defn [alis has-doc-str?]

   169   (if (seq alis)

   170     ((formatter-out " ~_~{~w~^ ~_~}") alis)))

   171 

   172 ;;; TODO: figure out how to support capturing metadata in defns (we might need a 

   173 ;;; special reader)

   174 (defn pprint-defn [alis]

   175   (if (next alis) 

   176     (let [[defn-sym defn-name & stuff] alis

   177           [doc-str stuff] (if (string? (first stuff))

   178                             [(first stuff) (next stuff)]

   179                             [nil stuff])

   180           [attr-map stuff] (if (map? (first stuff))

   181                              [(first stuff) (next stuff)]

   182                              [nil stuff])]

   183       (pprint-logical-block :prefix "(" :suffix ")"

   184         ((formatter-out "~w ~1I~@_~w") defn-sym defn-name)

   185         (if doc-str

   186           ((formatter-out " ~_~w") doc-str))

   187         (if attr-map

   188           ((formatter-out " ~_~w") attr-map))

   189         ;; Note: the multi-defn case will work OK for malformed defns too

   190         (cond

   191          (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))

   192          :else (multi-defn stuff (or doc-str attr-map)))))

   193     (pprint-simple-code-list alis)))

   194 

   195 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   196 ;;; Format something with a binding form

   197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   198 

   199 (defn pprint-binding-form [binding-vec]

   200   (pprint-logical-block :prefix "[" :suffix "]"

   201     (loop [binding binding-vec]

   202       (when (seq binding)

   203         (pprint-logical-block binding

   204           (write-out (first binding))

   205           (when (next binding)

   206             (.write ^java.io.Writer *out* " ")

   207             (pprint-newline :miser)

   208             (write-out (second binding))))

   209         (when (next (rest binding))

   210           (.write ^java.io.Writer *out* " ")

   211           (pprint-newline :linear)

   212           (recur (next (rest binding))))))))

   213 

   214 (defn pprint-let [alis]

   215   (let [base-sym (first alis)]

   216     (pprint-logical-block :prefix "(" :suffix ")"

   217       (if (and (next alis) (vector? (second alis)))

   218         (do

   219           ((formatter-out "~w ~1I~@_") base-sym)

   220           (pprint-binding-form (second alis))

   221           ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis))))

   222         (pprint-simple-code-list alis)))))

   223 

   224 

   225 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

   227 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   228 

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

   230 

   231 (defn pprint-cond [alis]

   232   (pprint-logical-block :prefix "(" :suffix ")"

   233     (pprint-indent :block 1)

   234     (write-out (first alis))

   235     (when (next alis)

   236       (.write ^java.io.Writer *out* " ")

   237       (pprint-newline :linear)

   238      (loop [alis (next alis)]

   239        (when alis

   240          (pprint-logical-block alis

   241           (write-out (first alis))

   242           (when (next alis)

   243             (.write ^java.io.Writer *out* " ")

   244             (pprint-newline :miser)

   245             (write-out (second alis))))

   246          (when (next (rest alis))

   247            (.write ^java.io.Writer *out* " ")

   248            (pprint-newline :linear)

   249            (recur (next (rest alis)))))))))

   250 

   251 (defn pprint-condp [alis]

   252   (if (> (count alis) 3) 

   253     (pprint-logical-block :prefix "(" :suffix ")"

   254       (pprint-indent :block 1)

   255       (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)

   256       (loop [alis (seq (drop 3 alis))]

   257         (when alis

   258           (pprint-logical-block alis

   259             (write-out (first alis))

   260             (when (next alis)

   261               (.write ^java.io.Writer *out* " ")

   262               (pprint-newline :miser)

   263               (write-out (second alis))))

   264           (when (next (rest alis))

   265             (.write ^java.io.Writer *out* " ")

   266             (pprint-newline :linear)

   267             (recur (next (rest alis)))))))

   268     (pprint-simple-code-list alis)))

   269 

   270 ;;; The map of symbols that are defined in an enclosing #() anonymous function

   271 (def *symbol-map* {})

   272 

   273 (defn pprint-anon-func [alis]

   274   (let [args (second alis)

   275         nlis (first (rest (rest alis)))]

   276     (if (vector? args)

   277       (binding [*symbol-map* (if (= 1 (count args)) 

   278                                {(first args) "%"}

   279                                (into {} 

   280                                      (map 

   281                                       #(vector %1 (str \% %2)) 

   282                                       args 

   283                                       (range 1 (inc (count args))))))]

   284         ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis))

   285       (pprint-simple-code-list alis))))

   286 

   287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

   289 ;;; special forms).

   290 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   291 

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

   293 ;;; easier on the stack.

   294 

   295 (defn pprint-simple-code-list [alis]

   296   (pprint-logical-block :prefix "(" :suffix ")"

   297     (pprint-indent :block 1)

   298     (loop [alis (seq alis)]

   299       (when alis

   300 	(write-out (first alis))

   301 	(when (next alis)

   302 	  (.write ^java.io.Writer *out* " ")

   303 	  (pprint-newline :linear)

   304 	  (recur (next alis)))))))

   305 

   306 ;;; Take a map with symbols as keys and add versions with no namespace.

   307 ;;; That is, if ns/sym->val is in the map, add sym->val to the result.

   308 (defn two-forms [amap]

   309   (into {} 

   310         (mapcat 

   311          identity 

   312          (for [x amap] 

   313            [x [(symbol (name (first x))) (second x)]]))))

   314 

   315 (defn add-core-ns [amap]

   316   (let [core "clojure.core"]

   317     (into {}

   318           (map #(let [[s f] %] 

   319                   (if (not (or (namespace s) (special-symbol? s)))

   320                     [(symbol core (name s)) f]

   321                     %))

   322                amap))))

   323 

   324 (def *code-table*

   325      (two-forms

   326       (add-core-ns

   327        {'def pprint-hold-first, 'defonce pprint-hold-first, 

   328 	'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn,

   329         'let pprint-let, 'loop pprint-let, 'binding pprint-let,

   330         'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let,

   331 	'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let,

   332 	'when-first pprint-let,

   333         'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if,

   334         'cond pprint-cond, 'condp pprint-condp,

   335         'fn* pprint-anon-func,

   336         '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first,

   337         'locking pprint-hold-first, 'struct pprint-hold-first,

   338         'struct-map pprint-hold-first, 

   339         })))

   340 

   341 (defn pprint-code-list [alis]

   342   (if-not (pprint-reader-macro alis) 

   343     (if-let [special-form (*code-table* (first alis))]

   344       (special-form alis)

   345       (pprint-simple-code-list alis))))

   346 

   347 (defn pprint-code-symbol [sym] 

   348   (if-let [arg-num (sym *symbol-map*)]

   349     (print arg-num)

   350     (if *print-suppress-namespaces* 

   351       (print (name sym))

   352       (pr sym))))

   353 

   354 (defmulti 

   355   *code-dispatch*

   356   "The pretty print dispatch function for pretty printing Clojure code."

   357   {:arglists '[[object]]} 

   358   class)

   359 

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

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

   362 

   363 ;; The following are all exact copies of *simple-dispatch*

   364 (use-method *code-dispatch* clojure.lang.IPersistentVector pprint-vector)

   365 (use-method *code-dispatch* clojure.lang.IPersistentMap pprint-map)

   366 (use-method *code-dispatch* clojure.lang.IPersistentSet pprint-set)

   367 (use-method *code-dispatch* clojure.lang.Ref pprint-ref)

   368 (use-method *code-dispatch* clojure.lang.Atom pprint-atom)

   369 (use-method *code-dispatch* clojure.lang.Agent pprint-agent)

   370 (use-method *code-dispatch* nil pr)

   371 (use-method *code-dispatch* :default pprint-simple-default)

   372 

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

   374 

   375 

   376 ;;; For testing

   377 (comment

   378 

   379 (with-pprint-dispatch *code-dispatch* 

   380   (pprint 

   381    '(defn cl-format 

   382       "An implementation of a Common Lisp compatible format function"

   383       [stream format-in & args]

   384       (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)

   385             navigator (init-navigator args)]

   386         (execute-format stream compiled-format navigator)))))

   387 

   388 (with-pprint-dispatch *code-dispatch* 

   389   (pprint 

   390    '(defn cl-format 

   391       [stream format-in & args]

   392       (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)

   393             navigator (init-navigator args)]

   394         (execute-format stream compiled-format navigator)))))

   395 

   396 (with-pprint-dispatch *code-dispatch* 

   397   (pprint

   398    '(defn- -write 

   399       ([this x]

   400          (condp = (class x)

   401            String 

   402            (let [s0 (write-initial-lines this x)

   403                  s (.replaceFirst s0 "\\s+$" "")

   404                  white-space (.substring s0 (count s))

   405                  mode (getf :mode)]

   406              (if (= mode :writing)

   407                (dosync

   408                 (write-white-space this)

   409                 (.col_write this s)

   410                 (setf :trailing-white-space white-space))

   411                (add-to-buffer this (make-buffer-blob s white-space))))

   412 

   413            Integer

   414            (let [c ^Character x]

   415              (if (= (getf :mode) :writing)

   416                (do 

   417                  (write-white-space this)

   418                  (.col_write this x))

   419                (if (= c (int \newline))

   420                  (write-initial-lines this "\n")

   421                  (add-to-buffer this (make-buffer-blob (str (char c)) nil))))))))))

   422 

   423 (with-pprint-dispatch *code-dispatch* 

   424   (pprint 

   425    '(defn pprint-defn [writer alis]

   426       (if (next alis) 

   427         (let [[defn-sym defn-name & stuff] alis

   428               [doc-str stuff] (if (string? (first stuff))

   429                                 [(first stuff) (next stuff)]

   430                                 [nil stuff])

   431               [attr-map stuff] (if (map? (first stuff))

   432                                  [(first stuff) (next stuff)]

   433                                  [nil stuff])]

   434           (pprint-logical-block writer :prefix "(" :suffix ")"

   435                                 (cl-format true "~w ~1I~@_~w" defn-sym defn-name)

   436                                 (if doc-str

   437                                   (cl-format true " ~_~w" doc-str))

   438                                 (if attr-map

   439                                   (cl-format true " ~_~w" attr-map))

   440                                 ;; Note: the multi-defn case will work OK for malformed defns too

   441                                 (cond

   442                                   (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))

   443                                   :else (multi-defn stuff (or doc-str attr-map)))))

   444         (pprint-simple-code-list writer alis)))))

   445 )

   446 nil

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