From 9a05c1c70a1070f5a631dfc81ed98d6c70b33a9d Mon Sep 17 00:00:00 2001 From: Ben Smith-Mannschott Date: Sat, 28 Aug 2010 18:17:22 +0200 Subject: [PATCH] removed deprecated clojure.contrib.pprint Signed-off-by: Stuart Sierra --- modules/complete/pom.xml | 5 - modules/json/pom.xml | 5 - .../src/main/clojure/clojure/contrib/json.clj | 2 +- modules/pprint/pom.xml | 14 - .../main/clojure/clojure/contrib/pprint.clj | 43 - .../clojure/contrib/pprint/cl_format.clj | 1844 ----------------- .../clojure/contrib/pprint/column_writer.clj | 80 - .../clojure/contrib/pprint/dispatch.clj | 447 ---- .../clojure/contrib/pprint/pprint_base.clj | 342 --- .../clojure/contrib/pprint/pretty_writer.clj | 488 ----- .../clojure/contrib/pprint/utilities.clj | 104 - .../clojure/contrib/pprint/test_cl_format.clj | 691 ------ .../clojure/contrib/pprint/test_helper.clj | 21 - .../clojure/contrib/pprint/test_pretty.clj | 127 -- pom.xml | 1 - 15 files changed, 1 insertion(+), 4213 deletions(-) delete mode 100644 modules/pprint/pom.xml delete mode 100644 modules/pprint/src/main/clojure/clojure/contrib/pprint.clj delete mode 100644 modules/pprint/src/main/clojure/clojure/contrib/pprint/cl_format.clj delete mode 100644 modules/pprint/src/main/clojure/clojure/contrib/pprint/column_writer.clj delete mode 100644 modules/pprint/src/main/clojure/clojure/contrib/pprint/dispatch.clj delete mode 100644 modules/pprint/src/main/clojure/clojure/contrib/pprint/pprint_base.clj delete mode 100644 modules/pprint/src/main/clojure/clojure/contrib/pprint/pretty_writer.clj delete mode 100644 modules/pprint/src/main/clojure/clojure/contrib/pprint/utilities.clj delete mode 100644 modules/pprint/src/test/clojure/clojure/contrib/pprint/test_cl_format.clj delete mode 100644 modules/pprint/src/test/clojure/clojure/contrib/pprint/test_helper.clj delete mode 100644 modules/pprint/src/test/clojure/clojure/contrib/pprint/test_pretty.clj diff --git a/modules/complete/pom.xml b/modules/complete/pom.xml index 09d3247a8a..0fdbea7d9c 100644 --- a/modules/complete/pom.xml +++ b/modules/complete/pom.xml @@ -230,11 +230,6 @@ ns-utils 1.3.0-SNAPSHOT - - org.clojure.contrib - pprint - 1.3.0-SNAPSHOT - org.clojure.contrib priority-map diff --git a/modules/json/pom.xml b/modules/json/pom.xml index 5cf987c46b..445723e7b1 100644 --- a/modules/json/pom.xml +++ b/modules/json/pom.xml @@ -12,10 +12,5 @@ json - - org.clojure.contrib - pprint - 1.3.0-SNAPSHOT - \ No newline at end of file diff --git a/modules/json/src/main/clojure/clojure/contrib/json.clj b/modules/json/src/main/clojure/clojure/contrib/json.clj index 457f33c942..f8008f7ef2 100644 --- a/modules/json/src/main/clojure/clojure/contrib/json.clj +++ b/modules/json/src/main/clojure/clojure/contrib/json.clj @@ -17,7 +17,7 @@ To write JSON, use json-str, write-json, or write-json. To read JSON, use read-json."} clojure.contrib.json - (:use [clojure.contrib.pprint :only (write formatter-out)]) + (:use [clojure.pprint :only (write formatter-out)]) (:import (java.io PrintWriter PushbackReader StringWriter StringReader Reader EOFException))) diff --git a/modules/pprint/pom.xml b/modules/pprint/pom.xml deleted file mode 100644 index fd5e75269b..0000000000 --- a/modules/pprint/pom.xml +++ /dev/null @@ -1,14 +0,0 @@ - - - 4.0.0 - - org.clojure.contrib - parent - 1.3.0-SNAPSHOT - ../parent - - pprint - \ No newline at end of file diff --git a/modules/pprint/src/main/clojure/clojure/contrib/pprint.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint.clj deleted file mode 100644 index 27c1be7345..0000000000 --- a/modules/pprint/src/main/clojure/clojure/contrib/pprint.clj +++ /dev/null @@ -1,43 +0,0 @@ -;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) for Clojure - -;; by Tom Faulhaber -;; April 3, 2009 - -;; Copyright (c) Tom Faulhaber, April 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. - -;; DEPRECATED in 1.2. Promoted to clojure.pprint - -(ns - ^{:author "Tom Faulhaber", - :deprecated "1.2" - :doc "This module comprises two elements: -1) A pretty printer for Clojure data structures, implemented in the - function \"pprint\" -2) A Common Lisp compatible format function, implemented as - \"cl-format\" because Clojure is using the name \"format\" - for its Java-based format function. - -See documentation for those functions for more information or complete -documentation on the the clojure-contrib web site on github. - -As of the 1.2 release, pprint has been moved to clojure.pprint. Please prefer -the clojure.pprint version for new code.", - } - clojure.contrib.pprint - (:use clojure.contrib.pprint.utilities) - (:use clojure.contrib.pprint.pretty-writer - clojure.contrib.pprint.column-writer)) - - -(load "pprint/pprint_base") -(load "pprint/cl_format") -(load "pprint/dispatch") - -nil diff --git a/modules/pprint/src/main/clojure/clojure/contrib/pprint/cl_format.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/cl_format.clj deleted file mode 100644 index 85f29b1306..0000000000 --- a/modules/pprint/src/main/clojure/clojure/contrib/pprint/cl_format.clj +++ /dev/null @@ -1,1844 +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) (-> val class .getName (.startsWith "java."))) - (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) - [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg]) - [mantissa exp] (float-parts abs) - scaled-exp (+ exp (:k params)) - add-sign (or (:at params) (neg? arg)) - append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp)) - [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp - d (if w (- w (if add-sign 1 0)))) - fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) - prepend-zero (= (first fixed-repr) \.)] - (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 sign) - (if prepend-zero "0") - fixed-repr - (if append-zero "0"))))) - (print (str - (if add-sign 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 expanded] (round-str mantissa exp d nil) - ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) 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 (num -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 (num -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)) - (get-max-column *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 (> (+ (get-column (:base @@*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 get-pretty-writer [writer] - (if (pretty-writer? writer) - writer - (pretty-writer 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 (get-column (:base @@*out*)))) - (prn))) - -(defn- absolute-tabulation [params navigator offsets] - (let [colnum (:colnum params) - colinc (:colinc params) - current (get-column (:base @@*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 (get-column (:base @@*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 (pretty-writer? real-stream))) - (get-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/modules/pprint/src/main/clojure/clojure/contrib/pprint/column_writer.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/column_writer.clj deleted file mode 100644 index 32e6293195..0000000000 --- a/modules/pprint/src/main/clojure/clojure/contrib/pprint/column_writer.clj +++ /dev/null @@ -1,80 +0,0 @@ -;;; column_writer.clj -- part of the pretty printer for Clojure - -;; by Tom Faulhaber -;; April 3, 2009 -;; Revised to use proxy instead of gen-class April 2010 - -; 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.column-writer - (:import - [clojure.lang IDeref] - [java.io Writer])) - -(def *default-page-width* 72) - -(defn- get-field [^Writer this sym] - (sym @@this)) - -(defn- set-field [^Writer this sym new-val] - (alter @this assoc sym new-val)) - -(defn get-column [this] - (get-field this :cur)) - -(defn get-line [this] - (get-field this :line)) - -(defn get-max-column [this] - (get-field this :max)) - -(defn set-max-column [this new-max] - (dosync (set-field this :max new-max)) - nil) - -(defn get-writer [this] - (get-field this :base)) - -(defn- write-char [^Writer 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 ^Writer (get-field this :base) c)) - -(defn column-writer - ([writer] (column-writer writer *default-page-width*)) - ([writer max-columns] - (let [fields (ref {:max max-columns, :cur 0, :line 0 :base writer})] - (proxy [Writer IDeref] [] - (deref [] fields) - (write - ([^chars cbuf ^Integer off ^Integer len] - (let [^Writer writer (get-field this :base)] - (.write writer cbuf off len))) - ([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 ^Writer (get-field this :base) s)) - - Integer - (write-char this x) - Long - (write-char this x)))))))) diff --git a/modules/pprint/src/main/clojure/clojure/contrib/pprint/dispatch.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/dispatch.clj deleted file mode 100644 index 2d7429649b..0000000000 --- a/modules/pprint/src/main/clojure/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 "#" - (write-out @ref))) -(defn pprint-atom [ref] - (pprint-logical-block :prefix "#" - (write-out @ref))) -(defn pprint-agent [ref] - (pprint-logical-block :prefix "#" - (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/modules/pprint/src/main/clojure/clojure/contrib/pprint/pprint_base.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/pprint_base.clj deleted file mode 100644 index 05d05390f7..0000000000 --- a/modules/pprint/src/main/clojure/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] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@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] - (pretty-writer 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 (get-column *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 ^java.io.Writer *out* "#") - (binding [*current-level* (inc *current-level*) - *current-length* 0] - (start-block *out* - ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options)) - ~@body - (end-block *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}) - (nl *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 *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/modules/pprint/src/main/clojure/clojure/contrib/pprint/pretty_writer.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/pretty_writer.clj deleted file mode 100644 index dfea976a89..0000000000 --- a/modules/pprint/src/main/clojure/clojure/contrib/pprint/pretty_writer.clj +++ /dev/null @@ -1,488 +0,0 @@ -;;; pretty_writer.clj -- part of the pretty printer for Clojure - -;; by Tom Faulhaber -;; April 3, 2009 -;; Revised to use proxy instead of gen-class April 2010 - -; 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.pretty-writer - (:refer-clojure :exclude (deftype)) - (:use clojure.contrib.pprint.utilities) - (:use [clojure.contrib.pprint.column-writer - :only (column-writer get-column get-max-column)]) - (:import - [clojure.lang IDeref] - [java.io Writer])) - -;; TODO: Support for tab directives - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Forward declarations -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare get-miser-width) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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 @@~'this)) - -(defmacro ^{:private true} - setf [sym new-val] - "Set the value of the field SYM to NEW-VAL" - `(alter @~'this assoc ~sym ~new-val)) - -(defmacro ^{:private true} - 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 pretty-writer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(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-t :type :logical-block :start-pos :end-pos) - -(deftype start-block-t :logical-block :start-pos :end-pos) - -(deftype end-block-t :logical-block :start-pos :end-pos) - -(deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Functions to write tokens in the output buffer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare emit-nl) - -(defmulti write-token #(:type-tag %2)) -(defmethod write-token :start-block-t [^Writer this token] - (when-let [cb (getf :logical-block-callback)] (cb :start)) - (let [lb (:logical-block token)] - (dosync - (when-let [^String prefix (:prefix lb)] - (.write (getf :base) prefix)) - (let [col (get-column (getf :base))] - (ref-set (:start-col lb) col) - (ref-set (:indent lb) col))))) - -(defmethod write-token :end-block-t [^Writer this token] - (when-let [cb (getf :logical-block-callback)] (cb :end)) - (when-let [^String suffix (:suffix (:logical-block token))] - (.write (getf :base) suffix))) - -(defmethod write-token :indent-t [^Writer this token] - (let [lb (:logical-block token)] - (ref-set (:indent lb) - (+ (:offset token) - (condp = (:relative-to token) - :block @(:start-col lb) - :current (get-column (getf :base))))))) - -(defmethod write-token :buffer-blob [^Writer this token] - (.write (getf :base) ^String (:data token))) - -(defmethod write-token :nl-t [^Writer 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)] - (.write (getf :base) tws))) - (dosync (setf :trailing-white-space nil))) - -(defn- write-tokens [^Writer this tokens force-trailing-whitespace] - (doseq [token tokens] - (if-not (= (:type-tag token) :nl-t) - (if-let [^String tws (getf :trailing-white-space)] - (.write (getf :base) 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) - (.write (getf :base) 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? [^Writer this tokens] -;;; (prlabel tf? (get-column (getf :base) (buffer-length tokens)) - (let [maxcol (get-max-column (getf :base))] - (or - (nil? maxcol) - (< (+ (get-column (getf :base)) (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? [^Writer this lb section] - (let [miser-width (get-miser-width this) - maxcol (get-max-column (getf :base))] - (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-t? %) (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-t? %) (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 [^Writer this nl] - (.write (getf :base) (int \newline)) - (dosync (setf :trailing-white-space nil)) - (let [lb (:logical-block nl) - ^String prefix (:per-line-prefix lb)] - (if prefix - (.write (getf :base) prefix)) - (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix)) - \space))] - (.write (getf :base) istr)) - (update-nl-state lb))) - -(defn- split-at-newline [tokens] - (let [pre (seq (take-while #(not (nl-t? %)) tokens))] - [pre (seq (drop (count pre) tokens))])) - -;;; Methods for showing token strings for debugging - -(defmulti tok :type-tag) -(defmethod tok :nl-t [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 [^Writer 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 [^Writer 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 [^Writer 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 - [^Writer 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)) - (.write (getf :base) l)) - (.write (getf :base) (int \newline)) - (doseq [^String l (next (butlast lines))] - (.write (getf :base) l) - (.write (getf :base) (int \newline)) - (if prefix - (.write (getf :base) prefix))) - (setf :buffering :writing) - (last lines)))))) - - -(defn write-white-space [^Writer this] - (if-let [^String tws (getf :trailing-white-space)] - (dosync - (.write (getf :base) tws) - (setf :trailing-white-space nil)))) - -(defn- write-char [^Writer this ^Integer c] - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (.write (getf :base) 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))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Initialize the pretty-writer instance -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defn pretty-writer [writer max-columns miser-width] - (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false)) - fields (ref {:pretty-writer true - :base (column-writer writer max-columns) - :logical-blocks lb - :sections nil - :mode :writing - :buffer [] - :buffer-block lb - :buffer-level 1 - :miser-width miser-width - :trailing-white-space nil - :pos 0})] - (proxy [Writer IDeref] [] - (deref [] fields) - - (write - ([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) - (.write (getf :base) 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) - Long - (write-char this x)))) - - (flush [] - (if (= (getf :mode) :buffering) - (dosync - (write-tokens this (getf :buffer) true) - (setf :buffer [])) - (write-white-space this))) - - (close [] - (.flush this))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Methods for pretty-writer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn start-block - [^Writer 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 - (.write (getf :base) prefix)) - (let [col (get-column (getf :base))] - (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-t lb oldpos newpos))))))) - -(defn end-block [^Writer this] - (dosync - (let [lb (getf :logical-blocks) - ^String suffix (:suffix lb)] - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (if suffix - (.write (getf :base) 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-t lb oldpos newpos)))) - (setf :logical-blocks (:parent lb))))) - -(defn nl [^Writer this type] - (dosync - (setf :mode :buffering) - (let [pos (getf :pos)] - (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos))))) - -(defn indent [^Writer 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 (get-column (getf :base)))))) - (let [pos (getf :pos)] - (add-to-buffer this (make-indent-t lb relative-to offset pos pos))))))) - -(defn get-miser-width [^Writer this] - (getf :miser-width)) - -(defn set-miser-width [^Writer this new-miser-width] - (dosync (setf :miser-width new-miser-width))) - -(defn set-logical-block-callback [^Writer this f] - (dosync (setf :logical-block-callback f))) diff --git a/modules/pprint/src/main/clojure/clojure/contrib/pprint/utilities.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/utilities.clj deleted file mode 100644 index 128c66e522..0000000000 --- a/modules/pprint/src/main/clojure/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)))))) - diff --git a/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_cl_format.clj b/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_cl_format.clj deleted file mode 100644 index 4022e5e358..0000000000 --- a/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_cl_format.clj +++ /dev/null @@ -1,691 +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 test set tests the basic cl-format functionality - -(ns clojure.contrib.pprint.test-cl-format - (:refer-clojure :exclude [format]) - (:use [clojure.test :only (deftest are run-tests)] - clojure.contrib.pprint.test-helper - clojure.contrib.pprint)) - -(def format cl-format) - -;; TODO tests for ~A, ~D, etc. -;; TODO add tests for ~F, etc.: 0.0, 9.9999 with rounding, 9.9999E99 with rounding - -(simple-tests d-tests - (cl-format nil "~D" 0) "0" - (cl-format nil "~D" 2e6) "2000000" - (cl-format nil "~D" 2000000) "2000000" - (cl-format nil "~:D" 2000000) "2,000,000" - (cl-format nil "~D" 1/2) "1/2" - (cl-format nil "~D" 'fred) "fred" -) - -(simple-tests base-tests - (cl-format nil "~{~2r~^ ~}~%" (range 10)) - "0 1 10 11 100 101 110 111 1000 1001\n" - (with-out-str - (dotimes [i 35] - (binding [*print-base* (+ i 2)] ;print the decimal number 40 - (write 40) ;in each base from 2 to 36 - (if (zero? (mod i 10)) (prn) (cl-format true " "))))) - "101000 -1111 220 130 104 55 50 44 40 37 34 -31 2c 2a 28 26 24 22 20 1j 1i -1h 1g 1f 1e 1d 1c 1b 1a 19 18 -17 16 15 14 " - (with-out-str - (doseq [pb [2 3 8 10 16]] - (binding [*print-radix* true ;print the integer 10 and - *print-base* pb] ;the ratio 1/10 in bases 2, - (cl-format true "~&~S ~S~%" 10 1/10)))) ;3, 8, 10, 16 - "#b1010 #b1/1010 -#3r101 #3r1/101 -#o12 #o1/12 -10. #10r1/10 -#xa #x1/a -") - - - -(simple-tests cardinal-tests - (cl-format nil "~R" 0) "zero" - (cl-format nil "~R" 4) "four" - (cl-format nil "~R" 15) "fifteen" - (cl-format nil "~R" -15) "minus fifteen" - (cl-format nil "~R" 25) "twenty-five" - (cl-format nil "~R" 20) "twenty" - (cl-format nil "~R" 200) "two hundred" - (cl-format nil "~R" 203) "two hundred three" - - (cl-format nil "~R" 44879032) - "forty-four million, eight hundred seventy-nine thousand, thirty-two" - - (cl-format nil "~R" -44879032) - "minus forty-four million, eight hundred seventy-nine thousand, thirty-two" - - (cl-format nil "~R = ~:*~:D" 44000032) - "forty-four million, thirty-two = 44,000,032" - - (cl-format nil "~R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094) - "four hundred forty-eight septendecillion, seven hundred ninety sexdecillion, three hundred twenty-nine quindecillion, four hundred eighty quattuordecillion, nine hundred forty-eight tredecillion, two hundred nine duodecillion, three hundred eighty-four undecillion, three hundred eighty-nine decillion, four hundred twenty-nine nonillion, three hundred eighty-four octillion, twenty-nine septillion, three hundred eighty-four sextillion, twenty-nine quintillion, eight hundred forty-two quadrillion, ninety-eight trillion, four hundred twenty billion, nine hundred eighty-nine million, eight hundred forty-two thousand, ninety-four = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094" - - (cl-format nil "~R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593475) - "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475 = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475" - - (cl-format nil "~R = ~:*~:D" 2e6) - "two million = 2,000,000" - - (cl-format nil "~R = ~:*~:D" 200000200000) - "two hundred billion, two hundred thousand = 200,000,200,000") - -(simple-tests ordinal-tests - (cl-format nil "~:R" 0) "zeroth" - (cl-format nil "~:R" 4) "fourth" - (cl-format nil "~:R" 15) "fifteenth" - (cl-format nil "~:R" -15) "minus fifteenth" - (cl-format nil "~:R" 25) "twenty-fifth" - (cl-format nil "~:R" 20) "twentieth" - (cl-format nil "~:R" 200) "two hundredth" - (cl-format nil "~:R" 203) "two hundred third" - - (cl-format nil "~:R" 44879032) - "forty-four million, eight hundred seventy-nine thousand, thirty-second" - - (cl-format nil "~:R" -44879032) - "minus forty-four million, eight hundred seventy-nine thousand, thirty-second" - - (cl-format nil "~:R = ~:*~:D" 44000032) - "forty-four million, thirty-second = 44,000,032" - - (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094) - "four hundred forty-eight septendecillion, seven hundred ninety sexdecillion, three hundred twenty-nine quindecillion, four hundred eighty quattuordecillion, nine hundred forty-eight tredecillion, two hundred nine duodecillion, three hundred eighty-four undecillion, three hundred eighty-nine decillion, four hundred twenty-nine nonillion, three hundred eighty-four octillion, twenty-nine septillion, three hundred eighty-four sextillion, twenty-nine quintillion, eight hundred forty-two quadrillion, ninety-eight trillion, four hundred twenty billion, nine hundred eighty-nine million, eight hundred forty-two thousand, ninety-fourth = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094" - (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593475) - "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475th = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475" - (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593471) - "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,471st = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,471" - (cl-format nil "~:R = ~:*~:D" 2e6) - "two millionth = 2,000,000") - -(simple-tests ordinal1-tests - (cl-format nil "~:R" 1) "first" - (cl-format nil "~:R" 11) "eleventh" - (cl-format nil "~:R" 21) "twenty-first" - (cl-format nil "~:R" 20) "twentieth" - (cl-format nil "~:R" 220) "two hundred twentieth" - (cl-format nil "~:R" 200) "two hundredth" - (cl-format nil "~:R" 999) "nine hundred ninety-ninth" - ) - -(simple-tests roman-tests - (cl-format nil "~@R" 3) "III" - (cl-format nil "~@R" 4) "IV" - (cl-format nil "~@R" 9) "IX" - (cl-format nil "~@R" 29) "XXIX" - (cl-format nil "~@R" 429) "CDXXIX" - (cl-format nil "~@:R" 429) "CCCCXXVIIII" - (cl-format nil "~@:R" 3429) "MMMCCCCXXVIIII" - (cl-format nil "~@R" 3429) "MMMCDXXIX" - (cl-format nil "~@R" 3479) "MMMCDLXXIX" - (cl-format nil "~@R" 3409) "MMMCDIX" - (cl-format nil "~@R" 300) "CCC" - (cl-format nil "~@R ~D" 300 20) "CCC 20" - (cl-format nil "~@R" 5000) "5,000" - (cl-format nil "~@R ~D" 5000 20) "5,000 20" - (cl-format nil "~@R" "the quick") "the quick") - -(simple-tests c-tests - (cl-format nil "~{~c~^, ~}~%" "hello") "h, e, l, l, o\n" - (cl-format nil "~{~:c~^, ~}~%" "hello") "h, e, l, l, o\n" - (cl-format nil "~@C~%" \m) "\\m\n" - (cl-format nil "~@C~%" (char 222)) "\\Þ\n" - (cl-format nil "~@C~%" (char 8)) "\\backspace\n" - (cl-format nil "~@C~%" (char 3)) "\\\n") - -(simple-tests e-tests - (cl-format nil "*~E*" 0.0) "*0.0E+0*" - (cl-format nil "*~6E*" 0.0) "*0.0E+0*" - (cl-format nil "*~6,0E*" 0.0) "* 0.E+0*" - (cl-format nil "*~7,2E*" 0.0) "*0.00E+0*" - (cl-format nil "*~5E*" 0.0) "*0.E+0*" - (cl-format nil "*~10,2,2,,'?E*" 2.8E120) "*??????????*" - (cl-format nil "*~10,2E*" 9.99999) "* 1.00E+1*" - (cl-format nil "*~10,2E*" 9.99999E99) "* 1.00E+100*" - (cl-format nil "*~10,2,2E*" 9.99999E99) "* 1.00E+100*" - (cl-format nil "*~10,2,2,,'?E*" 9.99999E99) "*??????????*" - ) - -(simple-tests $-tests - (cl-format nil "~$" 22.3) "22.30" - (cl-format nil "~$" 22.375) "22.38" - (cl-format nil "~3,5$" 22.375) "00022.375" - (cl-format nil "~3,5,8$" 22.375) "00022.375" - (cl-format nil "~3,5,10$" 22.375) " 00022.375" - (cl-format nil "~3,5,14@$" 22.375) " +00022.375" - (cl-format nil "~3,5,14@$" 22.375) " +00022.375" - (cl-format nil "~3,5,14@:$" 22.375) "+ 00022.375" - (cl-format nil "~3,,14@:$" 0.375) "+ 0.375" - (cl-format nil "~1,1$" -12.0) "-12.0" - (cl-format nil "~1,1$" 12.0) "12.0" - (cl-format nil "~1,1$" 12.0) "12.0" - (cl-format nil "~1,1@$" 12.0) "+12.0" - (cl-format nil "~1,1,8,' @:$" 12.0) "+ 12.0" - (cl-format nil "~1,1,8,' @$" 12.0) " +12.0" - (cl-format nil "~1,1,8,' :$" 12.0) " 12.0" - (cl-format nil "~1,1,8,' $" 12.0) " 12.0" - (cl-format nil "~1,1,8,' @:$" -12.0) "- 12.0" - (cl-format nil "~1,1,8,' @$" -12.0) " -12.0" - (cl-format nil "~1,1,8,' :$" -12.0) "- 12.0" - (cl-format nil "~1,1,8,' $" -12.0) " -12.0" - (cl-format nil "~1,1$" 0.001) "0.0" - (cl-format nil "~2,1$" 0.001) "0.00" - (cl-format nil "~1,1,6$" 0.001) " 0.0" - (cl-format nil "~1,1,6$" 0.0015) " 0.0" - (cl-format nil "~2,1,6$" 0.005) " 0.01" - (cl-format nil "~2,1,6$" 0.01) " 0.01" - (cl-format nil "~$" 0.099) "0.10" - (cl-format nil "~1$" 0.099) "0.1" - (cl-format nil "~1$" 0.1) "0.1" - (cl-format nil "~1$" 0.99) "1.0" - (cl-format nil "~1$" -0.99) "-1.0") - -(simple-tests f-tests - (cl-format nil "~,1f" -12.0) "-12.0" - (cl-format nil "~,0f" 9.4) "9." - (cl-format nil "~,0f" 9.5) "10." - (cl-format nil "~,0f" -0.99) "-1." - (cl-format nil "~,1f" -0.99) "-1.0" - (cl-format nil "~,2f" -0.99) "-0.99" - (cl-format nil "~,3f" -0.99) "-0.990" - (cl-format nil "~,0f" 0.99) "1." - (cl-format nil "~,1f" 0.99) "1.0" - (cl-format nil "~,2f" 0.99) "0.99" - (cl-format nil "~,3f" 0.99) "0.990" - (cl-format nil "~f" -1) "-1.0" - (cl-format nil "~2f" -1) "-1." - (cl-format nil "~3f" -1) "-1." - (cl-format nil "~4f" -1) "-1.0" - (cl-format nil "~8f" -1) " -1.0" - (cl-format nil "~1,1f" 0.1) ".1") - -(simple-tests ampersand-tests - (cl-format nil "The quick brown ~a jumped over ~d lazy dogs" 'elephant 5) - "The quick brown elephant jumped over 5 lazy dogs" - (cl-format nil "The quick brown ~&~a jumped over ~d lazy dogs" 'elephant 5) - "The quick brown \nelephant jumped over 5 lazy dogs" - (cl-format nil "The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) - "The quick brown \nelephant jumped\n over 5 lazy dogs" - (cl-format nil "~&The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) - "The quick brown \nelephant jumped\n over 5 lazy dogs" - (cl-format nil "~3&The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) - "\n\nThe quick brown \nelephant jumped\n over 5 lazy dogs" - (cl-format nil "~@{~&The quick brown ~a jumped over ~d lazy dogs~}" 'elephant 5 'fox 10) - "The quick brown elephant jumped over 5 lazy dogs\nThe quick brown fox jumped over 10 lazy dogs" - (cl-format nil "I ~[don't ~:;d~&o ~]have one~%" 0) "I don't have one\n" - (cl-format nil "I ~[don't ~:;d~&o ~]have one~%" 1) "I d\no have one\n") - -(simple-tests t-tests - (cl-format nil "~@{~&~A~8,4T~:*~A~}" - 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) - "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" - (cl-format nil "~@{~&~A~,4T~:*~A~}" - 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) - "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" - (cl-format nil "~@{~&~A~2,6@T~:*~A~}" 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) - "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" -) - -(simple-tests paren-tests - (cl-format nil "~(PLEASE SPEAK QUIETLY IN HERE~)") "please speak quietly in here" - (cl-format nil "~@(PLEASE SPEAK QUIETLY IN HERE~)") "Please speak quietly in here" - (cl-format nil "~@:(but this Is imporTant~)") "BUT THIS IS IMPORTANT" - (cl-format nil "~:(the greAt gatsby~)!") "The Great Gatsby!" - ;; Test cases from CLtL 18.3 - string-upcase, et al. - (cl-format nil "~@:(~A~)" "Dr. Livingstone, I presume?") "DR. LIVINGSTONE, I PRESUME?" - (cl-format nil "~(~A~)" "Dr. Livingstone, I presume?") "dr. livingstone, i presume?" - (cl-format nil "~:(~A~)" " hello ") " Hello " - (cl-format nil "~:(~A~)" "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") - "Occluded Casements Forestall Inadvertent Defenestration" - (cl-format nil "~:(~A~)" 'kludgy-hash-search) "Kludgy-Hash-Search" - (cl-format nil "~:(~A~)" "DON'T!") "Don'T!" ;not "Don't!" - (cl-format nil "~:(~A~)" "pipe 13a, foo16c") "Pipe 13a, Foo16c" -) - -(simple-tests square-bracket-tests - ;; Tests for format without modifiers - (cl-format nil "I ~[don't ~]have one~%" 0) "I don't have one\n" - (cl-format nil "I ~[don't ~]have one~%" 1) "I have one\n" - (cl-format nil "I ~[don't ~;do ~]have one~%" 0) "I don't have one\n" - (cl-format nil "I ~[don't ~;do ~]have one~%" 1) "I do have one\n" - (cl-format nil "I ~[don't ~;do ~]have one~%" 2) "I have one\n" - (cl-format nil "I ~[don't ~:;do ~]have one~%" 0) "I don't have one\n" - (cl-format nil "I ~[don't ~:;do ~]have one~%" 1) "I do have one\n" - (cl-format nil "I ~[don't ~:;do ~]have one~%" 2) "I do have one\n" - (cl-format nil "I ~[don't ~:;do ~]have one~%" 700) "I do have one\n" - - ;; Tests for format with a colon - (cl-format nil "I ~:[don't ~;do ~]have one~%" true) "I do have one\n" - (cl-format nil "I ~:[don't ~;do ~]have one~%" 700) "I do have one\n" - (cl-format nil "I ~:[don't ~;do ~]have one~%" '(a b)) "I do have one\n" - (cl-format nil "I ~:[don't ~;do ~]have one~%" nil) "I don't have one\n" - (cl-format nil "I ~:[don't ~;do ~]have one~%" false) "I don't have one\n" - - ;; Tests for format with an at sign - (cl-format nil "We had ~D wins~@[ (out of ~D tries)~].~%" 15 nil) "We had 15 wins.\n" - (cl-format nil "We had ~D wins~@[ (out of ~D tries)~].~%" 15 17) - "We had 15 wins (out of 17 tries).\n" - - ;; Format tests with directives - (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, 0, 7) - "Max 15: Blue team 7.\n" - (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, 1, 12) - "Max 15: Red team 12.\n" - (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" - 15, -1, "(system failure)") - "Max 15: No team (system failure).\n" - - ;; Nested format tests - (cl-format nil "Max ~D: ~[Blue team ~D~:[~; (complete success)~]~;Red team ~D~:;No team ~].~%" - 15, 0, 7, true) - "Max 15: Blue team 7 (complete success).\n" - (cl-format nil "Max ~D: ~[Blue team ~D~:[~; (complete success)~]~;Red team ~D~:;No team ~].~%" - 15, 0, 7, false) - "Max 15: Blue team 7.\n" - - ;; Test the selector as part of the argument - (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~].") - "The answer is nothing." - (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 4) - "The answer is 4." - (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 7 22) - "The answer is 7 out of 22." - (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 1 2 3 4) - "The answer is something crazy." -) - -(simple-tests curly-brace-plain-tests - ;; Iteration from sublist - (cl-format nil "Coordinates are~{ [~D,~D]~}~%" [ 0, 1, 1, 0, 3, 5, 2, 1 ]) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~2{ [~D,~D]~}~%" [ 0, 1, 1, 0, 3, 5, 2, 1 ]) - "Coordinates are [0,1] [1,0]\n" - - (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ]) - "Coordinates are\n" - - (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ]) - "Coordinates are none\n" - - (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3 1]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~{~:}~%" "" []) - "Coordinates are\n" - - (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3 1]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ]) - "Coordinates are none\n" -) - - -(simple-tests curly-brace-colon-tests - ;; Iteration from list of sublists - (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ]) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ]) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~2:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ]) - "Coordinates are [0,1] [1,0]\n" - - (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ]) - "Coordinates are\n" - - (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ]) - "Coordinates are none\n" - - (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [[2 3] [1]]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~:{~:}~%" "" []) - "Coordinates are\n" - - (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [[2 3] [1]]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ]) - "Coordinates are none\n" -) - -(simple-tests curly-brace-at-tests - ;; Iteration from main list - (cl-format nil "Coordinates are~@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~2@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1) - "Coordinates are [0,1] [1,0]\n" - - (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~}~%") - "Coordinates are\n" - - (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%") - "Coordinates are none\n" - - (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" 2 3 1) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~@{~:}~%" "") - "Coordinates are\n" - - (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" 2 3 1) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]") - "Coordinates are none\n" -) - -(simple-tests curly-brace-colon-at-tests - ;; Iteration from sublists on the main arg list - (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1] ) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~2@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1]) - "Coordinates are [0,1] [1,0]\n" - - (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%") - "Coordinates are\n" - - (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%") - "Coordinates are none\n" - - (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3] [1]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~@:{~:}~%" "") - "Coordinates are\n" - - (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3] [1]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]") - "Coordinates are none\n" -) - -;; TODO tests for ~^ in ~[ constructs and other brackets -;; TODO test ~:^ generates an error when used improperly -;; TODO test ~:^ works in ~@:{...~} -(let [aseq '(a quick brown fox jumped over the lazy dog) - lseq (mapcat identity (for [x aseq] [x (.length (name x))]))] - (simple-tests up-tests - (cl-format nil "~{~a~^, ~}" aseq) "a, quick, brown, fox, jumped, over, the, lazy, dog" - (cl-format nil "~{~a~0^, ~}" aseq) "a" - (cl-format nil "~{~a~#,3^, ~}" aseq) "a, quick, brown, fox, jumped, over" - (cl-format nil "~{~a~v,3^, ~}" lseq) "a, quick, brown, fox" - (cl-format nil "~{~a~3,v,4^, ~}" lseq) "a, quick, brown, fox" -)) - -(simple-tests angle-bracket-tests - (cl-format nil "~") "foobarbaz" - (cl-format nil "~20") "foo bar baz" - (cl-format nil "~,,2") "foo bar baz" - (cl-format nil "~20<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" - (cl-format nil "~20:<~A~;~A~;~A~>" "foo" "bar" "baz") " foo bar baz" - (cl-format nil "~20@<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz " - (cl-format nil "~20@:<~A~;~A~;~A~>" "foo" "bar" "baz") " foo bar baz " - (cl-format nil "~10,,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" - (cl-format nil "~10,10,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" - (cl-format nil "~10,10<~A~;~A~;~A~>" "foo" "bar" "baz") "foo barbaz" - (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar" "baz") "foo bar baz" - (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar") "foo bar" - (cl-format nil "~20@<~A~;~^~A~;~^~A~>" "foo") "foo " - (cl-format nil "~20:<~A~;~^~A~;~^~A~>" "foo") " foo" -) - -(simple-tests angle-bracket-max-column-tests - (cl-format nil "~%;; ~{~<~%;; ~1,50:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance" "\\s"))) - "\n;; This function computes the circular\n;; thermodynamic coefficient of the thrombulator\n;; angle for use in determining the reaction\n;; distance.\n" -(cl-format true "~%;; ~{~<~%;; ~:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance." "\\s")))) - -(defn list-to-table [aseq column-width] - (let [stream (get-pretty-writer (java.io.StringWriter.))] - (binding [*out* stream] - (doseq [row aseq] - (doseq [col row] - (cl-format true "~4D~7,vT" col column-width)) - (prn))) - (.flush stream) - (.toString (:base @@(:base @@stream))))) - -(simple-tests column-writer-test - (list-to-table (map #(vector % (* % %) (* % % %)) (range 1 21)) 8) - " 1 1 1 \n 2 4 8 \n 3 9 27 \n 4 16 64 \n 5 25 125 \n 6 36 216 \n 7 49 343 \n 8 64 512 \n 9 81 729 \n 10 100 1000 \n 11 121 1331 \n 12 144 1728 \n 13 169 2197 \n 14 196 2744 \n 15 225 3375 \n 16 256 4096 \n 17 289 4913 \n 18 324 5832 \n 19 361 6859 \n 20 400 8000 \n") -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; The following tests are the various examples from the format -;; documentation in Common Lisp, the Language, 2nd edition, Chapter 22.3 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn expt [base pow] (reduce * (repeat pow base))) - -(let [x 5, y "elephant", n 3] - (simple-tests cltl-intro-tests - (format nil "foo") "foo" - (format nil "The answer is ~D." x) "The answer is 5." - (format nil "The answer is ~3D." x) "The answer is 5." - (format nil "The answer is ~3,'0D." x) "The answer is 005." - (format nil "The answer is ~:D." (expt 47 x)) "The answer is 229,345,007." - (format nil "Look at the ~A!" y) "Look at the elephant!" - (format nil "Type ~:C to ~A." (char 4) "delete all your files") - "Type Control-D to delete all your files." - (format nil "~D item~:P found." n) "3 items found." - (format nil "~R dog~:[s are~; is~] here." n (= n 1)) "three dogs are here." - (format nil "~R dog~:*~[s are~; is~:;s are~] here." n) "three dogs are here." - (format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) "Here are three puppies.")) - -(simple-tests cltl-B-tests - ;; CLtL didn't have the colons here, but the spec requires them - (format nil "~,,' ,4:B" 0xFACE) "1111 1010 1100 1110" - (format nil "~,,' ,4:B" 0x1CE) "1 1100 1110" - (format nil "~19,,' ,4:B" 0xFACE) "1111 1010 1100 1110" - ;; This one was a nice idea, but nothing in the spec supports it working this way - ;; (and SBCL doesn't work this way either) - ;(format nil "~19,,' ,4:B" 0x1CE) "0000 0001 1100 1110") - ) - -(simple-tests cltl-P-tests - (format nil "~D tr~:@P/~D win~:P" 7 1) "7 tries/1 win" - (format nil "~D tr~:@P/~D win~:P" 1 0) "1 try/0 wins" - (format nil "~D tr~:@P/~D win~:P" 1 3) "1 try/3 wins") - -(defn foo [x] - (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" - x x x x x x)) - -(simple-tests cltl-F-tests - (foo 3.14159) " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" - (foo -3.14159) " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" - (foo 100.0) "100.00|******|100.00| 100.0|100.00|100.0" - (foo 1234.0) "1234.00|******|??????|1234.0|1234.00|1234.0" - (foo 0.006) " 0.01| 0.06| 0.01| 0.006|0.01|0.006") - -(defn foo-e [x] - (format nil - "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" - x x x x)) - -;; Clojure doesn't support float/double differences in representation -(simple-tests cltl-E-tests - (foo-e 0.0314159) " 3.14E-2| 31.42$-03|+.003E+01| 3.14E-2" ; Added this one - (foo-e 3.14159) " 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" - (foo-e -3.14159) " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" - (foo-e 1100.0) " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" -; In Clojure, this is identical to the above -; (foo-e 1100.0L0) " 1.10L+3| 11.00$+02|+.001L+06| 1.10L+3" - (foo-e 1.1E13) "*********| 11.00$+12|+.001E+16| 1.10E+13" - (foo-e 1.1E120) "*********|??????????|%%%%%%%%%|1.10E+120" -; Clojure doesn't support real numbers this large -; (foo-e 1.1L1200) "*********|??????????|%%%%%%%%%|1.10L+1200" -) - -(simple-tests cltl-E-scale-tests - (map - (fn [k] (format nil "Scale factor ~2D~:*: |~13,6,2,VE|" - (- k 5) 3.14159)) ;Prints 13 lines - (range 13)) - '("Scale factor -5: | 0.000003E+06|" - "Scale factor -4: | 0.000031E+05|" - "Scale factor -3: | 0.000314E+04|" - "Scale factor -2: | 0.003142E+03|" - "Scale factor -1: | 0.031416E+02|" - "Scale factor 0: | 0.314159E+01|" - "Scale factor 1: | 3.141590E+00|" - "Scale factor 2: | 31.41590E-01|" - "Scale factor 3: | 314.1590E-02|" - "Scale factor 4: | 3141.590E-03|" - "Scale factor 5: | 31415.90E-04|" - "Scale factor 6: | 314159.0E-05|" - "Scale factor 7: | 3141590.E-06|")) - -(defn foo-g [x] - (format nil - "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" - x x x x)) - -;; Clojure doesn't support float/double differences in representation -(simple-tests cltl-G-tests - (foo-g 0.0314159) " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" - (foo-g 0.314159) " 0.31 |0.314 |0.314 | 0.31 " - (foo-g 3.14159) " 3.1 | 3.14 | 3.14 | 3.1 " - (foo-g 31.4159) " 31. | 31.4 | 31.4 | 31. " - (foo-g 314.159) " 3.14E+2| 314. | 314. | 3.14E+2" - (foo-g 3141.59) " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" -; In Clojure, this is identical to the above -; (foo-g 3141.59L0) " 3.14L+3|314.2$+01|0.314L+04| 3.14L+3" - (foo-g 3.14E12) "*********|314.0$+10|0.314E+13| 3.14E+12" - (foo-g 3.14E120) "*********|?????????|%%%%%%%%%|3.14E+120" -; Clojure doesn't support real numbers this large -; (foo-g 3.14L1200) "*********|?????????|%%%%%%%%%|3.14L+1200" -) - -(defn type-clash-error [fun nargs argnum right-type wrong-type] - (format nil ;; CLtL has this format string slightly wrong - "~&Function ~S requires its ~:[~:R ~;~*~]~ - argument to be of type ~S,~%but it was called ~ - with an argument of type ~S.~%" - fun (= nargs 1) argnum right-type wrong-type)) - -(simple-tests cltl-Newline-tests - (type-clash-error 'aref nil 2 'integer 'vector) -"Function aref requires its second argument to be of type integer, -but it was called with an argument of type vector.\n" - (type-clash-error 'car 1 1 'list 'short-float) -"Function car requires its argument to be of type list, -but it was called with an argument of type short-float.\n") - -(simple-tests cltl-?-tests - (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) " 7" - (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) " 7" - (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) " 7" - (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) " 14") - -(defn f [n] (format nil "~@(~R~) error~:P detected." n)) - -(simple-tests cltl-paren-tests - (format nil "~@R ~(~@R~)" 14 14) "XIV xiv" - (f 0) "Zero errors detected." - (f 1) "One error detected." - (f 23) "Twenty-three errors detected.") - -(let [*print-level* nil *print-length* 5] - (simple-tests cltl-bracket-tests - (format nil "~@[ print level = ~D~]~@[ print length = ~D~]" - *print-level* *print-length*) - " print length = 5")) - -(let [foo "Items:~#[ none~; ~S~; ~S and ~S~ - ~:;~@{~#[~; and~] ~ - ~S~^,~}~]."] - (simple-tests cltl-bracket1-tests - (format nil foo) "Items: none." - (format nil foo 'foo) "Items: foo." - (format nil foo 'foo 'bar) "Items: foo and bar." - (format nil foo 'foo 'bar 'baz) "Items: foo, bar, and baz." - (format nil foo 'foo 'bar 'baz 'quux) "Items: foo, bar, baz, and quux.")) - -(simple-tests cltl-curly-bracket-tests - (format nil - "The winners are:~{ ~S~}." - '(fred harry jill)) - "The winners are: fred harry jill." - - (format nil "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) - "Pairs: ." - - (format nil "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) - "Pairs: ." - - (format nil "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3) - "Pairs: ." - - (format nil "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) - "Pairs: .") - -(simple-tests cltl-angle-bracket-tests - (format nil "~10") "foo bar" - (format nil "~10:") " foo bar" - (format nil "~10:@") " foo bar " - (format nil "~10") " foobar" - (format nil "~10:") " foobar" - (format nil "~10@") "foobar " - (format nil "~10:@") " foobar ") - -(let [donestr "Done.~^ ~D warning~:P.~^ ~D error~:P." - tellstr "~@{~@(~@[~R~^ ~]~A~)~}."] ;; The CLtL example is a little wrong here - - (simple-tests cltl-up-tests - (format nil donestr) "Done." - (format nil donestr 3) "Done. 3 warnings." - (format nil donestr 1 5) "Done. 1 warning. 5 errors." - (format nil tellstr 23) "Twenty-three." - (format nil tellstr nil "losers") "Losers." - (format nil tellstr 23 "losers") "Twenty-three losers." - (format nil "~15<~S~;~^~S~;~^~S~>" 'foo) - " foo" - (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) - "foo bar" - (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) - "foo bar baz")) - -(simple-tests cltl-up-x3j13-tests - (format nil - "~:{/~S~^ ...~}" - '((hot dog) (hamburger) (ice cream) (french fries))) - "/hot .../hamburger/ice .../french ..." - (format nil - "~:{/~S~:^ ...~}" - '((hot dog) (hamburger) (ice cream) (french fries))) - "/hot .../hamburger .../ice .../french" - - (format nil - "~:{/~S~#:^ ...~}" ;; This is wrong in CLtL - '((hot dog) (hamburger) (ice cream) (french fries))) - "/hot .../hamburger") - diff --git a/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_helper.clj b/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_helper.clj deleted file mode 100644 index 9a36bbbeaa..0000000000 --- a/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_helper.clj +++ /dev/null @@ -1,21 +0,0 @@ -;;; helper.clj -- part of the pretty printer for Clojure - -;; by Tom Faulhaber -;; April 3, 2009 - -; Copyright (c) Tom Faulhaber, April 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 is just a macro to make my tests a little cleaner - -(ns clojure.contrib.pprint.test-helper - (:use [clojure.test :only (deftest are run-tests)])) - -(defmacro simple-tests [name & test-pairs] - `(deftest ~name (are [x y] (= x y) ~@test-pairs))) - diff --git a/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_pretty.clj b/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_pretty.clj deleted file mode 100644 index f5de6f1e83..0000000000 --- a/modules/pprint/src/test/clojure/clojure/contrib/pprint/test_pretty.clj +++ /dev/null @@ -1,127 +0,0 @@ -;;; pretty.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. - -(ns clojure.contrib.pprint.test-pretty - (:use [clojure.test :only (deftest are run-tests)] - clojure.contrib.pprint.test-helper - clojure.contrib.pprint)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Unit tests for the pretty printer -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(simple-tests xp-fill-test - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 38 - *print-miser-width* nil] - (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%" - '((x 4) (*print-length* nil) (z 2) (list nil)))) - "(let ((x 4) (*print-length* nil)\n (z 2) (list nil))\n ...)\n" - - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 22] - (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%" - '((x 4) (*print-length* nil) (z 2) (list nil)))) - "(let ((x 4)\n (*print-length*\n nil)\n (z 2)\n (list nil))\n ...)\n") - -(simple-tests xp-miser-test - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 10, *print-miser-width* 9] - (cl-format nil "~:" '(first second third))) - "(LIST\n first\n second\n third)" - - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 10, *print-miser-width* 8] - (cl-format nil "~:" '(first second third))) - "(LIST first second third)") - -(simple-tests mandatory-fill-test - (cl-format nil - "
~%~~%
~%" - [ "hello" "gooodbye" ]) - "
-Usage: *hello*
-       *gooodbye*
-
-") - -(simple-tests prefix-suffix-test - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 10, *print-miser-width* 10] - (cl-format nil "~<{~;LIST ~@_~W ~@_~W ~@_~W~;}~:>" '(first second third))) - "{LIST\n first\n second\n third}") - -(simple-tests pprint-test - (binding [*print-pprint-dispatch* *simple-dispatch*] - (write '(defn foo [x y] - (let [result (* x y)] - (if (> result 400) - (cl-format true "That number is too big") - (cl-format true "The result of ~d x ~d is ~d" x y result)))) - :stream nil)) - "(defn - foo - [x y] - (let - [result (* x y)] - (if - (> result 400) - (cl-format true \"That number is too big\") - (cl-format true \"The result of ~d x ~d is ~d\" x y result))))" - - (with-pprint-dispatch *code-dispatch* - (write '(defn foo [x y] - (let [result (* x y)] - (if (> result 400) - (cl-format true "That number is too big") - (cl-format true "The result of ~d x ~d is ~d" x y result)))) - :stream nil)) - "(defn foo [x y] - (let [result (* x y)] - (if (> result 400) - (cl-format true \"That number is too big\") - (cl-format true \"The result of ~d x ~d is ~d\" x y result))))" - - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 15] - (write '(fn (cons (car x) (cdr y))) :stream nil)) - "(fn\n (cons\n (car x)\n (cdr y)))" - - (with-pprint-dispatch *code-dispatch* - (binding [*print-right-margin* 52] - (write - '(add-to-buffer this (make-buffer-blob (str (char c)) nil)) - :stream nil))) - "(add-to-buffer\n this\n (make-buffer-blob (str (char c)) nil))" - ) - - - -(simple-tests pprint-reader-macro-test - (with-pprint-dispatch *code-dispatch* - (write (read-string "(map #(first %) [[1 2 3] [4 5 6] [7]])") - :stream nil)) - "(map #(first %) [[1 2 3] [4 5 6] [7]])" - - (with-pprint-dispatch *code-dispatch* - (write (read-string "@@(ref (ref 1))") - :stream nil)) - "@@(ref (ref 1))" - - (with-pprint-dispatch *code-dispatch* - (write (read-string "'foo") - :stream nil)) - "'foo" -) diff --git a/pom.xml b/pom.xml index 172a720930..69141fc05c 100644 --- a/pom.xml +++ b/pom.xml @@ -61,7 +61,6 @@ modules/monadic-io-streams modules/monads modules/ns-utils - modules/pprint modules/priority-map modules/probabilities modules/profile