summaryrefslogtreecommitdiff
path: root/src/clojure/contrib/pprint
diff options
context:
space:
mode:
Diffstat (limited to 'src/clojure/contrib/pprint')
-rw-r--r--src/clojure/contrib/pprint/ColumnWriter.clj89
-rw-r--r--src/clojure/contrib/pprint/PrettyWriter.clj486
-rw-r--r--src/clojure/contrib/pprint/cl_format.clj1843
-rw-r--r--src/clojure/contrib/pprint/dispatch.clj447
-rw-r--r--src/clojure/contrib/pprint/examples/hexdump.clj63
-rw-r--r--src/clojure/contrib/pprint/examples/json.clj142
-rw-r--r--src/clojure/contrib/pprint/examples/multiply.clj23
-rw-r--r--src/clojure/contrib/pprint/examples/props.clj25
-rw-r--r--src/clojure/contrib/pprint/examples/show_doc.clj50
-rw-r--r--src/clojure/contrib/pprint/examples/xml.clj117
-rw-r--r--src/clojure/contrib/pprint/pprint_base.clj342
-rw-r--r--src/clojure/contrib/pprint/utilities.clj104
12 files changed, 0 insertions, 3731 deletions
diff --git a/src/clojure/contrib/pprint/ColumnWriter.clj b/src/clojure/contrib/pprint/ColumnWriter.clj
deleted file mode 100644
index fc6ae75c..00000000
--- a/src/clojure/contrib/pprint/ColumnWriter.clj
+++ /dev/null
@@ -1,89 +0,0 @@
-;;; ColumnWriter.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Dec 2008. 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 a column-aware wrapper around an instance of java.io.Writer
-
-(ns clojure.contrib.pprint.ColumnWriter
- (:gen-class
- :extends java.io.Writer
- :init init
- :constructors {[java.io.Writer Integer] [],
- [java.io.Writer] []}
- :methods [[getColumn [] Integer]
- [getLine [] Integer]
- [getMaxColumn [] Integer]
- [setMaxColumn [Integer] Void]
- [getWriter [] java.io.Writer]]
- :state state))
-
-(def *default-page-width* 72)
-
-(defn- -init
- ([writer] (-init writer *default-page-width*))
- ([writer max-columns] [[] (ref {:max max-columns, :cur 0, :line 0 :base writer})]))
-
-(defn- get-field [#^clojure.contrib.pprint.ColumnWriter this sym]
- (sym @(.state this)))
-
-(defn- set-field [#^clojure.contrib.pprint.ColumnWriter this sym new-val]
- (alter (.state this) assoc sym new-val))
-
-(defn- -getColumn [this]
- (get-field this :cur))
-
-(defn- -getLine [this]
- (get-field this :line))
-
-(defn- -getMaxColumn [this]
- (get-field this :max))
-
-(defn- -setMaxColumn [this new-max]
- (dosync (set-field this :max new-max))
- nil)
-
-(defn- -getWriter [this]
- (get-field this :base))
-
-(declare write-char)
-
-(defn- -write
- ([#^clojure.contrib.pprint.ColumnWriter this #^chars cbuf #^Integer off #^Integer len]
- (let [#^java.io.Writer writer (get-field this :base)]
- (.write writer cbuf off len)))
- ([#^clojure.contrib.pprint.ColumnWriter this x]
- (condp = (class x)
- String
- (let [#^String s x
- nl (.lastIndexOf s (int \newline))]
- (dosync (if (neg? nl)
- (set-field this :cur (+ (get-field this :cur) (count s)))
- (do
- (set-field this :cur (- (count s) nl 1))
- (set-field this :line (+ (get-field this :line)
- (count (filter #(= % \newline) s)))))))
- (.write #^java.io.Writer (get-field this :base) s))
-
- Integer
- (write-char this x))))
-
-(defn- write-char [#^clojure.contrib.pprint.ColumnWriter this #^Integer c]
- (dosync (if (= c (int \newline))
- (do
- (set-field this :cur 0)
- (set-field this :line (inc (get-field this :line))))
- (set-field this :cur (inc (get-field this :cur)))))
- (.write #^java.io.Writer (get-field this :base) c))
-
-(defn- -flush [this]) ;; Currently a no-op
-
-(defn- -close [this]) ;; Currently a no-op
diff --git a/src/clojure/contrib/pprint/PrettyWriter.clj b/src/clojure/contrib/pprint/PrettyWriter.clj
deleted file mode 100644
index 10192097..00000000
--- a/src/clojure/contrib/pprint/PrettyWriter.clj
+++ /dev/null
@@ -1,486 +0,0 @@
-;;; PrettyWriter.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Jan 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 a wrapper around a java.io.Writer which implements the
-;; core of the XP algorithm.
-
-(ns clojure.contrib.pprint.PrettyWriter
- (:refer-clojure :exclude (deftype))
- (:use clojure.contrib.pprint.utilities)
- (:gen-class
- :extends clojure.contrib.pprint.ColumnWriter
- :init init
- :constructors {[java.io.Writer Integer Object] [java.io.Writer Integer]}
- :methods [[startBlock [String String String] void]
- [endBlock [] void]
- [newline [clojure.lang.Keyword] void]
- [indent [clojure.lang.Keyword Integer] void]
- [getMiserWidth [] Object]
- [setMiserWidth [Object] void]
- [setLogicalBlockCallback [clojure.lang.IFn] void]]
- :exposes-methods {write col_write}
- :state pwstate))
-
-;; TODO: Support for tab directives
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Macros to simplify dealing with types and classes. These are
-;;; really utilities, but I'm experimenting with them here.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro #^{:private true}
- getf
- "Get the value of the field a named by the argument (which should be a keyword)."
- [sym]
- `(~sym @(.pwstate ~'this)))
-
-(defmacro #^{:private true}
- setf [sym new-val]
- "Set the value of the field SYM to NEW-VAL"
- `(alter (.pwstate ~'this) assoc ~sym ~new-val))
-
-(defmacro deftype [type-name & fields]
- (let [name-str (name type-name)]
- `(do
- (defstruct ~type-name :type-tag ~@fields)
- (defn- ~(symbol (str "make-" name-str))
- [& vals#] (apply struct ~type-name ~(keyword name-str) vals#))
- (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; The data structures used by PrettyWriter
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defstruct #^{:private true} logical-block
- :parent :section :start-col :indent
- :done-nl :intra-block-nl
- :prefix :per-line-prefix :suffix
- :logical-block-callback)
-
-(defn ancestor? [parent child]
- (loop [child (:parent child)]
- (cond
- (nil? child) false
- (identical? parent child) true
- :else (recur (:parent child)))))
-
-(defstruct #^{:private true} section :parent)
-
-(defn buffer-length [l]
- (let [l (seq l)]
- (if l
- (- (:end-pos (last l)) (:start-pos (first l)))
- 0)))
-
-; A blob of characters (aka a string)
-(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos)
-
-; A newline
-(deftype nl :type :logical-block :start-pos :end-pos)
-
-(deftype start-block :logical-block :start-pos :end-pos)
-
-(deftype end-block :logical-block :start-pos :end-pos)
-
-(deftype indent :logical-block :relative-to :offset :start-pos :end-pos)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Initialize the PrettyWriter instance
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn- -init
- [writer max-columns miser-width]
- [[writer max-columns]
- (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))]
- (ref {:logical-blocks lb
- :sections nil
- :mode :writing
- :buffer []
- :buffer-block lb
- :buffer-level 1
- :miser-width miser-width
- :trailing-white-space nil
- :pos 0}))])
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Functions to write tokens in the output buffer
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(declare emit-nl)
-
-(defmulti write-token #(:type-tag %2))
-(defmethod write-token :start-block [#^clojure.contrib.pprint.PrettyWriter this token]
- (when-let [cb (getf :logical-block-callback)] (cb :start))
- (let [lb (:logical-block token)]
- (dosync
- (when-let [#^String prefix (:prefix lb)]
- (.col_write this prefix))
- (let [col (.getColumn this)]
- (ref-set (:start-col lb) col)
- (ref-set (:indent lb) col)))))
-
-(defmethod write-token :end-block [#^clojure.contrib.pprint.PrettyWriter this token]
- (when-let [cb (getf :logical-block-callback)] (cb :end))
- (when-let [#^String suffix (:suffix (:logical-block token))]
- (.col_write this suffix)))
-
-(defmethod write-token :indent [#^clojure.contrib.pprint.PrettyWriter this token]
- (let [lb (:logical-block token)]
- (ref-set (:indent lb)
- (+ (:offset token)
- (condp = (:relative-to token)
- :block @(:start-col lb)
- :current (.getColumn this))))))
-
-(defmethod write-token :buffer-blob [#^clojure.contrib.pprint.PrettyWriter this token]
- (.col_write this #^String (:data token)))
-
-(defmethod write-token :nl [#^clojure.contrib.pprint.PrettyWriter this token]
-; (prlabel wt @(:done-nl (:logical-block token)))
-; (prlabel wt (:type token) (= (:type token) :mandatory))
- (if (or (= (:type token) :mandatory)
- (and (not (= (:type token) :fill))
- @(:done-nl (:logical-block token))))
- (emit-nl this token)
- (if-let [#^String tws (getf :trailing-white-space)]
- (.col_write this tws)))
- (dosync (setf :trailing-white-space nil)))
-
-(defn- write-tokens [#^clojure.contrib.pprint.PrettyWriter this tokens force-trailing-whitespace]
- (doseq [token tokens]
- (if-not (= (:type-tag token) :nl)
- (if-let [#^String tws (getf :trailing-white-space)]
- (.col_write this tws)))
- (write-token this token)
- (setf :trailing-white-space (:trailing-white-space token)))
- (let [#^String tws (getf :trailing-white-space)]
- (when (and force-trailing-whitespace tws)
- (.col_write this tws)
- (setf :trailing-white-space nil))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; emit-nl? method defs for each type of new line. This makes
-;;; the decision about whether to print this type of new line.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(defn- tokens-fit? [#^clojure.contrib.pprint.PrettyWriter this tokens]
-;;; (prlabel tf? (.getColumn this) (buffer-length tokens))
- (let [maxcol (.getMaxColumn this)]
- (or
- (nil? maxcol)
- (< (+ (.getColumn this) (buffer-length tokens)) maxcol))))
-
-(defn- linear-nl? [this lb section]
-; (prlabel lnl? @(:done-nl lb) (tokens-fit? this section))
- (or @(:done-nl lb)
- (not (tokens-fit? this section))))
-
-(defn- miser-nl? [#^clojure.contrib.pprint.PrettyWriter this lb section]
- (let [miser-width (.getMiserWidth this)
- maxcol (.getMaxColumn this)]
- (and miser-width maxcol
- (>= @(:start-col lb) (- maxcol miser-width))
- (linear-nl? this lb section))))
-
-(defmulti emit-nl? (fn [t _ _ _] (:type t)))
-
-(defmethod emit-nl? :linear [newl this section _]
- (let [lb (:logical-block newl)]
- (linear-nl? this lb section)))
-
-(defmethod emit-nl? :miser [newl this section _]
- (let [lb (:logical-block newl)]
- (miser-nl? this lb section)))
-
-(defmethod emit-nl? :fill [newl this section subsection]
- (let [lb (:logical-block newl)]
- (or @(:intra-block-nl lb)
- (not (tokens-fit? this subsection))
- (miser-nl? this lb section))))
-
-(defmethod emit-nl? :mandatory [_ _ _ _]
- true)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Various support functions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(defn- get-section [buffer]
- (let [nl (first buffer)
- lb (:logical-block nl)
- section (seq (take-while #(not (and (nl? %) (ancestor? (:logical-block %) lb)))
- (next buffer)))]
- [section (seq (drop (inc (count section)) buffer))]))
-
-(defn- get-sub-section [buffer]
- (let [nl (first buffer)
- lb (:logical-block nl)
- section (seq (take-while #(let [nl-lb (:logical-block %)]
- (not (and (nl? %) (or (= nl-lb lb) (ancestor? nl-lb lb)))))
- (next buffer)))]
- section))
-
-(defn- update-nl-state [lb]
- (dosync
- (ref-set (:intra-block-nl lb) false)
- (ref-set (:done-nl lb) true)
- (loop [lb (:parent lb)]
- (if lb
- (do (ref-set (:done-nl lb) true)
- (ref-set (:intra-block-nl lb) true)
- (recur (:parent lb)))))))
-
-(defn emit-nl [#^clojure.contrib.pprint.PrettyWriter this nl]
- (.col_write this (int \newline))
- (dosync (setf :trailing-white-space nil))
- (let [lb (:logical-block nl)
- #^String prefix (:per-line-prefix lb)]
- (if prefix
- (.col_write this prefix))
- (let [#^String istr (apply str (repeat (- @(:indent lb) (count prefix))
- \space))]
- (.col_write this istr))
- (update-nl-state lb)))
-
-(defn- split-at-newline [tokens]
- (let [pre (seq (take-while #(not (nl? %)) tokens))]
- [pre (seq (drop (count pre) tokens))]))
-
-;;; Methods for showing token strings for debugging
-
-(defmulti tok :type-tag)
-(defmethod tok :nl [token]
- (:type token))
-(defmethod tok :buffer-blob [token]
- (str \" (:data token) (:trailing-white-space token) \"))
-(defmethod tok :default [token]
- (:type-tag token))
-(defn toks [toks] (map tok toks))
-
-;;; write-token-string is called when the set of tokens in the buffer
-;;; is longer than the available space on the line
-
-(defn- write-token-string [this tokens]
- (let [[a b] (split-at-newline tokens)]
-;; (prlabel wts (toks a) (toks b))
- (if a (write-tokens this a false))
- (if b
- (let [[section remainder] (get-section b)
- newl (first b)]
-;; (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder))
- (let [do-nl (emit-nl? newl this section (get-sub-section b))
- result (if do-nl
- (do
-;; (prlabel emit-nl (:type newl))
- (emit-nl this newl)
- (next b))
- b)
- long-section (not (tokens-fit? this result))
- result (if long-section
- (let [rem2 (write-token-string this section)]
-;;; (prlabel recurse (toks rem2))
- (if (= rem2 section)
- (do ; If that didn't produce any output, it has no nls
- ; so we'll force it
- (write-tokens this section false)
- remainder)
- (into [] (concat rem2 remainder))))
- result)
-;; ff (prlabel wts (toks result))
- ]
- result)))))
-
-(defn- write-line [#^clojure.contrib.pprint.PrettyWriter this]
- (dosync
- (loop [buffer (getf :buffer)]
-;; (prlabel wl1 (toks buffer))
- (setf :buffer (into [] buffer))
- (if (not (tokens-fit? this buffer))
- (let [new-buffer (write-token-string this buffer)]
-;; (prlabel wl new-buffer)
- (if-not (identical? buffer new-buffer)
- (recur new-buffer)))))))
-
-;;; Add a buffer token to the buffer and see if it's time to start
-;;; writing
-(defn- add-to-buffer [#^clojure.contrib.pprint.PrettyWriter this token]
-; (prlabel a2b token)
- (dosync
- (setf :buffer (conj (getf :buffer) token))
- (if (not (tokens-fit? this (getf :buffer)))
- (write-line this))))
-
-;;; Write all the tokens that have been buffered
-(defn- write-buffered-output [#^clojure.contrib.pprint.PrettyWriter this]
- (write-line this)
- (if-let [buf (getf :buffer)]
- (do
- (write-tokens this buf true)
- (setf :buffer []))))
-
-;;; If there are newlines in the string, print the lines up until the last newline,
-;;; making the appropriate adjustments. Return the remainder of the string
-(defn- write-initial-lines
- [#^clojure.contrib.pprint.PrettyWriter this #^String s]
- (let [lines (.split s "\n" -1)]
- (if (= (count lines) 1)
- s
- (dosync
- (let [#^String prefix (:per-line-prefix (first (getf :logical-blocks)))
- #^String l (first lines)]
- (if (= :buffering (getf :mode))
- (let [oldpos (getf :pos)
- newpos (+ oldpos (count l))]
- (setf :pos newpos)
- (add-to-buffer this (make-buffer-blob l nil oldpos newpos))
- (write-buffered-output this))
- (.col_write this l))
- (.col_write this (int \newline))
- (doseq [#^String l (next (butlast lines))]
- (.col_write this l)
- (.col_write this (int \newline))
- (if prefix
- (.col_write this prefix)))
- (setf :buffering :writing)
- (last lines))))))
-
-
-(defn write-white-space [#^clojure.contrib.pprint.PrettyWriter this]
- (if-let [#^String tws (getf :trailing-white-space)]
- (dosync
- (.col_write this tws)
- (setf :trailing-white-space nil))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Writer overrides
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(declare write-char)
-
-(defn- -write
- ([#^clojure.contrib.pprint.PrettyWriter this x]
- ;; (prlabel write x (getf :mode))
- (condp = (class x)
- String
- (let [#^String s0 (write-initial-lines this x)
- #^String s (.replaceFirst s0 "\\s+$" "")
- white-space (.substring s0 (count s))
- mode (getf :mode)]
- (dosync
- (if (= mode :writing)
- (do
- (write-white-space this)
- (.col_write this s)
- (setf :trailing-white-space white-space))
- (let [oldpos (getf :pos)
- newpos (+ oldpos (count s0))]
- (setf :pos newpos)
- (add-to-buffer this (make-buffer-blob s white-space oldpos newpos))))))
-
- Integer
- (write-char this x))))
-
-(defn- write-char [#^clojure.contrib.pprint.PrettyWriter this #^Integer c]
- (if (= (getf :mode) :writing)
- (do
- (write-white-space this)
- (.col_write this c))
- (if (= c \newline)
- (write-initial-lines this "\n")
- (let [oldpos (getf :pos)
- newpos (inc oldpos)]
- (dosync
- (setf :pos newpos)
- (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos)))))))
-
-(defn- -flush [#^clojure.contrib.pprint.PrettyWriter this]
- (if (= (getf :mode) :buffering)
- (dosync
- (write-tokens this (getf :buffer) true)
- (setf :buffer []))
- (write-white-space this)))
-
-(defn- -close [this]
- (-flush this)) ;TODO: close underlying stream?
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Methods for PrettyWriter
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn -startBlock
- [#^clojure.contrib.pprint.PrettyWriter this
- #^String prefix #^String per-line-prefix #^String suffix]
- (dosync
- (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0)
- (ref false) (ref false)
- prefix per-line-prefix suffix)]
- (setf :logical-blocks lb)
- (if (= (getf :mode) :writing)
- (do
- (write-white-space this)
- (when-let [cb (getf :logical-block-callback)] (cb :start))
- (if prefix
- (.col_write this prefix))
- (let [col (.getColumn this)]
- (ref-set (:start-col lb) col)
- (ref-set (:indent lb) col)))
- (let [oldpos (getf :pos)
- newpos (+ oldpos (if prefix (count prefix) 0))]
- (setf :pos newpos)
- (add-to-buffer this (make-start-block lb oldpos newpos)))))))
-
-(defn -endBlock [#^clojure.contrib.pprint.PrettyWriter this]
- (dosync
- (let [lb (getf :logical-blocks)
- #^String suffix (:suffix lb)]
- (if (= (getf :mode) :writing)
- (do
- (write-white-space this)
- (if suffix
- (.col_write this suffix))
- (when-let [cb (getf :logical-block-callback)] (cb :end)))
- (let [oldpos (getf :pos)
- newpos (+ oldpos (if suffix (count suffix) 0))]
- (setf :pos newpos)
- (add-to-buffer this (make-end-block lb oldpos newpos))))
- (setf :logical-blocks (:parent lb)))))
-
-(defn- -newline [#^clojure.contrib.pprint.PrettyWriter this type]
- (dosync
- (setf :mode :buffering)
- (let [pos (getf :pos)]
- (add-to-buffer this (make-nl type (getf :logical-blocks) pos pos)))))
-
-(defn- -indent [#^clojure.contrib.pprint.PrettyWriter this relative-to offset]
- (dosync
- (let [lb (getf :logical-blocks)]
- (if (= (getf :mode) :writing)
- (do
- (write-white-space this)
- (ref-set (:indent lb)
- (+ offset (condp = relative-to
- :block @(:start-col lb)
- :current (.getColumn this)))))
- (let [pos (getf :pos)]
- (add-to-buffer this (make-indent lb relative-to offset pos pos)))))))
-
-(defn- -getMiserWidth [#^clojure.contrib.pprint.PrettyWriter this]
- (getf :miser-width))
-
-(defn- -setMiserWidth [#^clojure.contrib.pprint.PrettyWriter this new-miser-width]
- (dosync (setf :miser-width new-miser-width)))
-
-(defn- -setLogicalBlockCallback [#^clojure.contrib.pprint.PrettyWriter this f]
- (dosync (setf :logical-block-callback f)))
diff --git a/src/clojure/contrib/pprint/cl_format.clj b/src/clojure/contrib/pprint/cl_format.clj
deleted file mode 100644
index 145697ff..00000000
--- a/src/clojure/contrib/pprint/cl_format.clj
+++ /dev/null
@@ -1,1843 +0,0 @@
-;;; cl_format.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Dec 2008. 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 Common Lisp compatible format function as documented
-;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at:
-;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000)
-
-(in-ns 'clojure.contrib.pprint)
-
-;;; Forward references
-(declare compile-format)
-(declare execute-format)
-(declare init-navigator)
-;;; End forward references
-
-(defn cl-format
- "An implementation of a Common Lisp compatible format function. cl-format formats its
-arguments to an output stream or string based on the format control string given. It
-supports sophisticated formatting of structured data.
-
-Writer is an instance of java.io.Writer, true to output to *out* or nil to output
-to a string, format-in is the format control string and the remaining arguments
-are the data to be formatted.
-
-The format control string is a string to be output with embedded 'format directives'
-describing how to format the various arguments passed in.
-
-If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format
-returns nil.
-
-For example:
- (let [results [46 38 22]]
- (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\"
- (count results) results))
-
-Prints to *out*:
- There are 3 results: 46, 38, 22
-
-Detailed documentation on format control strings is available in the \"Common Lisp the
-Language, 2nd edition\", Chapter 22 (available online at:
-http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000)
-and in the Common Lisp HyperSpec at
-http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm
-"
- {:see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000"
- "Common Lisp the Language"]
- ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm"
- "Common Lisp HyperSpec"]]}
- [writer format-in & args]
- (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
- navigator (init-navigator args)]
- (execute-format writer compiled-format navigator)))
-
-(def #^{:private true} *format-str* nil)
-
-(defn- format-error [message offset]
- (let [full-message (str message \newline *format-str* \newline
- (apply str (repeat offset \space)) "^" \newline)]
- (throw (RuntimeException. full-message))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Argument navigators manage the argument list
-;;; as the format statement moves through the list
-;;; (possibly going forwards and backwards as it does so)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defstruct #^{:private true}
- arg-navigator :seq :rest :pos )
-
-(defn init-navigator
- "Create a new arg-navigator from the sequence with the position set to 0"
- {:skip-wiki true}
- [s]
- (let [s (seq s)]
- (struct arg-navigator s s 0)))
-
-;; TODO call format-error with offset
-(defn- next-arg [ navigator ]
- (let [ rst (:rest navigator) ]
- (if rst
- [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))]
- (throw (new Exception "Not enough arguments for format definition")))))
-
-(defn- next-arg-or-nil [navigator]
- (let [rst (:rest navigator)]
- (if rst
- [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))]
- [nil navigator])))
-
-;; Get an argument off the arg list and compile it if it's not already compiled
-(defn- get-format-arg [navigator]
- (let [[raw-format navigator] (next-arg navigator)
- compiled-format (if (instance? String raw-format)
- (compile-format raw-format)
- raw-format)]
- [compiled-format navigator]))
-
-(declare relative-reposition)
-
-(defn- absolute-reposition [navigator position]
- (if (>= position (:pos navigator))
- (relative-reposition navigator (- (:pos navigator) position))
- (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position)))
-
-(defn- relative-reposition [navigator position]
- (let [newpos (+ (:pos navigator) position)]
- (if (neg? position)
- (absolute-reposition navigator newpos)
- (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos))))
-
-(defstruct #^{:private true}
- compiled-directive :func :def :params :offset)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; When looking at the parameter list, we may need to manipulate
-;;; the argument list as well (for 'V' and '#' parameter types).
-;;; We hide all of this behind a function, but clients need to
-;;; manage changing arg navigator
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; TODO: validate parameters when they come from arg list
-(defn- realize-parameter [[param [raw-val offset]] navigator]
- (let [[real-param new-navigator]
- (cond
- (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary
- [raw-val navigator]
-
- (= raw-val :parameter-from-args)
- (next-arg navigator)
-
- (= raw-val :remaining-arg-count)
- [(count (:rest navigator)) navigator]
-
- true
- [raw-val navigator])]
- [[param [real-param offset]] new-navigator]))
-
-(defn- realize-parameter-list [parameter-map navigator]
- (let [[pairs new-navigator]
- (map-passing-context realize-parameter navigator parameter-map)]
- [(into {} pairs) new-navigator]))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Functions that support individual directives
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Common handling code for ~A and ~S
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(declare opt-base-str)
-
-(def #^{:private true}
- special-radix-markers {2 "#b" 8 "#o", 16 "#x"})
-
-(defn- format-simple-number [n]
- (cond
- (integer? n) (if (= *print-base* 10)
- (str n (if *print-radix* "."))
- (str
- (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))
- (opt-base-str *print-base* n)))
- (ratio? n) (str
- (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))
- (opt-base-str *print-base* (.numerator n))
- "/"
- (opt-base-str *print-base* (.denominator n)))
- :else nil))
-
-(defn- format-ascii [print-func params arg-navigator offsets]
- (let [ [arg arg-navigator] (next-arg arg-navigator)
- #^String base-output (or (format-simple-number arg) (print-func arg))
- base-width (.length base-output)
- min-width (+ base-width (:minpad params))
- width (if (>= min-width (:mincol params))
- min-width
- (+ min-width
- (* (+ (quot (- (:mincol params) min-width 1)
- (:colinc params) )
- 1)
- (:colinc params))))
- chars (apply str (repeat (- width base-width) (:padchar params)))]
- (if (:at params)
- (print (str chars base-output))
- (print (str base-output chars)))
- arg-navigator))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for the integer directives ~D, ~X, ~O, ~B and some
-;;; of ~R
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn- integral?
- "returns true if a number is actually an integer (that is, has no fractional part)"
- [x]
- (cond
- (integer? x) true
- (decimal? x) (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part
- (float? x) (= x (Math/floor x))
- (ratio? x) (let [#^clojure.lang.Ratio r x]
- (= 0 (rem (.numerator r) (.denominator r))))
- :else false))
-
-(defn- remainders
- "Return the list of remainders (essentially the 'digits') of val in the given base"
- [base val]
- (reverse
- (first
- (consume #(if (pos? %)
- [(rem % base) (quot % base)]
- [nil nil])
- val))))
-
-;;; TODO: xlated-val does not seem to be used here.
-(defn- base-str
- "Return val as a string in the given base"
- [base val]
- (if (zero? val)
- "0"
- (let [xlated-val (cond
- (float? val) (bigdec val)
- (ratio? val) (let [#^clojure.lang.Ratio r val]
- (/ (.numerator r) (.denominator r)))
- :else val)]
- (apply str
- (map
- #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10))))
- (remainders base val))))))
-
-(def #^{:private true}
- java-base-formats {8 "%o", 10 "%d", 16 "%x"})
-
-(defn- opt-base-str
- "Return val as a string in the given base, using clojure.core/format if supported
-for improved performance"
- [base val]
- (let [format-str (get java-base-formats base)]
- (if (and format-str (integer? val))
- (clojure.core/format format-str val)
- (base-str base val))))
-
-(defn- group-by [unit lis]
- (reverse
- (first
- (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis)))))
-
-(defn- format-integer [base params arg-navigator offsets]
- (let [[arg arg-navigator] (next-arg arg-navigator)]
- (if (integral? arg)
- (let [neg (neg? arg)
- pos-arg (if neg (- arg) arg)
- raw-str (opt-base-str base pos-arg)
- group-str (if (:colon params)
- (let [groups (map #(apply str %) (group-by (:commainterval params) raw-str))
- commas (repeat (count groups) (:commachar params))]
- (apply str (next (interleave commas groups))))
- raw-str)
- #^String signed-str (cond
- neg (str "-" group-str)
- (:at params) (str "+" group-str)
- true group-str)
- padded-str (if (< (.length signed-str) (:mincol params))
- (str (apply str (repeat (- (:mincol params) (.length signed-str))
- (:padchar params)))
- signed-str)
- signed-str)]
- (print padded-str))
- (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0
- :padchar (:padchar params) :at true}
- (init-navigator [arg]) nil))
- arg-navigator))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for english formats (~R and ~:R)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(def #^{:private true}
- english-cardinal-units
- ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
- "ten" "eleven" "twelve" "thirteen" "fourteen"
- "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"])
-
-(def #^{:private true}
- english-ordinal-units
- ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth"
- "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
- "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"])
-
-(def #^{:private true}
- english-cardinal-tens
- ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"])
-
-(def #^{:private true}
- english-ordinal-tens
- ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth"
- "sixtieth" "seventieth" "eightieth" "ninetieth"])
-
-;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales)
-;; Number names from http://www.jimloy.com/math/billion.htm
-;; We follow the rules for writing numbers from the Blue Book
-;; (http://www.grammarbook.com/numbers/numbers.asp)
-(def #^{:private true}
- english-scale-numbers
- ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion"
- "sextillion" "septillion" "octillion" "nonillion" "decillion"
- "undecillion" "duodecillion" "tredecillion" "quattuordecillion"
- "quindecillion" "sexdecillion" "septendecillion"
- "octodecillion" "novemdecillion" "vigintillion"])
-
-(defn- format-simple-cardinal
- "Convert a number less than 1000 to a cardinal english string"
- [num]
- (let [hundreds (quot num 100)
- tens (rem num 100)]
- (str
- (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))
- (if (and (pos? hundreds) (pos? tens)) " ")
- (if (pos? tens)
- (if (< tens 20)
- (nth english-cardinal-units tens)
- (let [ten-digit (quot tens 10)
- unit-digit (rem tens 10)]
- (str
- (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))
- (if (and (pos? ten-digit) (pos? unit-digit)) "-")
- (if (pos? unit-digit) (nth english-cardinal-units unit-digit)))))))))
-
-(defn- add-english-scales
- "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string
-offset is a factor of 10^3 to multiply by"
- [parts offset]
- (let [cnt (count parts)]
- (loop [acc []
- pos (dec cnt)
- this (first parts)
- remainder (next parts)]
- (if (nil? remainder)
- (str (apply str (interpose ", " acc))
- (if (and (not (empty? this)) (not (empty? acc))) ", ")
- this
- (if (and (not (empty? this)) (pos? (+ pos offset)))
- (str " " (nth english-scale-numbers (+ pos offset)))))
- (recur
- (if (empty? this)
- acc
- (conj acc (str this " " (nth english-scale-numbers (+ pos offset)))))
- (dec pos)
- (first remainder)
- (next remainder))))))
-
-(defn- format-cardinal-english [params navigator offsets]
- (let [[arg navigator] (next-arg navigator)]
- (if (= 0 arg)
- (print "zero")
- (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs
- parts (remainders 1000 abs-arg)]
- (if (<= (count parts) (count english-scale-numbers))
- (let [parts-strs (map format-simple-cardinal parts)
- full-str (add-english-scales parts-strs 0)]
- (print (str (if (neg? arg) "minus ") full-str)))
- (format-integer ;; for numbers > 10^63, we fall back on ~D
- 10
- { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
- (init-navigator [arg])
- { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}))))
- navigator))
-
-(defn- format-simple-ordinal
- "Convert a number less than 1000 to a ordinal english string
-Note this should only be used for the last one in the sequence"
- [num]
- (let [hundreds (quot num 100)
- tens (rem num 100)]
- (str
- (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))
- (if (and (pos? hundreds) (pos? tens)) " ")
- (if (pos? tens)
- (if (< tens 20)
- (nth english-ordinal-units tens)
- (let [ten-digit (quot tens 10)
- unit-digit (rem tens 10)]
- (if (and (pos? ten-digit) (not (pos? unit-digit)))
- (nth english-ordinal-tens ten-digit)
- (str
- (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))
- (if (and (pos? ten-digit) (pos? unit-digit)) "-")
- (if (pos? unit-digit) (nth english-ordinal-units unit-digit))))))
- (if (pos? hundreds) "th")))))
-
-(defn- format-ordinal-english [params navigator offsets]
- (let [[arg navigator] (next-arg navigator)]
- (if (= 0 arg)
- (print "zeroth")
- (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs
- parts (remainders 1000 abs-arg)]
- (if (<= (count parts) (count english-scale-numbers))
- (let [parts-strs (map format-simple-cardinal (drop-last parts))
- head-str (add-english-scales parts-strs 1)
- tail-str (format-simple-ordinal (last parts))]
- (print (str (if (neg? arg) "minus ")
- (cond
- (and (not (empty? head-str)) (not (empty? tail-str)))
- (str head-str ", " tail-str)
-
- (not (empty? head-str)) (str head-str "th")
- :else tail-str))))
- (do (format-integer ;; for numbers > 10^63, we fall back on ~D
- 10
- { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
- (init-navigator [arg])
- { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})
- (let [low-two-digits (rem arg 100)
- not-teens (or (< 11 low-two-digits) (> 19 low-two-digits))
- low-digit (rem low-two-digits 10)]
- (print (cond
- (and (= low-digit 1) not-teens) "st"
- (and (= low-digit 2) not-teens) "nd"
- (and (= low-digit 3) not-teens) "rd"
- :else "th")))))))
- navigator))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for roman numeral formats (~@R and ~@:R)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(def #^{:private true}
- old-roman-table
- [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"]
- [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"]
- [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"]
- [ "M" "MM" "MMM"]])
-
-(def #^{:private true}
- new-roman-table
- [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"]
- [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"]
- [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"]
- [ "M" "MM" "MMM"]])
-
-(defn- format-roman
- "Format a roman numeral using the specified look-up table"
- [table params navigator offsets]
- (let [[arg navigator] (next-arg navigator)]
- (if (and (number? arg) (> arg 0) (< arg 4000))
- (let [digits (remainders 10 arg)]
- (loop [acc []
- pos (dec (count digits))
- digits digits]
- (if (empty? digits)
- (print (apply str acc))
- (let [digit (first digits)]
- (recur (if (= 0 digit)
- acc
- (conj acc (nth (nth table pos) (dec digit))))
- (dec pos)
- (next digits))))))
- (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D
- 10
- { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
- (init-navigator [arg])
- { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}))
- navigator))
-
-(defn- format-old-roman [params navigator offsets]
- (format-roman old-roman-table params navigator offsets))
-
-(defn- format-new-roman [params navigator offsets]
- (format-roman new-roman-table params navigator offsets))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for character formats (~C)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(def #^{:private true}
- special-chars { 8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"})
-
-(defn- pretty-character [params navigator offsets]
- (let [[c navigator] (next-arg navigator)
- as-int (int c)
- base-char (bit-and as-int 127)
- meta (bit-and as-int 128)
- special (get special-chars base-char)]
- (if (> meta 0) (print "Meta-"))
- (print (cond
- special special
- (< base-char 32) (str "Control-" (char (+ base-char 64)))
- (= base-char 127) "Control-?"
- :else (char base-char)))
- navigator))
-
-(defn- readable-character [params navigator offsets]
- (let [[c navigator] (next-arg navigator)]
- (condp = (:char-format params)
- \o (cl-format true "\\o~3,'0o" (int c))
- \u (cl-format true "\\u~4,'0x" (int c))
- nil (pr c))
- navigator))
-
-(defn- plain-character [params navigator offsets]
- (let [[char navigator] (next-arg navigator)]
- (print char)
- navigator))
-
-;; Check to see if a result is an abort (~^) construct
-;; TODO: move these funcs somewhere more appropriate
-(defn- abort? [context]
- (let [token (first context)]
- (or (= :up-arrow token) (= :colon-up-arrow token))))
-
-;; Handle the execution of "sub-clauses" in bracket constructions
-(defn- execute-sub-format [format args base-args]
- (second
- (map-passing-context
- (fn [element context]
- (if (abort? context)
- [nil context] ; just keep passing it along
- (let [[params args] (realize-parameter-list (:params element) context)
- [params offsets] (unzip-map params)
- params (assoc params :base-args base-args)]
- [nil (apply (:func element) [params args offsets])])))
- args
- format)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for real number formats
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; TODO - return exponent as int to eliminate double conversion
-(defn- float-parts-base
- "Produce string parts for the mantissa (normalized 1-9) and exponent"
- [#^Object f]
- (let [#^String s (.toLowerCase (.toString f))
- exploc (.indexOf s (int \e))]
- (if (neg? exploc)
- (let [dotloc (.indexOf s (int \.))]
- (if (neg? dotloc)
- [s (str (dec (count s)))]
- [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))]))
- [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))])))
-
-
-(defn- float-parts
- "Take care of leading and trailing zeros in decomposed floats"
- [f]
- (let [[m #^String e] (float-parts-base f)
- m1 (rtrim m \0)
- m2 (ltrim m1 \0)
- delta (- (count m1) (count m2))
- #^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)]
- (if (empty? m2)
- ["0" 0]
- [m2 (- (Integer/valueOf e) delta)])))
-
-(defn- round-str [m e d w]
- (if (or d w)
- (let [len (count m)
- round-pos (if d (+ e d 1))
- round-pos (if (and w (< (inc e) (dec w))
- (or (nil? round-pos) (< (dec w) round-pos)))
- (dec w)
- round-pos)
- [m1 e1 round-pos len] (if (= round-pos 0)
- [(str "0" m) (inc e) 1 (inc len)]
- [m e round-pos len])]
- (if round-pos
- (if (neg? round-pos)
- ["0" 0 false]
- (if (> len round-pos)
- (let [round-char (nth m1 round-pos)
- #^String result (subs m1 0 round-pos)]
- (if (>= (int round-char) (int \5))
- (let [result-val (Integer/valueOf result)
- leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1)))
- round-up-result (str leading-zeros
- (String/valueOf (+ result-val
- (if (neg? result-val) -1 1))))
- expanded (> (count round-up-result) (count result))]
- [round-up-result e1 expanded])
- [result e1 false]))
- [m e false]))
- [m e false]))
- [m e false]))
-
-(defn- expand-fixed [m e d]
- (let [m1 (if (neg? e) (str (apply str (repeat (dec (- e)) \0)) m) m)
- len (count m1)
- target-len (if d (+ e d 1) (inc e))]
- (if (< len target-len)
- (str m1 (apply str (repeat (- target-len len) \0)))
- m1)))
-
-(defn- insert-decimal
- "Insert the decimal point at the right spot in the number to match an exponent"
- [m e]
- (if (neg? e)
- (str "." m)
- (let [loc (inc e)]
- (str (subs m 0 loc) "." (subs m loc)))))
-
-(defn- get-fixed [m e d]
- (insert-decimal (expand-fixed m e d) e))
-
-(defn- insert-scaled-decimal
- "Insert the decimal point at the right spot in the number to match an exponent"
- [m k]
- (if (neg? k)
- (str "." m)
- (str (subs m 0 k) "." (subs m k))))
-
-;; the function to render ~F directives
-;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
-(defn- fixed-float [params navigator offsets]
- (let [w (:w params)
- d (:d params)
- [arg navigator] (next-arg navigator)
- [mantissa exp] (float-parts arg)
- scaled-exp (+ exp (:k params))
- add-sign (and (:at params) (not (neg? arg)))
- prepend-zero (< -1.0 arg 1.0)
- append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp))
- [rounded-mantissa scaled-exp] (round-str mantissa scaled-exp
- d (if w (- w (if add-sign 1 0))))
- fixed-repr (get-fixed rounded-mantissa scaled-exp d)]
- (if w
- (let [len (count fixed-repr)
- signed-len (if add-sign (inc len) len)
- prepend-zero (and prepend-zero (not (= signed-len w)))
- append-zero (and append-zero (not (= signed-len w)))
- full-len (if (or prepend-zero append-zero)
- (inc signed-len)
- signed-len)]
- (if (and (> full-len w) (:overflowchar params))
- (print (apply str (repeat w (:overflowchar params))))
- (print (str
- (apply str (repeat (- w full-len) (:padchar params)))
- (if add-sign "+")
- (if prepend-zero "0")
- fixed-repr
- (if append-zero "0")))))
- (print (str
- (if add-sign "+")
- (if prepend-zero "0")
- fixed-repr
- (if append-zero "0"))))
- navigator))
-
-
-;; the function to render ~E directives
-;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
-;; TODO: define ~E representation for Infinity
-(defn- exponential-float [params navigator offsets]
- (let [[arg navigator] (next-arg navigator)]
- (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))]
- (let [w (:w params)
- d (:d params)
- e (:e params)
- k (:k params)
- expchar (or (:exponentchar params) \E)
- add-sign (or (:at params) (neg? arg))
- prepend-zero (<= k 0)
- #^Integer scaled-exp (- exp (dec k))
- scaled-exp-str (str (Math/abs scaled-exp))
- scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+)
- (if e (apply str
- (repeat
- (- e
- (count scaled-exp-str))
- \0)))
- scaled-exp-str)
- exp-width (count scaled-exp-str)
- base-mantissa-width (count mantissa)
- scaled-mantissa (str (apply str (repeat (- k) \0))
- mantissa
- (if d
- (apply str
- (repeat
- (- d (dec base-mantissa-width)
- (if (neg? k) (- k) 0)) \0))))
- w-mantissa (if w (- w exp-width))
- [rounded-mantissa _ incr-exp] (round-str
- scaled-mantissa 0
- (cond
- (= k 0) (dec d)
- (pos? k) d
- (neg? k) (dec d))
- (if w-mantissa
- (- w-mantissa (if add-sign 1 0))))
- full-mantissa (insert-scaled-decimal rounded-mantissa k)
- append-zero (and (= k (count rounded-mantissa)) (nil? d))]
- (if (not incr-exp)
- (if w
- (let [len (+ (count full-mantissa) exp-width)
- signed-len (if add-sign (inc len) len)
- prepend-zero (and prepend-zero (not (= signed-len w)))
- full-len (if prepend-zero (inc signed-len) signed-len)
- append-zero (and append-zero (< full-len w))]
- (if (and (or (> full-len w) (and e (> (- exp-width 2) e)))
- (:overflowchar params))
- (print (apply str (repeat w (:overflowchar params))))
- (print (str
- (apply str
- (repeat
- (- w full-len (if append-zero 1 0) )
- (:padchar params)))
- (if add-sign (if (neg? arg) \- \+))
- (if prepend-zero "0")
- full-mantissa
- (if append-zero "0")
- scaled-exp-str))))
- (print (str
- (if add-sign (if (neg? arg) \- \+))
- (if prepend-zero "0")
- full-mantissa
- (if append-zero "0")
- scaled-exp-str)))
- (recur [rounded-mantissa (inc exp)]))))
- navigator))
-
-;; the function to render ~G directives
-;; This just figures out whether to pass the request off to ~F or ~E based
-;; on the algorithm in CLtL.
-;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
-;; TODO: refactor so that float-parts isn't called twice
-(defn- general-float [params navigator offsets]
- (let [[arg _] (next-arg navigator)
- [mantissa exp] (float-parts (if (neg? arg) (- arg) arg))
- w (:w params)
- d (:d params)
- e (:e params)
- n (if (= arg 0.0) 0 (inc exp))
- ee (if e (+ e 2) 4)
- ww (if w (- w ee))
- d (if d d (max (count mantissa) (min n 7)))
- dd (- d n)]
- (if (<= 0 dd d)
- (let [navigator (fixed-float {:w ww, :d dd, :k 0,
- :overflowchar (:overflowchar params),
- :padchar (:padchar params), :at (:at params)}
- navigator offsets)]
- (print (apply str (repeat ee \space)))
- navigator)
- (exponential-float params navigator offsets))))
-
-;; the function to render ~$ directives
-;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
-(defn- dollar-float [params navigator offsets]
- (let [[#^Double arg navigator] (next-arg navigator)
- [mantissa exp] (float-parts (Math/abs arg))
- d (:d params) ; digits after the decimal
- n (:n params) ; minimum digits before the decimal
- w (:w params) ; minimum field width
- add-sign (or (:at params) (neg? arg))
- [rounded-mantissa scaled-exp _] (round-str mantissa exp d nil)
- #^String fixed-repr (get-fixed rounded-mantissa scaled-exp d)
- full-repr (str (apply str (repeat (- n (.indexOf fixed-repr (int \.))) \0)) fixed-repr)
- full-len (+ (count full-repr) (if add-sign 1 0))]
- (print (str
- (if (and (:colon params) add-sign) (if (neg? arg) \- \+))
- (apply str (repeat (- w full-len) (:padchar params)))
- (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+))
- full-repr))
- navigator))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for the '~[...~]' conditional construct in its
-;;; different flavors
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; ~[...~] without any modifiers chooses one of the clauses based on the param or
-;; next argument
-;; TODO check arg is positive int
-(defn- choice-conditional [params arg-navigator offsets]
- (let [arg (:selector params)
- [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator))
- clauses (:clauses params)
- clause (if (or (neg? arg) (>= arg (count clauses)))
- (first (:else params))
- (nth clauses arg))]
- (if clause
- (execute-sub-format clause navigator (:base-args params))
- navigator)))
-
-;; ~:[...~] with the colon reads the next argument treating it as a truth value
-(defn- boolean-conditional [params arg-navigator offsets]
- (let [[arg navigator] (next-arg arg-navigator)
- clauses (:clauses params)
- clause (if arg
- (second clauses)
- (first clauses))]
- (if clause
- (execute-sub-format clause navigator (:base-args params))
- navigator)))
-
-;; ~@[...~] with the at sign executes the conditional if the next arg is not
-;; nil/false without consuming the arg
-(defn- check-arg-conditional [params arg-navigator offsets]
- (let [[arg navigator] (next-arg arg-navigator)
- clauses (:clauses params)
- clause (if arg (first clauses))]
- (if arg
- (if clause
- (execute-sub-format clause arg-navigator (:base-args params))
- arg-navigator)
- navigator)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for the '~{...~}' iteration construct in its
-;;; different flavors
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;; ~{...~} without any modifiers uses the next argument as an argument list that
-;; is consumed by all the iterations
-(defn- iterate-sublist [params navigator offsets]
- (let [max-count (:max-iterations params)
- param-clause (first (:clauses params))
- [clause navigator] (if (empty? param-clause)
- (get-format-arg navigator)
- [param-clause navigator])
- [arg-list navigator] (next-arg navigator)
- args (init-navigator arg-list)]
- (loop [count 0
- args args
- last-pos -1]
- (if (and (not max-count) (= (:pos args) last-pos) (> count 1))
- ;; TODO get the offset in here and call format exception
- (throw (RuntimeException. "%{ construct not consuming any arguments: Infinite loop!")))
- (if (or (and (empty? (:rest args))
- (or (not (:colon (:right-params params))) (> count 0)))
- (and max-count (>= count max-count)))
- navigator
- (let [iter-result (execute-sub-format clause args (:base-args params))]
- (if (= :up-arrow (first iter-result))
- navigator
- (recur (inc count) iter-result (:pos args))))))))
-
-;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the
-;; sublists is used as the arglist for a single iteration.
-(defn- iterate-list-of-sublists [params navigator offsets]
- (let [max-count (:max-iterations params)
- param-clause (first (:clauses params))
- [clause navigator] (if (empty? param-clause)
- (get-format-arg navigator)
- [param-clause navigator])
- [arg-list navigator] (next-arg navigator)]
- (loop [count 0
- arg-list arg-list]
- (if (or (and (empty? arg-list)
- (or (not (:colon (:right-params params))) (> count 0)))
- (and max-count (>= count max-count)))
- navigator
- (let [iter-result (execute-sub-format
- clause
- (init-navigator (first arg-list))
- (init-navigator (next arg-list)))]
- (if (= :colon-up-arrow (first iter-result))
- navigator
- (recur (inc count) (next arg-list))))))))
-
-;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations
-;; is consumed by all the iterations
-(defn- iterate-main-list [params navigator offsets]
- (let [max-count (:max-iterations params)
- param-clause (first (:clauses params))
- [clause navigator] (if (empty? param-clause)
- (get-format-arg navigator)
- [param-clause navigator])]
- (loop [count 0
- navigator navigator
- last-pos -1]
- (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1))
- ;; TODO get the offset in here and call format exception
- (throw (RuntimeException. "%@{ construct not consuming any arguments: Infinite loop!")))
- (if (or (and (empty? (:rest navigator))
- (or (not (:colon (:right-params params))) (> count 0)))
- (and max-count (>= count max-count)))
- navigator
- (let [iter-result (execute-sub-format clause navigator (:base-args params))]
- (if (= :up-arrow (first iter-result))
- (second iter-result)
- (recur
- (inc count) iter-result (:pos navigator))))))))
-
-;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one
-;; of which is consumed with each iteration
-(defn- iterate-main-sublists [params navigator offsets]
- (let [max-count (:max-iterations params)
- param-clause (first (:clauses params))
- [clause navigator] (if (empty? param-clause)
- (get-format-arg navigator)
- [param-clause navigator])
- ]
- (loop [count 0
- navigator navigator]
- (if (or (and (empty? (:rest navigator))
- (or (not (:colon (:right-params params))) (> count 0)))
- (and max-count (>= count max-count)))
- navigator
- (let [[sublist navigator] (next-arg-or-nil navigator)
- iter-result (execute-sub-format clause (init-navigator sublist) navigator)]
- (if (= :colon-up-arrow (first iter-result))
- navigator
- (recur (inc count) navigator)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; The '~< directive has two completely different meanings
-;;; in the '~<...~>' form it does justification, but with
-;;; ~<...~:>' it represents the logical block operation of the
-;;; pretty printer.
-;;;
-;;; Unfortunately, the current architecture decides what function
-;;; to call at form parsing time before the sub-clauses have been
-;;; folded, so it is left to run-time to make the decision.
-;;;
-;;; TODO: make it possible to make these decisions at compile-time.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(declare format-logical-block)
-(declare justify-clauses)
-
-(defn- logical-block-or-justify [params navigator offsets]
- (if (:colon (:right-params params))
- (format-logical-block params navigator offsets)
- (justify-clauses params navigator offsets)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for the '~<...~>' justification directive
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn- render-clauses [clauses navigator base-navigator]
- (loop [clauses clauses
- acc []
- navigator navigator]
- (if (empty? clauses)
- [acc navigator]
- (let [clause (first clauses)
- [iter-result result-str] (binding [*out* (java.io.StringWriter.)]
- [(execute-sub-format clause navigator base-navigator)
- (.toString *out*)])]
- (if (= :up-arrow (first iter-result))
- [acc (second iter-result)]
- (recur (next clauses) (conj acc result-str) iter-result))))))
-
-;; TODO support for ~:; constructions
-(defn- justify-clauses [params navigator offsets]
- (let [[[eol-str] new-navigator] (when-let [else (:else params)]
- (render-clauses else navigator (:base-args params)))
- navigator (or new-navigator navigator)
- [else-params new-navigator] (when-let [p (:else-params params)]
- (realize-parameter-list p navigator))
- navigator (or new-navigator navigator)
- min-remaining (or (first (:min-remaining else-params)) 0)
- max-columns (or (first (:max-columns else-params))
- (.getMaxColumn #^PrettyWriter *out*))
- clauses (:clauses params)
- [strs navigator] (render-clauses clauses navigator (:base-args params))
- slots (max 1
- (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0)))
- chars (reduce + (map count strs))
- mincol (:mincol params)
- minpad (:minpad params)
- colinc (:colinc params)
- minout (+ chars (* slots minpad))
- result-columns (if (<= minout mincol)
- mincol
- (+ mincol (* colinc
- (+ 1 (quot (- minout mincol 1) colinc)))))
- total-pad (- result-columns chars)
- pad (max minpad (quot total-pad slots))
- extra-pad (- total-pad (* pad slots))
- pad-str (apply str (repeat pad (:padchar params)))]
- (if (and eol-str (> (+ (.getColumn #^PrettyWriter *out*) min-remaining result-columns)
- max-columns))
- (print eol-str))
- (loop [slots slots
- extra-pad extra-pad
- strs strs
- pad-only (or (:colon params)
- (and (= (count strs) 1) (not (:at params))))]
- (if (seq strs)
- (do
- (print (str (if (not pad-only) (first strs))
- (if (or pad-only (next strs) (:at params)) pad-str)
- (if (pos? extra-pad) (:padchar params))))
- (recur
- (dec slots)
- (dec extra-pad)
- (if pad-only strs (next strs))
- false))))
- navigator))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for case modification with ~(...~).
-;;; We do this by wrapping the underlying writer with
-;;; a special writer to do the appropriate modification. This
-;;; allows us to support arbitrary-sized output and sources
-;;; that may block.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn- downcase-writer
- "Returns a proxy that wraps writer, converting all characters to lower case"
- [#^java.io.Writer writer]
- (proxy [java.io.Writer] []
- (close [] (.close writer))
- (flush [] (.flush writer))
- (write ([#^chars cbuf #^Integer off #^Integer len]
- (.write writer cbuf off len))
- ([x]
- (condp = (class x)
- String
- (let [s #^String x]
- (.write writer (.toLowerCase s)))
-
- Integer
- (let [c #^Character x]
- (.write writer (int (Character/toLowerCase (char c))))))))))
-
-(defn- upcase-writer
- "Returns a proxy that wraps writer, converting all characters to upper case"
- [#^java.io.Writer writer]
- (proxy [java.io.Writer] []
- (close [] (.close writer))
- (flush [] (.flush writer))
- (write ([#^chars cbuf #^Integer off #^Integer len]
- (.write writer cbuf off len))
- ([x]
- (condp = (class x)
- String
- (let [s #^String x]
- (.write writer (.toUpperCase s)))
-
- Integer
- (let [c #^Character x]
- (.write writer (int (Character/toUpperCase (char c))))))))))
-
-(defn- capitalize-string
- "Capitalizes the words in a string. If first? is false, don't capitalize the
- first character of the string even if it's a letter."
- [s first?]
- (let [#^Character f (first s)
- s (if (and first? f (Character/isLetter f))
- (str (Character/toUpperCase f) (subs s 1))
- s)]
- (apply str
- (first
- (consume
- (fn [s]
- (if (empty? s)
- [nil nil]
- (let [m (re-matcher #"\W\w" s)
- match (re-find m)
- offset (and match (inc (.start m)))]
- (if offset
- [(str (subs s 0 offset)
- (Character/toUpperCase #^Character (nth s offset)))
- (subs s (inc offset))]
- [s nil]))))
- s)))))
-
-(defn- capitalize-word-writer
- "Returns a proxy that wraps writer, captializing all words"
- [#^java.io.Writer writer]
- (let [last-was-whitespace? (ref true)]
- (proxy [java.io.Writer] []
- (close [] (.close writer))
- (flush [] (.flush writer))
- (write
- ([#^chars cbuf #^Integer off #^Integer len]
- (.write writer cbuf off len))
- ([x]
- (condp = (class x)
- String
- (let [s #^String x]
- (.write writer
- #^String (capitalize-string (.toLowerCase s) @last-was-whitespace?))
- (dosync
- (ref-set last-was-whitespace?
- (Character/isWhitespace
- #^Character (nth s (dec (count s)))))))
-
- Integer
- (let [c (char x)]
- (let [mod-c (if @last-was-whitespace? (Character/toUpperCase #^Character (char x)) c)]
- (.write writer (int mod-c))
- (dosync (ref-set last-was-whitespace? (Character/isWhitespace #^Character (char x))))))))))))
-
-(defn- init-cap-writer
- "Returns a proxy that wraps writer, capitalizing the first word"
- [#^java.io.Writer writer]
- (let [capped (ref false)]
- (proxy [java.io.Writer] []
- (close [] (.close writer))
- (flush [] (.flush writer))
- (write ([#^chars cbuf #^Integer off #^Integer len]
- (.write writer cbuf off len))
- ([x]
- (condp = (class x)
- String
- (let [s (.toLowerCase #^String x)]
- (if (not @capped)
- (let [m (re-matcher #"\S" s)
- match (re-find m)
- offset (and match (.start m))]
- (if offset
- (do (.write writer
- (str (subs s 0 offset)
- (Character/toUpperCase #^Character (nth s offset))
- (.toLowerCase #^String (subs s (inc offset)))))
- (dosync (ref-set capped true)))
- (.write writer s)))
- (.write writer (.toLowerCase s))))
-
- Integer
- (let [c #^Character (char x)]
- (if (and (not @capped) (Character/isLetter c))
- (do
- (dosync (ref-set capped true))
- (.write writer (int (Character/toUpperCase c))))
- (.write writer (int (Character/toLowerCase c)))))))))))
-
-(defn- modify-case [make-writer params navigator offsets]
- (let [clause (first (:clauses params))]
- (binding [*out* (make-writer *out*)]
- (execute-sub-format clause navigator (:base-args params)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; If necessary, wrap the writer in a PrettyWriter object
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn pretty-writer [writer]
- (if (instance? PrettyWriter writer)
- writer
- (PrettyWriter. writer *print-right-margin* *print-miser-width*)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for column-aware operations ~&, ~T
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; TODO: make an automatic newline for non-ColumnWriters
-(defn fresh-line
- "Make a newline if the Writer is not already at the beginning of the line.
-N.B. Only works on ColumnWriters right now."
- []
- (if (not (= 0 (.getColumn #^PrettyWriter *out*)))
- (prn)))
-
-(defn- absolute-tabulation [params navigator offsets]
- (let [colnum (:colnum params)
- colinc (:colinc params)
- current (.getColumn #^PrettyWriter *out*)
- space-count (cond
- (< current colnum) (- colnum current)
- (= colinc 0) 0
- :else (- colinc (rem (- current colnum) colinc)))]
- (print (apply str (repeat space-count \space))))
- navigator)
-
-(defn- relative-tabulation [params navigator offsets]
- (let [colrel (:colnum params)
- colinc (:colinc params)
- start-col (+ colrel (.getColumn #^PrettyWriter *out*))
- offset (if (pos? colinc) (rem start-col colinc) 0)
- space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))]
- (print (apply str (repeat space-count \space))))
- navigator)
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Support for accessing the pretty printer from a format
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; TODO: support ~@; per-line-prefix separator
-;; TODO: get the whole format wrapped so we can start the lb at any column
-(defn- format-logical-block [params navigator offsets]
- (let [clauses (:clauses params)
- clause-count (count clauses)
- prefix (cond
- (> clause-count 1) (:string (:params (first (first clauses))))
- (:colon params) "(")
- body (nth clauses (if (> clause-count 1) 1 0))
- suffix (cond
- (> clause-count 2) (:string (:params (first (nth clauses 2))))
- (:colon params) ")")
- [arg navigator] (next-arg navigator)]
- (pprint-logical-block :prefix prefix :suffix suffix
- (execute-sub-format
- body
- (init-navigator arg)
- (:base-args params)))
- navigator))
-
-(defn- set-indent [params navigator offsets]
- (let [relative-to (if (:colon params) :current :block)]
- (pprint-indent relative-to (:n params))
- navigator))
-
-;;; TODO: support ~:T section options for ~T
-
-(defn- conditional-newline [params navigator offsets]
- (let [kind (if (:colon params)
- (if (:at params) :mandatory :fill)
- (if (:at params) :miser :linear))]
- (pprint-newline kind)
- navigator))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; The table of directives we support, each with its params,
-;;; properties, and the compilation function
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; We start with a couple of helpers
-(defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ]
- [char,
- {:directive char,
- :params `(array-map ~@params),
- :flags flags,
- :bracket-info bracket-info,
- :generator-fn (concat '(fn [ params offset]) generator-fn) }])
-
-(defmacro #^{:private true}
- defdirectives
- [ & directives ]
- `(def #^{:private true}
- directive-table (hash-map ~@(mapcat process-directive-table-element directives))))
-
-(defdirectives
- (\A
- [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ]
- #{ :at :colon :both} {}
- #(format-ascii print-str %1 %2 %3))
-
- (\S
- [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ]
- #{ :at :colon :both} {}
- #(format-ascii pr-str %1 %2 %3))
-
- (\D
- [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character]
- :commainterval [ 3 Integer]]
- #{ :at :colon :both } {}
- #(format-integer 10 %1 %2 %3))
-
- (\B
- [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character]
- :commainterval [ 3 Integer]]
- #{ :at :colon :both } {}
- #(format-integer 2 %1 %2 %3))
-
- (\O
- [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character]
- :commainterval [ 3 Integer]]
- #{ :at :colon :both } {}
- #(format-integer 8 %1 %2 %3))
-
- (\X
- [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character]
- :commainterval [ 3 Integer]]
- #{ :at :colon :both } {}
- #(format-integer 16 %1 %2 %3))
-
- (\R
- [:base [nil Integer] :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character]
- :commainterval [ 3 Integer]]
- #{ :at :colon :both } {}
- (do
- (cond ; ~R is overloaded with bizareness
- (first (:base params)) #(format-integer (:base %1) %1 %2 %3)
- (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3)
- (:at params) #(format-new-roman %1 %2 %3)
- (:colon params) #(format-ordinal-english %1 %2 %3)
- true #(format-cardinal-english %1 %2 %3))))
-
- (\P
- [ ]
- #{ :at :colon :both } {}
- (fn [params navigator offsets]
- (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator)
- strs (if (:at params) ["y" "ies"] ["" "s"])
- [arg navigator] (next-arg navigator)]
- (print (if (= arg 1) (first strs) (second strs)))
- navigator)))
-
- (\C
- [:char-format [nil Character]]
- #{ :at :colon :both } {}
- (cond
- (:colon params) pretty-character
- (:at params) readable-character
- :else plain-character))
-
- (\F
- [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character]
- :padchar [\space Character] ]
- #{ :at } {}
- fixed-float)
-
- (\E
- [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer]
- :overflowchar [nil Character] :padchar [\space Character]
- :exponentchar [nil Character] ]
- #{ :at } {}
- exponential-float)
-
- (\G
- [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer]
- :overflowchar [nil Character] :padchar [\space Character]
- :exponentchar [nil Character] ]
- #{ :at } {}
- general-float)
-
- (\$
- [ :d [2 Integer] :n [1 Integer] :w [0 Integer] :padchar [\space Character]]
- #{ :at :colon :both} {}
- dollar-float)
-
- (\%
- [ :count [1 Integer] ]
- #{ } {}
- (fn [params arg-navigator offsets]
- (dotimes [i (:count params)]
- (prn))
- arg-navigator))
-
- (\&
- [ :count [1 Integer] ]
- #{ :pretty } {}
- (fn [params arg-navigator offsets]
- (let [cnt (:count params)]
- (if (pos? cnt) (fresh-line))
- (dotimes [i (dec cnt)]
- (prn)))
- arg-navigator))
-
- (\|
- [ :count [1 Integer] ]
- #{ } {}
- (fn [params arg-navigator offsets]
- (dotimes [i (:count params)]
- (print \formfeed))
- arg-navigator))
-
- (\~
- [ :n [1 Integer] ]
- #{ } {}
- (fn [params arg-navigator offsets]
- (let [n (:n params)]
- (print (apply str (repeat n \~)))
- arg-navigator)))
-
- (\newline ;; Whitespace supression is handled in the compilation loop
- [ ]
- #{:colon :at} {}
- (fn [params arg-navigator offsets]
- (if (:at params)
- (prn))
- arg-navigator))
-
- (\T
- [ :colnum [1 Integer] :colinc [1 Integer] ]
- #{ :at :pretty } {}
- (if (:at params)
- #(relative-tabulation %1 %2 %3)
- #(absolute-tabulation %1 %2 %3)))
-
- (\*
- [ :n [1 Integer] ]
- #{ :colon :at } {}
- (fn [params navigator offsets]
- (let [n (:n params)]
- (if (:at params)
- (absolute-reposition navigator n)
- (relative-reposition navigator (if (:colon params) (- n) n)))
- )))
-
- (\?
- [ ]
- #{ :at } {}
- (if (:at params)
- (fn [params navigator offsets] ; args from main arg list
- (let [[subformat navigator] (get-format-arg navigator)]
- (execute-sub-format subformat navigator (:base-args params))))
- (fn [params navigator offsets] ; args from sub-list
- (let [[subformat navigator] (get-format-arg navigator)
- [subargs navigator] (next-arg navigator)
- sub-navigator (init-navigator subargs)]
- (execute-sub-format subformat sub-navigator (:base-args params))
- navigator))))
-
-
- (\(
- [ ]
- #{ :colon :at :both} { :right \), :allows-separator nil, :else nil }
- (let [mod-case-writer (cond
- (and (:at params) (:colon params))
- upcase-writer
-
- (:colon params)
- capitalize-word-writer
-
- (:at params)
- init-cap-writer
-
- :else
- downcase-writer)]
- #(modify-case mod-case-writer %1 %2 %3)))
-
- (\) [] #{} {} nil)
-
- (\[
- [ :selector [nil Integer] ]
- #{ :colon :at } { :right \], :allows-separator true, :else :last }
- (cond
- (:colon params)
- boolean-conditional
-
- (:at params)
- check-arg-conditional
-
- true
- choice-conditional))
-
- (\; [:min-remaining [nil Integer] :max-columns [nil Integer]]
- #{ :colon } { :separator true } nil)
-
- (\] [] #{} {} nil)
-
- (\{
- [ :max-iterations [nil Integer] ]
- #{ :colon :at :both} { :right \}, :allows-separator false }
- (cond
- (and (:at params) (:colon params))
- iterate-main-sublists
-
- (:colon params)
- iterate-list-of-sublists
-
- (:at params)
- iterate-main-list
-
- true
- iterate-sublist))
-
-
- (\} [] #{:colon} {} nil)
-
- (\<
- [:mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character]]
- #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first }
- logical-block-or-justify)
-
- (\> [] #{:colon} {} nil)
-
- ;; TODO: detect errors in cases where colon not allowed
- (\^ [:arg1 [nil Integer] :arg2 [nil Integer] :arg3 [nil Integer]]
- #{:colon} {}
- (fn [params navigator offsets]
- (let [arg1 (:arg1 params)
- arg2 (:arg2 params)
- arg3 (:arg3 params)
- exit (if (:colon params) :colon-up-arrow :up-arrow)]
- (cond
- (and arg1 arg2 arg3)
- (if (<= arg1 arg2 arg3) [exit navigator] navigator)
-
- (and arg1 arg2)
- (if (= arg1 arg2) [exit navigator] navigator)
-
- arg1
- (if (= arg1 0) [exit navigator] navigator)
-
- true ; TODO: handle looking up the arglist stack for info
- (if (if (:colon params)
- (empty? (:rest (:base-args params)))
- (empty? (:rest navigator)))
- [exit navigator] navigator)))))
-
- (\W
- []
- #{:at :colon :both} {}
- (if (or (:at params) (:colon params))
- (let [bindings (concat
- (if (:at params) [:level nil :length nil] [])
- (if (:colon params) [:pretty true] []))]
- (fn [params navigator offsets]
- (let [[arg navigator] (next-arg navigator)]
- (if (apply write arg bindings)
- [:up-arrow navigator]
- navigator))))
- (fn [params navigator offsets]
- (let [[arg navigator] (next-arg navigator)]
- (if (write-out arg)
- [:up-arrow navigator]
- navigator)))))
-
- (\_
- []
- #{:at :colon :both} {}
- conditional-newline)
-
- (\I
- [:n [0 Integer]]
- #{:colon} {}
- set-indent)
- )
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Code to manage the parameters and flags associated with each
-;;; directive in the format string.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(def #^{:private true}
- param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))")
-(def #^{:private true}
- special-params #{ :parameter-from-args :remaining-arg-count })
-
-(defn- extract-param [[s offset saw-comma]]
- (let [m (re-matcher param-pattern s)
- param (re-find m)]
- (if param
- (let [token-str (first (re-groups m))
- remainder (subs s (.end m))
- new-offset (+ offset (.end m))]
- (if (not (= \, (nth remainder 0)))
- [ [token-str offset] [remainder new-offset false]]
- [ [token-str offset] [(subs remainder 1) (inc new-offset) true]]))
- (if saw-comma
- (format-error "Badly formed parameters in format directive" offset)
- [ nil [s offset]]))))
-
-
-(defn- extract-params [s offset]
- (consume extract-param [s offset false]))
-
-(defn- translate-param
- "Translate the string representation of a param to the internalized
- representation"
- [[#^String p offset]]
- [(cond
- (= (.length p) 0) nil
- (and (= (.length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args
- (and (= (.length p) 1) (= \# (nth p 0))) :remaining-arg-count
- (and (= (.length p) 2) (= \' (nth p 0))) (nth p 1)
- true (new Integer p))
- offset])
-
-(def #^{:private true}
- flag-defs { \: :colon, \@ :at })
-
-(defn- extract-flags [s offset]
- (consume
- (fn [[s offset flags]]
- (if (empty? s)
- [nil [s offset flags]]
- (let [flag (get flag-defs (first s))]
- (if flag
- (if (contains? flags flag)
- (format-error
- (str "Flag \"" (first s) "\" appears more than once in a directive")
- offset)
- [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]])
- [nil [s offset flags]]))))
- [s offset {}]))
-
-(defn- check-flags [def flags]
- (let [allowed (:flags def)]
- (if (and (not (:at allowed)) (:at flags))
- (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"")
- (nth (:at flags) 1)))
- (if (and (not (:colon allowed)) (:colon flags))
- (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"")
- (nth (:colon flags) 1)))
- (if (and (not (:both allowed)) (:at flags) (:colon flags))
- (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \""
- (:directive def) "\"")
- (min (nth (:colon flags) 1) (nth (:at flags) 1))))))
-
-(defn- map-params
- "Takes a directive definition and the list of actual parameters and
-a map of flags and returns a map of the parameters and flags with defaults
-filled in. We check to make sure that there are the right types and number
-of parameters as well."
- [def params flags offset]
- (check-flags def flags)
- (if (> (count params) (count (:params def)))
- (format-error
- (cl-format
- nil
- "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed"
- (:directive def) (count params) (count (:params def)))
- (second (first params))))
- (doall
- (map #(let [val (first %1)]
- (if (not (or (nil? val) (contains? special-params val)
- (instance? (second (second %2)) val)))
- (format-error (str "Parameter " (name (first %2))
- " has bad type in directive \"" (:directive def) "\": "
- (class val))
- (second %1))) )
- params (:params def)))
-
- (merge ; create the result map
- (into (array-map) ; start with the default values, make sure the order is right
- (reverse (for [[name [default]] (:params def)] [name [default offset]])))
- (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils
- flags)) ; and finally add the flags
-
-(defn- compile-directive [s offset]
- (let [[raw-params [rest offset]] (extract-params s offset)
- [_ [rest offset flags]] (extract-flags rest offset)
- directive (first rest)
- def (get directive-table (Character/toUpperCase #^Character directive))
- params (if def (map-params def (map translate-param raw-params) flags offset))]
- (if (not directive)
- (format-error "Format string ended in the middle of a directive" offset))
- (if (not def)
- (format-error (str "Directive \"" directive "\" is undefined") offset))
- [(struct compiled-directive ((:generator-fn def) params offset) def params offset)
- (let [remainder (subs rest 1)
- offset (inc offset)
- trim? (and (= \newline (:directive def))
- (not (:colon params)))
- trim-count (if trim? (prefix-count remainder [\space \tab]) 0)
- remainder (subs remainder trim-count)
- offset (+ offset trim-count)]
- [remainder offset])]))
-
-(defn- compile-raw-string [s offset]
- (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset))
-
-(defn- right-bracket [this] (:right (:bracket-info (:def this))))
-(defn- separator? [this] (:separator (:bracket-info (:def this))))
-(defn- else-separator? [this]
- (and (:separator (:bracket-info (:def this)))
- (:colon (:params this))))
-
-
-(declare collect-clauses)
-
-(defn- process-bracket [this remainder]
- (let [[subex remainder] (collect-clauses (:bracket-info (:def this))
- (:offset this) remainder)]
- [(struct compiled-directive
- (:func this) (:def this)
- (merge (:params this) (tuple-map subex (:offset this)))
- (:offset this))
- remainder]))
-
-(defn- process-clause [bracket-info offset remainder]
- (consume
- (fn [remainder]
- (if (empty? remainder)
- (format-error "No closing bracket found." offset)
- (let [this (first remainder)
- remainder (next remainder)]
- (cond
- (right-bracket this)
- (process-bracket this remainder)
-
- (= (:right bracket-info) (:directive (:def this)))
- [ nil [:right-bracket (:params this) nil remainder]]
-
- (else-separator? this)
- [nil [:else nil (:params this) remainder]]
-
- (separator? this)
- [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~;
-
- true
- [this remainder]))))
- remainder))
-
-(defn- collect-clauses [bracket-info offset remainder]
- (second
- (consume
- (fn [[clause-map saw-else remainder]]
- (let [[clause [type right-params else-params remainder]]
- (process-clause bracket-info offset remainder)]
- (cond
- (= type :right-bracket)
- [nil [(merge-with concat clause-map
- {(if saw-else :else :clauses) [clause]
- :right-params right-params})
- remainder]]
-
- (= type :else)
- (cond
- (:else clause-map)
- (format-error "Two else clauses (\"~:;\") inside bracket construction." offset)
-
- (not (:else bracket-info))
- (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it."
- offset)
-
- (and (= :first (:else bracket-info)) (seq (:clauses clause-map)))
- (format-error
- "The else clause (\"~:;\") is only allowed in the first position for this directive."
- offset)
-
- true ; if the ~:; is in the last position, the else clause
- ; is next, this was a regular clause
- (if (= :first (:else bracket-info))
- [true [(merge-with concat clause-map { :else [clause] :else-params else-params})
- false remainder]]
- [true [(merge-with concat clause-map { :clauses [clause] })
- true remainder]]))
-
- (= type :separator)
- (cond
- saw-else
- (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset)
-
- (not (:allows-separator bracket-info))
- (format-error "A separator (\"~;\") is in a bracket type that doesn't support it."
- offset)
-
- true
- [true [(merge-with concat clause-map { :clauses [clause] })
- false remainder]]))))
- [{ :clauses [] } false remainder])))
-
-(defn- process-nesting
- "Take a linearly compiled format and process the bracket directives to give it
- the appropriate tree structure"
- [format]
- (first
- (consume
- (fn [remainder]
- (let [this (first remainder)
- remainder (next remainder)
- bracket (:bracket-info (:def this))]
- (if (:right bracket)
- (process-bracket this remainder)
- [this remainder])))
- format)))
-
-(defn compile-format
- "Compiles format-str into a compiled format which can be used as an argument
-to cl-format just like a plain format string. Use this function for improved
-performance when you're using the same format string repeatedly"
- [ format-str ]
-; (prlabel compiling format-str)
- (binding [*format-str* format-str]
- (process-nesting
- (first
- (consume
- (fn [[#^String s offset]]
- (if (empty? s)
- [nil s]
- (let [tilde (.indexOf s (int \~))]
- (cond
- (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.length s))]]
- (zero? tilde) (compile-directive (subs s 1) (inc offset))
- true
- [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]]))))
- [format-str 0])))))
-
-(defn- needs-pretty
- "determine whether a given compiled format has any directives that depend on the
-column number or pretty printing"
- [format]
- (loop [format format]
- (if (empty? format)
- false
- (if (or (:pretty (:flags (:def (first format))))
- (some needs-pretty (first (:clauses (:params (first format)))))
- (some needs-pretty (first (:else (:params (first format))))))
- true
- (recur (next format))))))
-
-(defn execute-format
- "Executes the format with the arguments. This should never be used directly, but is public
-because the formatter macro uses it."
- {:skip-wiki true}
- ([stream format args]
- (let [#^java.io.Writer real-stream (cond
- (not stream) (java.io.StringWriter.)
- (true? stream) *out*
- :else stream)
- #^java.io.Writer wrapped-stream (if (and (needs-pretty format)
- (not (instance? PrettyWriter real-stream)))
- (pretty-writer real-stream)
- real-stream)]
- (binding [*out* wrapped-stream]
- (try
- (execute-format format args)
- (finally
- (if-not (identical? real-stream wrapped-stream)
- (.flush wrapped-stream))))
- (if (not stream) (.toString real-stream)))))
- ([format args]
- (map-passing-context
- (fn [element context]
- (if (abort? context)
- [nil context]
- (let [[params args] (realize-parameter-list
- (:params element) context)
- [params offsets] (unzip-map params)
- params (assoc params :base-args args)]
- [nil (apply (:func element) [params args offsets])])))
- args
- format)))
-
-
-(defmacro formatter
- "Makes a function which can directly run format-in. The function is
-fn [stream & args] ... and returns nil unless the stream is nil (meaning
-output to a string) in which case it returns the resulting string.
-
-format-in can be either a control string or a previously compiled format."
- [format-in]
- (let [cf (gensym "compiled-format")]
- `(let [format-in# ~format-in]
- (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#))
- (fn [stream# & args#]
- (let [navigator# (init-navigator args#)]
- (execute-format stream# ~cf navigator#)))))))
-
-(defmacro formatter-out
- "Makes a function which can directly run format-in. The function is
-fn [& args] ... and returns nil. This version of the formatter macro is
-designed to be used with *out* set to an appropriate Writer. In particular,
-this is meant to be used as part of a pretty printer dispatch method.
-
-format-in can be either a control string or a previously compiled format."
- [format-in]
- (let [cf (gensym "compiled-format")]
- `(let [format-in# ~format-in]
- (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#))
- (fn [& args#]
- (let [navigator# (init-navigator args#)]
- (execute-format ~cf navigator#)))))))
diff --git a/src/clojure/contrib/pprint/dispatch.clj b/src/clojure/contrib/pprint/dispatch.clj
deleted file mode 100644
index 82db8746..00000000
--- a/src/clojure/contrib/pprint/dispatch.clj
+++ /dev/null
@@ -1,447 +0,0 @@
-;; 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
-
diff --git a/src/clojure/contrib/pprint/examples/hexdump.clj b/src/clojure/contrib/pprint/examples/hexdump.clj
deleted file mode 100644
index fa5316ec..00000000
--- a/src/clojure/contrib/pprint/examples/hexdump.clj
+++ /dev/null
@@ -1,63 +0,0 @@
-;;; hexdump.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Dec 2008. 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 example is a classic hexdump program written using cl-format.
-
-;; For some local color, it was written in Dulles Airport while waiting for a flight
-;; home to San Francisco.
-
-(ns clojure.contrib.pprint.examples.hexdump
- (:use clojure.contrib.pprint
- clojure.contrib.pprint.utilities)
- (:gen-class (:main true)))
-
-(def *buffer-length* 1024)
-
-(defn zip-array [base-offset arr]
- (let [grouped (partition 16 arr)]
- (first (map-passing-context
- (fn [line offset]
- [[offset
- (map #(if (neg? %) (+ % 256) %) line)
- (- 16 (count line))
- (map #(if (<= 32 % 126) (char %) \.) line)]
- (+ 16 offset)])
- base-offset grouped))))
-
-
-(defn hexdump
- ([in-stream] (hexdump in-stream true 0))
- ([in-stream out-stream] (hexdump [in-stream out-stream 0]))
- ([in-stream out-stream offset]
- (let [buf (make-array Byte/TYPE *buffer-length*)]
- (loop [offset offset
- count (.read in-stream buf)]
- (if (neg? count)
- nil
- (let [bytes (take count buf)
- zipped (zip-array offset bytes)]
- (cl-format out-stream
- "~:{~8,'0X: ~2{~8@{~#[ ~:;~2,'0X ~]~} ~}~v@{ ~}~2{~8@{~A~} ~}~%~}"
- zipped)
- (recur (+ offset *buffer-length*) (.read in-stream buf))))))))
-
-(defn hexdump-file
- ([file-name] (hexdump-file file-name true))
- ([file-name stream]
- (with-open [s (java.io.FileInputStream. file-name)]
- (hexdump s))))
-
-;; I don't quite understand how to invoke main funcs w/o AOT yet
-(defn -main [& args]
- (hexdump-file (first args)))
-
diff --git a/src/clojure/contrib/pprint/examples/json.clj b/src/clojure/contrib/pprint/examples/json.clj
deleted file mode 100644
index 3cde1751..00000000
--- a/src/clojure/contrib/pprint/examples/json.clj
+++ /dev/null
@@ -1,142 +0,0 @@
-;;; json.clj: A pretty printing version of the JavaScript Object Notation (JSON) generator
-
-;; by Tom Faulhaber, based on the version by Stuart Sierra (clojure.contrib.json.write)
-;; May 9, 2009
-
-;; Copyright (c) Tom Faulhaber/Stuart Sierra, 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.
-
-
-(ns
- #^{:author "Tom Faulhaber (based on the version by Stuart Sierra)",
- :doc "Pretty printing JavaScript Object Notation (JSON) generator.
-
-This is an example of using a pretty printer dispatch function to generate JSON output",
- :see-also [["http://json.org/", "JSON Home Page"]]}
- clojure.contrib.pprint.examples.json
- (:require [clojure.contrib.java-utils :as j])
- (:use [clojure.test :only (deftest- is)]
- [clojure.contrib.pprint :only (write formatter-out)]))
-
-
-
-(defmulti dispatch-json
- "The dispatch function for printing objects as JSON"
- {:arglists '[[x]]}
- (fn [x] (cond
- (nil? x) nil ;; prevent NullPointerException on next line
- (.isArray (class x)) ::array
- :else (type x))))
-
-;; Primitive types can be printed with Clojure's pr function.
-(derive java.lang.Boolean ::pr)
-(derive java.lang.Byte ::pr)
-(derive java.lang.Short ::pr)
-(derive java.lang.Integer ::pr)
-(derive java.lang.Long ::pr)
-(derive java.lang.Float ::pr)
-(derive java.lang.Double ::pr)
-
-;; Collection types can be printed as JSON objects or arrays.
-(derive java.util.Map ::object)
-(derive java.util.Collection ::array)
-
-;; Symbols and keywords are converted to strings.
-(derive clojure.lang.Symbol ::symbol)
-(derive clojure.lang.Keyword ::symbol)
-
-
-(defmethod dispatch-json ::pr [x] (pr x))
-
-(defmethod dispatch-json nil [x] (print "null"))
-
-(defmethod dispatch-json ::symbol [x] (pr (name x)))
-
-(defmethod dispatch-json ::array [s]
- ((formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>") s))
-
-(defmethod dispatch-json ::object [m]
- ((formatter-out "~<{~;~@{~<~w:~_~w~:>~^, ~_~}~;}~:>")
- (for [[k v] m] [(j/as-str k) v])))
-
-(defmethod dispatch-json java.lang.CharSequence [s]
- (print \")
- (dotimes [i (count s)]
- (let [cp (Character/codePointAt s i)]
- (cond
- ;; Handle printable JSON escapes before ASCII
- (= cp 34) (print "\\\"")
- (= cp 92) (print "\\\\")
- ;; Print simple ASCII characters
- (< 31 cp 127) (print (.charAt s i))
- ;; Handle non-printable JSON escapes
- (= cp 8) (print "\\b")
- (= cp 12) (print "\\f")
- (= cp 10) (print "\\n")
- (= cp 13) (print "\\r")
- (= cp 9) (print "\\t")
- ;; Any other character is printed as Hexadecimal escape
- :else (printf "\\u%04x" cp))))
- (print \"))
-
-(defn print-json
- "Prints x as JSON. Nil becomes JSON null. Keywords become
- strings, without the leading colon. Maps become JSON objects, all
- other collection types become JSON arrays. Java arrays become JSON
- arrays. Unicode characters in strings are escaped as \\uXXXX.
- Numbers print as with pr."
- [x]
- (write x :dispatch dispatch-json))
-
-(defn json-str
- "Converts x to a JSON-formatted string."
- [x]
- (with-out-str (print-json x)))
-
-
-
-;;; TESTS
-
-;; Run these tests with
-;; (clojure.test/run-tests 'clojure.contrib.print-json)
-
-;; Bind clojure.test/*load-tests* to false to omit these
-;; tests from production code.
-
-(deftest- can-print-json-strings
- (is (= "\"Hello, World!\"" (json-str "Hello, World!")))
- (is (= "\"\\\"Embedded\\\" Quotes\"" (json-str "\"Embedded\" Quotes"))))
-
-(deftest- can-print-unicode
- (is (= "\"\\u1234\\u4567\"" (json-str "\u1234\u4567"))))
-
-(deftest- can-print-json-null
- (is (= "null" (json-str nil))))
-
-(deftest- can-print-json-arrays
- (is (= "[1, 2, 3]" (json-str [1 2 3])))
- (is (= "[1, 2, 3]" (json-str (list 1 2 3))))
- (is (= "[1, 2, 3]" (json-str (sorted-set 1 2 3))))
- (is (= "[1, 2, 3]" (json-str (seq [1 2 3])))))
-
-(deftest- can-print-java-arrays
- (is (= "[1, 2, 3]" (json-str (into-array [1 2 3])))))
-
-(deftest- can-print-empty-arrays
- (is (= "[]" (json-str [])))
- (is (= "[]" (json-str (list))))
- (is (= "[]" (json-str #{}))))
-
-(deftest- can-print-json-objects
- (is (= "{\"a\":1, \"b\":2}" (json-str (sorted-map :a 1 :b 2)))))
-
-(deftest- object-keys-must-be-strings
- (is (= "{\"1\":1, \"2\":2}" (json-str (sorted-map 1 1 2 2)))))
-
-(deftest- can-print-empty-objects
- (is (= "{}" (json-str {}))))
diff --git a/src/clojure/contrib/pprint/examples/multiply.clj b/src/clojure/contrib/pprint/examples/multiply.clj
deleted file mode 100644
index c7e33035..00000000
--- a/src/clojure/contrib/pprint/examples/multiply.clj
+++ /dev/null
@@ -1,23 +0,0 @@
-;;; multiply.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Dec 2008. 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 example prints a multiplication table using cl-format.
-
-(ns clojure.contrib.pprint.examples.multiply
- (:use clojure.contrib.pprint))
-
-(defn multiplication-table [limit]
- (let [nums (range 1 (inc limit))]
- (cl-format true "~{~{~4d~}~%~}"
- (map #(map % nums)
- (map #(partial * %) nums)))))
diff --git a/src/clojure/contrib/pprint/examples/props.clj b/src/clojure/contrib/pprint/examples/props.clj
deleted file mode 100644
index 4edb9149..00000000
--- a/src/clojure/contrib/pprint/examples/props.clj
+++ /dev/null
@@ -1,25 +0,0 @@
-;;; props.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Dec 2008. 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 example displays a nicely formatted table of the java properties using
-;; cl-format
-
-(ns clojure.contrib.pprint.examples.props
- (:use clojure.contrib.pprint))
-
-(defn show-props [stream]
- (let [p (mapcat
- #(vector (key %) (val %))
- (sort-by key (System/getProperties)))]
- (cl-format true "~30A~A~%~{~20,,,'-A~10A~}~%~{~30A~S~%~}"
- "Property" "Value" ["" "" "" ""] p)))
diff --git a/src/clojure/contrib/pprint/examples/show_doc.clj b/src/clojure/contrib/pprint/examples/show_doc.clj
deleted file mode 100644
index 6bf61585..00000000
--- a/src/clojure/contrib/pprint/examples/show_doc.clj
+++ /dev/null
@@ -1,50 +0,0 @@
-;;; show_doc.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Dec 2008. 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 example uses cl-format as part of a routine to display all the doc
-;; strings and function arguments from one or more namespaces.
-
-(ns clojure.contrib.pprint.examples.show-doc
- (:use clojure.contrib.pprint))
-
-(defn ns-list
- ([] (ns-list nil))
- ([pattern]
- (filter
- (if pattern
- (comp (partial re-find pattern) name ns-name)
- (constantly true))
- (sort-by ns-name (all-ns)))))
-
-(defn show-doc
- ([] (show-doc nil))
- ([pattern]
- (cl-format
- true
- "~:{~A: ===============================================~
- ~%~{~{~a: ~{~a~^, ~}~%~a~%~}~^~%~}~2%~}"
- (map
- #(vector (ns-name %)
- (map
- (fn [f]
- (let [f-meta (meta (find-var (symbol (str (ns-name %)) (str f))))]
- [f (:arglists f-meta) (:doc f-meta)]))
- (filter
- (fn [a] (instance? clojure.lang.IFn a))
- (sort (map key (ns-publics %))))))
- (ns-list pattern)))))
-
-(defn create-api-file [pattern out-file]
- (with-open [f (java.io.FileWriter. out-file)]
- (binding [*out* f]
- (show-doc pattern))))
diff --git a/src/clojure/contrib/pprint/examples/xml.clj b/src/clojure/contrib/pprint/examples/xml.clj
deleted file mode 100644
index 3a2b9ae8..00000000
--- a/src/clojure/contrib/pprint/examples/xml.clj
+++ /dev/null
@@ -1,117 +0,0 @@
-;;; xml.clj -- a pretty print dispatch version of prxml.clj -- a compact syntax for generating XML
-
-;; by Tom Faulhaber, based on the original by Stuart Sierra, http://stuartsierra.com/
-;; May 13, 2009
-
-;; Copyright (c) 2009 Tom Faulhaber/Stuart Sierra. 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.
-
-
-;; See function "prxml" at the bottom of this file for documentation.
-
-
-(ns
- #^{:author "Tom Faulhaber, based on the original by Stuart Sierra",
- :doc "A version of prxml that uses a pretty print dispatch function."}
- clojure.contrib.pprint.examples.xml
- (:use [clojure.contrib.lazy-xml :only (escape-xml)]
- [clojure.contrib.java-utils :only (as-str)]
- [clojure.contrib.pprint :only (formatter-out write)]
- [clojure.contrib.pprint.utilities :only (prlabel)]))
-
-(def
- #^{:doc "If true, empty tags will have a space before the closing />"}
- *html-compatible* false)
-
-(def
- #^{:doc "The number of spaces to indent sub-tags."}
- *prxml-indent* 2)
-
-(defmulti #^{:private true} print-xml-tag (fn [tag attrs content] tag))
-
-(defmethod print-xml-tag :raw! [tag attrs contents]
- (doseq [c contents] (print c)))
-
-(defmethod print-xml-tag :comment! [tag attrs contents]
- (print "<!-- ")
- (doseq [c contents] (print c))
- (print " -->"))
-
-(defmethod print-xml-tag :decl! [tag attrs contents]
- (let [attrs (merge {:version "1.0" :encoding "UTF-8"}
- attrs)]
- ;; Must enforce ordering of pseudo-attributes:
- ((formatter-out "<?xml version=\"~a\" encoding=\"~a\"~@[ standalone=\"~a\"~]?>")
- (:version attrs) (:encoding attrs) (:standalone attrs))))
-
-(defmethod print-xml-tag :cdata! [tag attrs contents]
- ((formatter-out "<[!CDATA[~{~a~}]]>") contents))
-
-(defmethod print-xml-tag :doctype! [tag attrs contents]
- ((formatter-out "<[!DOCTYPE [~{~a~}]]>") contents))
-
-(defmethod print-xml-tag :default [tag attrs contents]
- (let [tag-name (as-str tag)
- xlated-attrs (map #(vector (as-str (key %)) (as-str (val %))) attrs)]
- (if (seq contents)
- ((formatter-out "~<~<<~a~1:i~{ ~:_~{~a=\"~a\"~}~}>~:>~vi~{~_~w~}~0i~_</~a>~:>")
- [[tag-name xlated-attrs] *prxml-indent* contents tag-name])
- ((formatter-out "~<<~a~1:i~{~:_ ~{~a=\"~a\"~}~}/>~:>") [tag-name xlated-attrs]))))
-
-
-(defmulti xml-dispatch class)
-
-(defmethod xml-dispatch clojure.lang.IPersistentVector [x]
- (let [[tag & contents] x
- [attrs content] (if (map? (first contents))
- [(first contents) (rest contents)]
- [{} contents])]
- (print-xml-tag tag attrs content)))
-
-(defmethod xml-dispatch clojure.lang.ISeq [x]
- ;; Recurse into sequences, so we can use (map ...) inside prxml.
- (doseq [c x] (xml-dispatch c)))
-
-(defmethod xml-dispatch clojure.lang.Keyword [x]
- (print-xml-tag x {} nil))
-
-(defmethod xml-dispatch String [x]
- (print (escape-xml x)))
-
-(defmethod xml-dispatch nil [x])
-
-(defmethod xml-dispatch :default [x]
- (print x))
-
-
-(defn prxml
- "Print XML to *out*. Vectors become XML tags: the first item is the
- tag name; optional second item is a map of attributes.
-
- Sequences are processed recursively, so you can use map and other
- sequence functions inside prxml.
-
- (prxml [:p {:class \"greet\"} [:i \"Ladies & gentlemen\"]])
- ; => <p class=\"greet\"><i>Ladies &amp; gentlemen</i></p>
-
- PSEUDO-TAGS: some keywords have special meaning:
-
- :raw! do not XML-escape contents
- :comment! create an XML comment
- :decl! create an XML declaration, with attributes
- :cdata! create a CDATA section
- :doctype! create a DOCTYPE!
-
- (prxml [:p [:raw! \"<i>here & gone</i>\"]])
- ; => <p><i>here & gone</i></p>
-
- (prxml [:decl! {:version \"1.1\"}])
- ; => <?xml version=\"1.1\" encoding=\"UTF-8\"?>"
- [& args]
- (doseq [arg args] (write arg :dispatch xml-dispatch))
- (when (pos? (count args)) (newline)))
diff --git a/src/clojure/contrib/pprint/pprint_base.clj b/src/clojure/contrib/pprint/pprint_base.clj
deleted file mode 100644
index 064fc5ec..00000000
--- a/src/clojure/contrib/pprint/pprint_base.clj
+++ /dev/null
@@ -1,342 +0,0 @@
-;;; pprint_base.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Jan 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 generic pretty print functions and special variables
-
-(in-ns 'clojure.contrib.pprint)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Variables that control the pretty printer
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;
-;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core
-;;; TODO: use *print-dup* here (or is it supplanted by other variables?)
-;;; TODO: make dispatch items like "(let..." get counted in *print-length*
-;;; constructs
-
-
-(def
- #^{ :doc "Bind to true if you want write to use pretty printing"}
- *print-pretty* true)
-
-(defonce ; If folks have added stuff here, don't overwrite
- #^{ :doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch
-to modify."}
- *print-pprint-dispatch* nil)
-
-(def
- #^{ :doc "Pretty printing will try to avoid anything going beyond this column.
-Set it to nil to have pprint let the line be arbitrarily long. This will ignore all
-non-mandatory newlines."}
- *print-right-margin* 72)
-
-(def
- #^{ :doc "The column at which to enter miser style. Depending on the dispatch table,
-miser style add newlines in more places to try to keep lines short allowing for further
-levels of nesting."}
- *print-miser-width* 40)
-
-;;; TODO implement output limiting
-(def
- #^{ :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"}
- *print-lines* nil)
-
-;;; TODO: implement circle and shared
-(def
- #^{ :doc "Mark circular structures (N.B. This is not yet used)"}
- *print-circle* nil)
-
-;;; TODO: should we just use *print-dup* here?
-(def
- #^{ :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"}
- *print-shared* nil)
-
-(def
- #^{ :doc "Don't print namespaces with symbols. This is particularly useful when
-pretty printing the results of macro expansions"}
- *print-suppress-namespaces* nil)
-
-;;; TODO: support print-base and print-radix in cl-format
-;;; TODO: support print-base and print-radix in rationals
-(def
- #^{ :doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8,
-or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the
-radix specifier is in the form #XXr where XX is the decimal value of *print-base* "}
- *print-radix* nil)
-
-(def
- #^{ :doc "The base to use for printing integers and rationals."}
- *print-base* 10)
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Internal variables that keep track of where we are in the
-;; structure
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(def #^{ :private true } *current-level* 0)
-
-(def #^{ :private true } *current-length* nil)
-
-;; TODO: add variables for length, lines.
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Support for the write function
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(declare format-simple-number)
-
-(def #^{:private true} orig-pr pr)
-
-(defn- pr-with-base [x]
- (if-let [s (format-simple-number x)]
- (print s)
- (orig-pr x)))
-
-(def #^{:private true} write-option-table
- {;:array *print-array*
- :base 'clojure.contrib.pprint/*print-base*,
- ;;:case *print-case*,
- :circle 'clojure.contrib.pprint/*print-circle*,
- ;;:escape *print-escape*,
- ;;:gensym *print-gensym*,
- :length 'clojure.core/*print-length*,
- :level 'clojure.core/*print-level*,
- :lines 'clojure.contrib.pprint/*print-lines*,
- :miser-width 'clojure.contrib.pprint/*print-miser-width*,
- :dispatch 'clojure.contrib.pprint/*print-pprint-dispatch*,
- :pretty 'clojure.contrib.pprint/*print-pretty*,
- :radix 'clojure.contrib.pprint/*print-radix*,
- :readably 'clojure.core/*print-readably*,
- :right-margin 'clojure.contrib.pprint/*print-right-margin*,
- :suppress-namespaces 'clojure.contrib.pprint/*print-suppress-namespaces*})
-
-
-(defmacro #^{:private true} binding-map [amap & body]
- (let []
- `(do
- (. clojure.lang.Var (pushThreadBindings ~amap))
- (try
- ~@body
- (finally
- (. clojure.lang.Var (popThreadBindings)))))))
-
-(defn- table-ize [t m]
- (apply hash-map (mapcat
- #(when-let [v (get t (key %))] [(find-var v) (val %)])
- m)))
-
-(defn- pretty-writer?
- "Return true iff x is a PrettyWriter"
- [x] (instance? PrettyWriter x))
-
-(defn- make-pretty-writer
- "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width"
- [base-writer right-margin miser-width]
- (PrettyWriter. base-writer right-margin miser-width))
-
-(defmacro #^{:private true} with-pretty-writer [base-writer & body]
- `(let [base-writer# ~base-writer
- new-writer# (not (pretty-writer? base-writer#))]
- (binding [*out* (if new-writer#
- (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*)
- base-writer#)]
- ~@body
- (.flush *out*))))
-
-
-;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc.
-(defn write-out
- "Write an object to *out* subject to the current bindings of the printer control
-variables. Use the kw-args argument to override individual variables for this call (and
-any recursive calls).
-
-*out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility
-of the caller.
-
-This method is primarily intended for use by pretty print dispatch functions that
-already know that the pretty printer will have set up their environment appropriately.
-Normal library clients should use the standard \"write\" interface. "
- [object]
- (let [length-reached (and
- *current-length*
- *print-length*
- (>= *current-length* *print-length*))]
- (if-not *print-pretty*
- (pr object)
- (if length-reached
- (print "...")
- (do
- (if *current-length* (set! *current-length* (inc *current-length*)))
- (*print-pprint-dispatch* object))))
- length-reached))
-
-(defn write
- "Write an object subject to the current bindings of the printer control variables.
-Use the kw-args argument to override individual variables for this call (and any
-recursive calls). Returns the string result if :stream is nil or nil otherwise.
-
-The following keyword arguments can be passed with values:
- Keyword Meaning Default value
- :stream Writer for output or nil true (indicates *out*)
- :base Base to use for writing rationals Current value of *print-base*
- :circle* If true, mark circular structures Current value of *print-circle*
- :length Maximum elements to show in sublists Current value of *print-length*
- :level Maximum depth Current value of *print-level*
- :lines* Maximum lines of output Current value of *print-lines*
- :miser-width Width to enter miser mode Current value of *print-miser-width*
- :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch*
- :pretty If true, do pretty printing Current value of *print-pretty*
- :radix If true, prepend a radix specifier Current value of *print-radix*
- :readably* If true, print readably Current value of *print-readably*
- :right-margin The column for the right margin Current value of *print-right-margin*
- :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces*
-
- * = not yet supported
-"
- [object & kw-args]
- (let [options (merge {:stream true} (apply hash-map kw-args))]
- (binding-map (table-ize write-option-table options)
- (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {})
- (let [optval (if (contains? options :stream)
- (:stream options)
- true)
- base-writer (condp = optval
- nil (java.io.StringWriter.)
- true *out*
- optval)]
- (if *print-pretty*
- (with-pretty-writer base-writer
- (write-out object))
- (binding [*out* base-writer]
- (pr object)))
- (if (nil? optval)
- (.toString #^java.io.StringWriter base-writer)))))))
-
-
-(defn pprint
- "Pretty print object to the optional output writer. If the writer is not provided,
-print the object to the currently bound value of *out*."
- ([object] (pprint object *out*))
- ([object writer]
- (with-pretty-writer writer
- (binding [*print-pretty* true]
- (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {})
- (write-out object)))
- (if (not (= 0 (.getColumn #^PrettyWriter *out*)))
- (.write *out* (int \newline))))))
-
-(defmacro pp
- "A convenience macro that pretty prints the last thing output. This is
-exactly equivalent to (pprint *1)."
- [] `(pprint *1))
-
-(defn set-pprint-dispatch
- "Set the pretty print dispatch function to a function matching (fn [obj] ...)
-where obj is the object to pretty print. That function will be called with *out* set
-to a pretty printing writer to which it should do its printing.
-
-For example functions, see *simple-dispatch* and *code-dispatch* in
-clojure.contrib.pprint.dispatch.clj."
- [function]
- (let [old-meta (meta #'*print-pprint-dispatch*)]
- (alter-var-root #'*print-pprint-dispatch* (constantly function))
- (alter-meta! #'*print-pprint-dispatch* (constantly old-meta)))
- nil)
-
-(defmacro with-pprint-dispatch
- "Execute body with the pretty print dispatch function bound to function."
- [function & body]
- `(binding [*print-pprint-dispatch* ~function]
- ~@body))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Support for the functional interface to the pretty printer
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn- parse-lb-options [opts body]
- (loop [body body
- acc []]
- (if (opts (first body))
- (recur (drop 2 body) (concat acc (take 2 body)))
- [(apply hash-map acc) body])))
-
-(defn- check-enumerated-arg [arg choices]
- (if-not (choices arg)
- (throw
- (IllegalArgumentException.
- ;; TODO clean up choices string
- (str "Bad argument: " arg ". It must be one of " choices)))))
-
-(defn level-exceeded []
- (and *print-level* (>= *current-level* *print-level*)))
-
-(defmacro pprint-logical-block
- "Execute the body as a pretty printing logical block with output to *out* which
-must be a pretty printing writer. When used from pprint or cl-format, this can be
-assumed.
-
-Before the body, the caller can optionally specify options: :prefix, :per-line-prefix,
-and :suffix."
- {:arglists '[[options* body]]}
- [& args]
- (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
- `(do (if (level-exceeded)
- (.write #^PrettyWriter *out* "#")
- (binding [*current-level* (inc *current-level*)
- *current-length* 0]
- (.startBlock #^PrettyWriter *out*
- ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))
- ~@body
- (.endBlock #^PrettyWriter *out*)))
- nil)))
-
-(defn pprint-newline
- "Print a conditional newline to a pretty printing stream. kind specifies if the
-newline is :linear, :miser, :fill, or :mandatory.
-
-Output is sent to *out* which must be a pretty printing writer."
- [kind]
- (check-enumerated-arg kind #{:linear :miser :fill :mandatory})
- (.newline #^PrettyWriter *out* kind))
-
-(defn pprint-indent
- "Create an indent at this point in the pretty printing stream. This defines how
-following lines are indented. relative-to can be either :block or :current depending
-whether the indent should be computed relative to the start of the logical block or
-the current column position. n is an offset.
-
-Output is sent to *out* which must be a pretty printing writer."
- [relative-to n]
- (check-enumerated-arg relative-to #{:block :current})
- (.indent #^PrettyWriter *out* relative-to n))
-
-;; TODO a real implementation for pprint-tab
-(defn pprint-tab
- "Tab at this point in the pretty printing stream. kind specifies whether the tab
-is :line, :section, :line-relative, or :section-relative.
-
-Colnum and colinc specify the target column and the increment to move the target
-forward if the output is already past the original target.
-
-Output is sent to *out* which must be a pretty printing writer.
-
-THIS FUNCTION IS NOT YET IMPLEMENTED."
- [kind colnum colinc]
- (check-enumerated-arg kind #{:line :section :line-relative :section-relative})
- (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))
-
-
-nil
diff --git a/src/clojure/contrib/pprint/utilities.clj b/src/clojure/contrib/pprint/utilities.clj
deleted file mode 100644
index 128c66e5..00000000
--- a/src/clojure/contrib/pprint/utilities.clj
+++ /dev/null
@@ -1,104 +0,0 @@
-;;; utilities.clj -- part of the pretty printer for Clojure
-
-;; by Tom Faulhaber
-;; April 3, 2009
-
-; Copyright (c) Tom Faulhaber, Jan 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 some utility function used in formatting and pretty
-;; printing. The functions here could go in a more general purpose library,
-;; perhaps.
-
-(ns clojure.contrib.pprint.utilities)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Helper functions for digesting formats in the various
-;;; phases of their lives.
-;;; These functions are actually pretty general.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn map-passing-context [func initial-context lis]
- (loop [context initial-context
- lis lis
- acc []]
- (if (empty? lis)
- [acc context]
- (let [this (first lis)
- remainder (next lis)
- [result new-context] (apply func [this context])]
- (recur new-context remainder (conj acc result))))))
-
-(defn consume [func initial-context]
- (loop [context initial-context
- acc []]
- (let [[result new-context] (apply func [context])]
- (if (not result)
- [acc new-context]
- (recur new-context (conj acc result))))))
-
-(defn consume-while [func initial-context]
- (loop [context initial-context
- acc []]
- (let [[result continue new-context] (apply func [context])]
- (if (not continue)
- [acc context]
- (recur new-context (conj acc result))))))
-
-(defn unzip-map [m]
- "Take a map that has pairs in the value slots and produce a pair of maps,
- the first having all the first elements of the pairs and the second all
- the second elements of the pairs"
- [(into {} (for [[k [v1 v2]] m] [k v1]))
- (into {} (for [[k [v1 v2]] m] [k v2]))])
-
-(defn tuple-map [m v1]
- "For all the values, v, in the map, replace them with [v v1]"
- (into {} (for [[k v] m] [k [v v1]])))
-
-(defn rtrim [s c]
- "Trim all instances of c from the end of sequence s"
- (let [len (count s)]
- (if (and (pos? len) (= (nth s (dec (count s))) c))
- (loop [n (dec len)]
- (cond
- (neg? n) ""
- (not (= (nth s n) c)) (subs s 0 (inc n))
- true (recur (dec n))))
- s)))
-
-(defn ltrim [s c]
- "Trim all instances of c from the beginning of sequence s"
- (let [len (count s)]
- (if (and (pos? len) (= (nth s 0) c))
- (loop [n 0]
- (if (or (= n len) (not (= (nth s n) c)))
- (subs s n)
- (recur (inc n))))
- s)))
-
-(defn prefix-count [aseq val]
- "Return the number of times that val occurs at the start of sequence aseq,
-if val is a seq itself, count the number of times any element of val occurs at the
-beginning of aseq"
- (let [test (if (coll? val) (set val) #{val})]
- (loop [pos 0]
- (if (or (= pos (count aseq)) (not (test (nth aseq pos))))
- pos
- (recur (inc pos))))))
-
-(defn prerr [& args]
- "Println to *err*"
- (binding [*out* *err*]
- (apply println args)))
-
-(defmacro prlabel [prefix arg & more-args]
- "Print args to *err* in name = value format"
- `(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %)
- (cons arg (seq more-args))))))
-
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-08-30 16:07:30 +0000