diff options
Diffstat (limited to 'src/clojure/contrib/pprint/cl_format.clj')
| -rw-r--r-- | src/clojure/contrib/pprint/cl_format.clj | 1843 |
1 files changed, 0 insertions, 1843 deletions
diff --git a/src/clojure/contrib/pprint/cl_format.clj b/src/clojure/contrib/pprint/cl_format.clj deleted file mode 100644 index 145697ff..00000000 --- a/src/clojure/contrib/pprint/cl_format.clj +++ /dev/null @@ -1,1843 +0,0 @@ -;;; cl_format.clj -- part of the pretty printer for Clojure - -;; by Tom Faulhaber -;; April 3, 2009 - -; Copyright (c) Tom Faulhaber, Dec 2008. All rights reserved. -; The use and distribution terms for this software are covered by the -; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -; which can be found in the file epl-v10.html at the root of this distribution. -; By using this software in any fashion, you are agreeing to be bound by -; the terms of this license. -; You must not remove this notice, or any other, from this software. - -;; This module implements the Common Lisp compatible format function as documented -;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at: -;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) - -(in-ns 'clojure.contrib.pprint) - -;;; Forward references -(declare compile-format) -(declare execute-format) -(declare init-navigator) -;;; End forward references - -(defn cl-format - "An implementation of a Common Lisp compatible format function. cl-format formats its -arguments to an output stream or string based on the format control string given. It -supports sophisticated formatting of structured data. - -Writer is an instance of java.io.Writer, true to output to *out* or nil to output -to a string, format-in is the format control string and the remaining arguments -are the data to be formatted. - -The format control string is a string to be output with embedded 'format directives' -describing how to format the various arguments passed in. - -If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format -returns nil. - -For example: - (let [results [46 38 22]] - (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" - (count results) results)) - -Prints to *out*: - There are 3 results: 46, 38, 22 - -Detailed documentation on format control strings is available in the \"Common Lisp the -Language, 2nd edition\", Chapter 22 (available online at: -http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) -and in the Common Lisp HyperSpec at -http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm -" - {:see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000" - "Common Lisp the Language"] - ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm" - "Common Lisp HyperSpec"]]} - [writer format-in & args] - (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) - navigator (init-navigator args)] - (execute-format writer compiled-format navigator))) - -(def #^{:private true} *format-str* nil) - -(defn- format-error [message offset] - (let [full-message (str message \newline *format-str* \newline - (apply str (repeat offset \space)) "^" \newline)] - (throw (RuntimeException. full-message)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Argument navigators manage the argument list -;;; as the format statement moves through the list -;;; (possibly going forwards and backwards as it does so) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct #^{:private true} - arg-navigator :seq :rest :pos ) - -(defn init-navigator - "Create a new arg-navigator from the sequence with the position set to 0" - {:skip-wiki true} - [s] - (let [s (seq s)] - (struct arg-navigator s s 0))) - -;; TODO call format-error with offset -(defn- next-arg [ navigator ] - (let [ rst (:rest navigator) ] - (if rst - [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] - (throw (new Exception "Not enough arguments for format definition"))))) - -(defn- next-arg-or-nil [navigator] - (let [rst (:rest navigator)] - (if rst - [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] - [nil navigator]))) - -;; Get an argument off the arg list and compile it if it's not already compiled -(defn- get-format-arg [navigator] - (let [[raw-format navigator] (next-arg navigator) - compiled-format (if (instance? String raw-format) - (compile-format raw-format) - raw-format)] - [compiled-format navigator])) - -(declare relative-reposition) - -(defn- absolute-reposition [navigator position] - (if (>= position (:pos navigator)) - (relative-reposition navigator (- (:pos navigator) position)) - (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position))) - -(defn- relative-reposition [navigator position] - (let [newpos (+ (:pos navigator) position)] - (if (neg? position) - (absolute-reposition navigator newpos) - (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos)))) - -(defstruct #^{:private true} - compiled-directive :func :def :params :offset) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; When looking at the parameter list, we may need to manipulate -;;; the argument list as well (for 'V' and '#' parameter types). -;;; We hide all of this behind a function, but clients need to -;;; manage changing arg navigator -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO: validate parameters when they come from arg list -(defn- realize-parameter [[param [raw-val offset]] navigator] - (let [[real-param new-navigator] - (cond - (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary - [raw-val navigator] - - (= raw-val :parameter-from-args) - (next-arg navigator) - - (= raw-val :remaining-arg-count) - [(count (:rest navigator)) navigator] - - true - [raw-val navigator])] - [[param [real-param offset]] new-navigator])) - -(defn- realize-parameter-list [parameter-map navigator] - (let [[pairs new-navigator] - (map-passing-context realize-parameter navigator parameter-map)] - [(into {} pairs) new-navigator])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Functions that support individual directives -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Common handling code for ~A and ~S -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare opt-base-str) - -(def #^{:private true} - special-radix-markers {2 "#b" 8 "#o", 16 "#x"}) - -(defn- format-simple-number [n] - (cond - (integer? n) (if (= *print-base* 10) - (str n (if *print-radix* ".")) - (str - (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) - (opt-base-str *print-base* n))) - (ratio? n) (str - (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) - (opt-base-str *print-base* (.numerator n)) - "/" - (opt-base-str *print-base* (.denominator n))) - :else nil)) - -(defn- format-ascii [print-func params arg-navigator offsets] - (let [ [arg arg-navigator] (next-arg arg-navigator) - #^String base-output (or (format-simple-number arg) (print-func arg)) - base-width (.length base-output) - min-width (+ base-width (:minpad params)) - width (if (>= min-width (:mincol params)) - min-width - (+ min-width - (* (+ (quot (- (:mincol params) min-width 1) - (:colinc params) ) - 1) - (:colinc params)))) - chars (apply str (repeat (- width base-width) (:padchar params)))] - (if (:at params) - (print (str chars base-output)) - (print (str base-output chars))) - arg-navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for the integer directives ~D, ~X, ~O, ~B and some -;;; of ~R -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- integral? - "returns true if a number is actually an integer (that is, has no fractional part)" - [x] - (cond - (integer? x) true - (decimal? x) (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part - (float? x) (= x (Math/floor x)) - (ratio? x) (let [#^clojure.lang.Ratio r x] - (= 0 (rem (.numerator r) (.denominator r)))) - :else false)) - -(defn- remainders - "Return the list of remainders (essentially the 'digits') of val in the given base" - [base val] - (reverse - (first - (consume #(if (pos? %) - [(rem % base) (quot % base)] - [nil nil]) - val)))) - -;;; TODO: xlated-val does not seem to be used here. -(defn- base-str - "Return val as a string in the given base" - [base val] - (if (zero? val) - "0" - (let [xlated-val (cond - (float? val) (bigdec val) - (ratio? val) (let [#^clojure.lang.Ratio r val] - (/ (.numerator r) (.denominator r))) - :else val)] - (apply str - (map - #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10)))) - (remainders base val)))))) - -(def #^{:private true} - java-base-formats {8 "%o", 10 "%d", 16 "%x"}) - -(defn- opt-base-str - "Return val as a string in the given base, using clojure.core/format if supported -for improved performance" - [base val] - (let [format-str (get java-base-formats base)] - (if (and format-str (integer? val)) - (clojure.core/format format-str val) - (base-str base val)))) - -(defn- group-by [unit lis] - (reverse - (first - (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis))))) - -(defn- format-integer [base params arg-navigator offsets] - (let [[arg arg-navigator] (next-arg arg-navigator)] - (if (integral? arg) - (let [neg (neg? arg) - pos-arg (if neg (- arg) arg) - raw-str (opt-base-str base pos-arg) - group-str (if (:colon params) - (let [groups (map #(apply str %) (group-by (:commainterval params) raw-str)) - commas (repeat (count groups) (:commachar params))] - (apply str (next (interleave commas groups)))) - raw-str) - #^String signed-str (cond - neg (str "-" group-str) - (:at params) (str "+" group-str) - true group-str) - padded-str (if (< (.length signed-str) (:mincol params)) - (str (apply str (repeat (- (:mincol params) (.length signed-str)) - (:padchar params))) - signed-str) - signed-str)] - (print padded-str)) - (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0 - :padchar (:padchar params) :at true} - (init-navigator [arg]) nil)) - arg-navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for english formats (~R and ~:R) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def #^{:private true} - english-cardinal-units - ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" - "ten" "eleven" "twelve" "thirteen" "fourteen" - "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"]) - -(def #^{:private true} - english-ordinal-units - ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" - "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" - "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"]) - -(def #^{:private true} - english-cardinal-tens - ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"]) - -(def #^{:private true} - english-ordinal-tens - ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth" - "sixtieth" "seventieth" "eightieth" "ninetieth"]) - -;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales) -;; Number names from http://www.jimloy.com/math/billion.htm -;; We follow the rules for writing numbers from the Blue Book -;; (http://www.grammarbook.com/numbers/numbers.asp) -(def #^{:private true} - english-scale-numbers - ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" - "sextillion" "septillion" "octillion" "nonillion" "decillion" - "undecillion" "duodecillion" "tredecillion" "quattuordecillion" - "quindecillion" "sexdecillion" "septendecillion" - "octodecillion" "novemdecillion" "vigintillion"]) - -(defn- format-simple-cardinal - "Convert a number less than 1000 to a cardinal english string" - [num] - (let [hundreds (quot num 100) - tens (rem num 100)] - (str - (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) - (if (and (pos? hundreds) (pos? tens)) " ") - (if (pos? tens) - (if (< tens 20) - (nth english-cardinal-units tens) - (let [ten-digit (quot tens 10) - unit-digit (rem tens 10)] - (str - (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) - (if (and (pos? ten-digit) (pos? unit-digit)) "-") - (if (pos? unit-digit) (nth english-cardinal-units unit-digit))))))))) - -(defn- add-english-scales - "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string -offset is a factor of 10^3 to multiply by" - [parts offset] - (let [cnt (count parts)] - (loop [acc [] - pos (dec cnt) - this (first parts) - remainder (next parts)] - (if (nil? remainder) - (str (apply str (interpose ", " acc)) - (if (and (not (empty? this)) (not (empty? acc))) ", ") - this - (if (and (not (empty? this)) (pos? (+ pos offset))) - (str " " (nth english-scale-numbers (+ pos offset))))) - (recur - (if (empty? this) - acc - (conj acc (str this " " (nth english-scale-numbers (+ pos offset))))) - (dec pos) - (first remainder) - (next remainder)))))) - -(defn- format-cardinal-english [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (= 0 arg) - (print "zero") - (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs - parts (remainders 1000 abs-arg)] - (if (<= (count parts) (count english-scale-numbers)) - (let [parts-strs (map format-simple-cardinal parts) - full-str (add-english-scales parts-strs 0)] - (print (str (if (neg? arg) "minus ") full-str))) - (format-integer ;; for numbers > 10^63, we fall back on ~D - 10 - { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} - (init-navigator [arg]) - { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})))) - navigator)) - -(defn- format-simple-ordinal - "Convert a number less than 1000 to a ordinal english string -Note this should only be used for the last one in the sequence" - [num] - (let [hundreds (quot num 100) - tens (rem num 100)] - (str - (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) - (if (and (pos? hundreds) (pos? tens)) " ") - (if (pos? tens) - (if (< tens 20) - (nth english-ordinal-units tens) - (let [ten-digit (quot tens 10) - unit-digit (rem tens 10)] - (if (and (pos? ten-digit) (not (pos? unit-digit))) - (nth english-ordinal-tens ten-digit) - (str - (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) - (if (and (pos? ten-digit) (pos? unit-digit)) "-") - (if (pos? unit-digit) (nth english-ordinal-units unit-digit)))))) - (if (pos? hundreds) "th"))))) - -(defn- format-ordinal-english [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (= 0 arg) - (print "zeroth") - (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs - parts (remainders 1000 abs-arg)] - (if (<= (count parts) (count english-scale-numbers)) - (let [parts-strs (map format-simple-cardinal (drop-last parts)) - head-str (add-english-scales parts-strs 1) - tail-str (format-simple-ordinal (last parts))] - (print (str (if (neg? arg) "minus ") - (cond - (and (not (empty? head-str)) (not (empty? tail-str))) - (str head-str ", " tail-str) - - (not (empty? head-str)) (str head-str "th") - :else tail-str)))) - (do (format-integer ;; for numbers > 10^63, we fall back on ~D - 10 - { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} - (init-navigator [arg]) - { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}) - (let [low-two-digits (rem arg 100) - not-teens (or (< 11 low-two-digits) (> 19 low-two-digits)) - low-digit (rem low-two-digits 10)] - (print (cond - (and (= low-digit 1) not-teens) "st" - (and (= low-digit 2) not-teens) "nd" - (and (= low-digit 3) not-teens) "rd" - :else "th"))))))) - navigator)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for roman numeral formats (~@R and ~@:R) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def #^{:private true} - old-roman-table - [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"] - [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"] - [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"] - [ "M" "MM" "MMM"]]) - -(def #^{:private true} - new-roman-table - [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"] - [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"] - [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"] - [ "M" "MM" "MMM"]]) - -(defn- format-roman - "Format a roman numeral using the specified look-up table" - [table params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (and (number? arg) (> arg 0) (< arg 4000)) - (let [digits (remainders 10 arg)] - (loop [acc [] - pos (dec (count digits)) - digits digits] - (if (empty? digits) - (print (apply str acc)) - (let [digit (first digits)] - (recur (if (= 0 digit) - acc - (conj acc (nth (nth table pos) (dec digit)))) - (dec pos) - (next digits)))))) - (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D - 10 - { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} - (init-navigator [arg]) - { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})) - navigator)) - -(defn- format-old-roman [params navigator offsets] - (format-roman old-roman-table params navigator offsets)) - -(defn- format-new-roman [params navigator offsets] - (format-roman new-roman-table params navigator offsets)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for character formats (~C) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def #^{:private true} - special-chars { 8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"}) - -(defn- pretty-character [params navigator offsets] - (let [[c navigator] (next-arg navigator) - as-int (int c) - base-char (bit-and as-int 127) - meta (bit-and as-int 128) - special (get special-chars base-char)] - (if (> meta 0) (print "Meta-")) - (print (cond - special special - (< base-char 32) (str "Control-" (char (+ base-char 64))) - (= base-char 127) "Control-?" - :else (char base-char))) - navigator)) - -(defn- readable-character [params navigator offsets] - (let [[c navigator] (next-arg navigator)] - (condp = (:char-format params) - \o (cl-format true "\\o~3,'0o" (int c)) - \u (cl-format true "\\u~4,'0x" (int c)) - nil (pr c)) - navigator)) - -(defn- plain-character [params navigator offsets] - (let [[char navigator] (next-arg navigator)] - (print char) - navigator)) - -;; Check to see if a result is an abort (~^) construct -;; TODO: move these funcs somewhere more appropriate -(defn- abort? [context] - (let [token (first context)] - (or (= :up-arrow token) (= :colon-up-arrow token)))) - -;; Handle the execution of "sub-clauses" in bracket constructions -(defn- execute-sub-format [format args base-args] - (second - (map-passing-context - (fn [element context] - (if (abort? context) - [nil context] ; just keep passing it along - (let [[params args] (realize-parameter-list (:params element) context) - [params offsets] (unzip-map params) - params (assoc params :base-args base-args)] - [nil (apply (:func element) [params args offsets])]))) - args - format))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for real number formats -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO - return exponent as int to eliminate double conversion -(defn- float-parts-base - "Produce string parts for the mantissa (normalized 1-9) and exponent" - [#^Object f] - (let [#^String s (.toLowerCase (.toString f)) - exploc (.indexOf s (int \e))] - (if (neg? exploc) - (let [dotloc (.indexOf s (int \.))] - (if (neg? dotloc) - [s (str (dec (count s)))] - [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))])) - [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))]))) - - -(defn- float-parts - "Take care of leading and trailing zeros in decomposed floats" - [f] - (let [[m #^String e] (float-parts-base f) - m1 (rtrim m \0) - m2 (ltrim m1 \0) - delta (- (count m1) (count m2)) - #^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)] - (if (empty? m2) - ["0" 0] - [m2 (- (Integer/valueOf e) delta)]))) - -(defn- round-str [m e d w] - (if (or d w) - (let [len (count m) - round-pos (if d (+ e d 1)) - round-pos (if (and w (< (inc e) (dec w)) - (or (nil? round-pos) (< (dec w) round-pos))) - (dec w) - round-pos) - [m1 e1 round-pos len] (if (= round-pos 0) - [(str "0" m) (inc e) 1 (inc len)] - [m e round-pos len])] - (if round-pos - (if (neg? round-pos) - ["0" 0 false] - (if (> len round-pos) - (let [round-char (nth m1 round-pos) - #^String result (subs m1 0 round-pos)] - (if (>= (int round-char) (int \5)) - (let [result-val (Integer/valueOf result) - leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1))) - round-up-result (str leading-zeros - (String/valueOf (+ result-val - (if (neg? result-val) -1 1)))) - expanded (> (count round-up-result) (count result))] - [round-up-result e1 expanded]) - [result e1 false])) - [m e false])) - [m e false])) - [m e false])) - -(defn- expand-fixed [m e d] - (let [m1 (if (neg? e) (str (apply str (repeat (dec (- e)) \0)) m) m) - len (count m1) - target-len (if d (+ e d 1) (inc e))] - (if (< len target-len) - (str m1 (apply str (repeat (- target-len len) \0))) - m1))) - -(defn- insert-decimal - "Insert the decimal point at the right spot in the number to match an exponent" - [m e] - (if (neg? e) - (str "." m) - (let [loc (inc e)] - (str (subs m 0 loc) "." (subs m loc))))) - -(defn- get-fixed [m e d] - (insert-decimal (expand-fixed m e d) e)) - -(defn- insert-scaled-decimal - "Insert the decimal point at the right spot in the number to match an exponent" - [m k] - (if (neg? k) - (str "." m) - (str (subs m 0 k) "." (subs m k)))) - -;; the function to render ~F directives -;; TODO: support rationals. Back off to ~D/~A is the appropriate cases -(defn- fixed-float [params navigator offsets] - (let [w (:w params) - d (:d params) - [arg navigator] (next-arg navigator) - [mantissa exp] (float-parts arg) - scaled-exp (+ exp (:k params)) - add-sign (and (:at params) (not (neg? arg))) - prepend-zero (< -1.0 arg 1.0) - append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp)) - [rounded-mantissa scaled-exp] (round-str mantissa scaled-exp - d (if w (- w (if add-sign 1 0)))) - fixed-repr (get-fixed rounded-mantissa scaled-exp d)] - (if w - (let [len (count fixed-repr) - signed-len (if add-sign (inc len) len) - prepend-zero (and prepend-zero (not (= signed-len w))) - append-zero (and append-zero (not (= signed-len w))) - full-len (if (or prepend-zero append-zero) - (inc signed-len) - signed-len)] - (if (and (> full-len w) (:overflowchar params)) - (print (apply str (repeat w (:overflowchar params)))) - (print (str - (apply str (repeat (- w full-len) (:padchar params))) - (if add-sign "+") - (if prepend-zero "0") - fixed-repr - (if append-zero "0"))))) - (print (str - (if add-sign "+") - (if prepend-zero "0") - fixed-repr - (if append-zero "0")))) - navigator)) - - -;; the function to render ~E directives -;; TODO: support rationals. Back off to ~D/~A is the appropriate cases -;; TODO: define ~E representation for Infinity -(defn- exponential-float [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))] - (let [w (:w params) - d (:d params) - e (:e params) - k (:k params) - expchar (or (:exponentchar params) \E) - add-sign (or (:at params) (neg? arg)) - prepend-zero (<= k 0) - #^Integer scaled-exp (- exp (dec k)) - scaled-exp-str (str (Math/abs scaled-exp)) - scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+) - (if e (apply str - (repeat - (- e - (count scaled-exp-str)) - \0))) - scaled-exp-str) - exp-width (count scaled-exp-str) - base-mantissa-width (count mantissa) - scaled-mantissa (str (apply str (repeat (- k) \0)) - mantissa - (if d - (apply str - (repeat - (- d (dec base-mantissa-width) - (if (neg? k) (- k) 0)) \0)))) - w-mantissa (if w (- w exp-width)) - [rounded-mantissa _ incr-exp] (round-str - scaled-mantissa 0 - (cond - (= k 0) (dec d) - (pos? k) d - (neg? k) (dec d)) - (if w-mantissa - (- w-mantissa (if add-sign 1 0)))) - full-mantissa (insert-scaled-decimal rounded-mantissa k) - append-zero (and (= k (count rounded-mantissa)) (nil? d))] - (if (not incr-exp) - (if w - (let [len (+ (count full-mantissa) exp-width) - signed-len (if add-sign (inc len) len) - prepend-zero (and prepend-zero (not (= signed-len w))) - full-len (if prepend-zero (inc signed-len) signed-len) - append-zero (and append-zero (< full-len w))] - (if (and (or (> full-len w) (and e (> (- exp-width 2) e))) - (:overflowchar params)) - (print (apply str (repeat w (:overflowchar params)))) - (print (str - (apply str - (repeat - (- w full-len (if append-zero 1 0) ) - (:padchar params))) - (if add-sign (if (neg? arg) \- \+)) - (if prepend-zero "0") - full-mantissa - (if append-zero "0") - scaled-exp-str)))) - (print (str - (if add-sign (if (neg? arg) \- \+)) - (if prepend-zero "0") - full-mantissa - (if append-zero "0") - scaled-exp-str))) - (recur [rounded-mantissa (inc exp)])))) - navigator)) - -;; the function to render ~G directives -;; This just figures out whether to pass the request off to ~F or ~E based -;; on the algorithm in CLtL. -;; TODO: support rationals. Back off to ~D/~A is the appropriate cases -;; TODO: refactor so that float-parts isn't called twice -(defn- general-float [params navigator offsets] - (let [[arg _] (next-arg navigator) - [mantissa exp] (float-parts (if (neg? arg) (- arg) arg)) - w (:w params) - d (:d params) - e (:e params) - n (if (= arg 0.0) 0 (inc exp)) - ee (if e (+ e 2) 4) - ww (if w (- w ee)) - d (if d d (max (count mantissa) (min n 7))) - dd (- d n)] - (if (<= 0 dd d) - (let [navigator (fixed-float {:w ww, :d dd, :k 0, - :overflowchar (:overflowchar params), - :padchar (:padchar params), :at (:at params)} - navigator offsets)] - (print (apply str (repeat ee \space))) - navigator) - (exponential-float params navigator offsets)))) - -;; the function to render ~$ directives -;; TODO: support rationals. Back off to ~D/~A is the appropriate cases -(defn- dollar-float [params navigator offsets] - (let [[#^Double arg navigator] (next-arg navigator) - [mantissa exp] (float-parts (Math/abs arg)) - d (:d params) ; digits after the decimal - n (:n params) ; minimum digits before the decimal - w (:w params) ; minimum field width - add-sign (or (:at params) (neg? arg)) - [rounded-mantissa scaled-exp _] (round-str mantissa exp d nil) - #^String fixed-repr (get-fixed rounded-mantissa scaled-exp d) - full-repr (str (apply str (repeat (- n (.indexOf fixed-repr (int \.))) \0)) fixed-repr) - full-len (+ (count full-repr) (if add-sign 1 0))] - (print (str - (if (and (:colon params) add-sign) (if (neg? arg) \- \+)) - (apply str (repeat (- w full-len) (:padchar params))) - (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+)) - full-repr)) - navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for the '~[...~]' conditional construct in its -;;; different flavors -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; ~[...~] without any modifiers chooses one of the clauses based on the param or -;; next argument -;; TODO check arg is positive int -(defn- choice-conditional [params arg-navigator offsets] - (let [arg (:selector params) - [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator)) - clauses (:clauses params) - clause (if (or (neg? arg) (>= arg (count clauses))) - (first (:else params)) - (nth clauses arg))] - (if clause - (execute-sub-format clause navigator (:base-args params)) - navigator))) - -;; ~:[...~] with the colon reads the next argument treating it as a truth value -(defn- boolean-conditional [params arg-navigator offsets] - (let [[arg navigator] (next-arg arg-navigator) - clauses (:clauses params) - clause (if arg - (second clauses) - (first clauses))] - (if clause - (execute-sub-format clause navigator (:base-args params)) - navigator))) - -;; ~@[...~] with the at sign executes the conditional if the next arg is not -;; nil/false without consuming the arg -(defn- check-arg-conditional [params arg-navigator offsets] - (let [[arg navigator] (next-arg arg-navigator) - clauses (:clauses params) - clause (if arg (first clauses))] - (if arg - (if clause - (execute-sub-format clause arg-navigator (:base-args params)) - arg-navigator) - navigator))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for the '~{...~}' iteration construct in its -;;; different flavors -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;; ~{...~} without any modifiers uses the next argument as an argument list that -;; is consumed by all the iterations -(defn- iterate-sublist [params navigator offsets] - (let [max-count (:max-iterations params) - param-clause (first (:clauses params)) - [clause navigator] (if (empty? param-clause) - (get-format-arg navigator) - [param-clause navigator]) - [arg-list navigator] (next-arg navigator) - args (init-navigator arg-list)] - (loop [count 0 - args args - last-pos -1] - (if (and (not max-count) (= (:pos args) last-pos) (> count 1)) - ;; TODO get the offset in here and call format exception - (throw (RuntimeException. "%{ construct not consuming any arguments: Infinite loop!"))) - (if (or (and (empty? (:rest args)) - (or (not (:colon (:right-params params))) (> count 0))) - (and max-count (>= count max-count))) - navigator - (let [iter-result (execute-sub-format clause args (:base-args params))] - (if (= :up-arrow (first iter-result)) - navigator - (recur (inc count) iter-result (:pos args)))))))) - -;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the -;; sublists is used as the arglist for a single iteration. -(defn- iterate-list-of-sublists [params navigator offsets] - (let [max-count (:max-iterations params) - param-clause (first (:clauses params)) - [clause navigator] (if (empty? param-clause) - (get-format-arg navigator) - [param-clause navigator]) - [arg-list navigator] (next-arg navigator)] - (loop [count 0 - arg-list arg-list] - (if (or (and (empty? arg-list) - (or (not (:colon (:right-params params))) (> count 0))) - (and max-count (>= count max-count))) - navigator - (let [iter-result (execute-sub-format - clause - (init-navigator (first arg-list)) - (init-navigator (next arg-list)))] - (if (= :colon-up-arrow (first iter-result)) - navigator - (recur (inc count) (next arg-list)))))))) - -;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations -;; is consumed by all the iterations -(defn- iterate-main-list [params navigator offsets] - (let [max-count (:max-iterations params) - param-clause (first (:clauses params)) - [clause navigator] (if (empty? param-clause) - (get-format-arg navigator) - [param-clause navigator])] - (loop [count 0 - navigator navigator - last-pos -1] - (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1)) - ;; TODO get the offset in here and call format exception - (throw (RuntimeException. "%@{ construct not consuming any arguments: Infinite loop!"))) - (if (or (and (empty? (:rest navigator)) - (or (not (:colon (:right-params params))) (> count 0))) - (and max-count (>= count max-count))) - navigator - (let [iter-result (execute-sub-format clause navigator (:base-args params))] - (if (= :up-arrow (first iter-result)) - (second iter-result) - (recur - (inc count) iter-result (:pos navigator)))))))) - -;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one -;; of which is consumed with each iteration -(defn- iterate-main-sublists [params navigator offsets] - (let [max-count (:max-iterations params) - param-clause (first (:clauses params)) - [clause navigator] (if (empty? param-clause) - (get-format-arg navigator) - [param-clause navigator]) - ] - (loop [count 0 - navigator navigator] - (if (or (and (empty? (:rest navigator)) - (or (not (:colon (:right-params params))) (> count 0))) - (and max-count (>= count max-count))) - navigator - (let [[sublist navigator] (next-arg-or-nil navigator) - iter-result (execute-sub-format clause (init-navigator sublist) navigator)] - (if (= :colon-up-arrow (first iter-result)) - navigator - (recur (inc count) navigator))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The '~< directive has two completely different meanings -;;; in the '~<...~>' form it does justification, but with -;;; ~<...~:>' it represents the logical block operation of the -;;; pretty printer. -;;; -;;; Unfortunately, the current architecture decides what function -;;; to call at form parsing time before the sub-clauses have been -;;; folded, so it is left to run-time to make the decision. -;;; -;;; TODO: make it possible to make these decisions at compile-time. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare format-logical-block) -(declare justify-clauses) - -(defn- logical-block-or-justify [params navigator offsets] - (if (:colon (:right-params params)) - (format-logical-block params navigator offsets) - (justify-clauses params navigator offsets))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for the '~<...~>' justification directive -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- render-clauses [clauses navigator base-navigator] - (loop [clauses clauses - acc [] - navigator navigator] - (if (empty? clauses) - [acc navigator] - (let [clause (first clauses) - [iter-result result-str] (binding [*out* (java.io.StringWriter.)] - [(execute-sub-format clause navigator base-navigator) - (.toString *out*)])] - (if (= :up-arrow (first iter-result)) - [acc (second iter-result)] - (recur (next clauses) (conj acc result-str) iter-result)))))) - -;; TODO support for ~:; constructions -(defn- justify-clauses [params navigator offsets] - (let [[[eol-str] new-navigator] (when-let [else (:else params)] - (render-clauses else navigator (:base-args params))) - navigator (or new-navigator navigator) - [else-params new-navigator] (when-let [p (:else-params params)] - (realize-parameter-list p navigator)) - navigator (or new-navigator navigator) - min-remaining (or (first (:min-remaining else-params)) 0) - max-columns (or (first (:max-columns else-params)) - (.getMaxColumn #^PrettyWriter *out*)) - clauses (:clauses params) - [strs navigator] (render-clauses clauses navigator (:base-args params)) - slots (max 1 - (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0))) - chars (reduce + (map count strs)) - mincol (:mincol params) - minpad (:minpad params) - colinc (:colinc params) - minout (+ chars (* slots minpad)) - result-columns (if (<= minout mincol) - mincol - (+ mincol (* colinc - (+ 1 (quot (- minout mincol 1) colinc))))) - total-pad (- result-columns chars) - pad (max minpad (quot total-pad slots)) - extra-pad (- total-pad (* pad slots)) - pad-str (apply str (repeat pad (:padchar params)))] - (if (and eol-str (> (+ (.getColumn #^PrettyWriter *out*) min-remaining result-columns) - max-columns)) - (print eol-str)) - (loop [slots slots - extra-pad extra-pad - strs strs - pad-only (or (:colon params) - (and (= (count strs) 1) (not (:at params))))] - (if (seq strs) - (do - (print (str (if (not pad-only) (first strs)) - (if (or pad-only (next strs) (:at params)) pad-str) - (if (pos? extra-pad) (:padchar params)))) - (recur - (dec slots) - (dec extra-pad) - (if pad-only strs (next strs)) - false)))) - navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for case modification with ~(...~). -;;; We do this by wrapping the underlying writer with -;;; a special writer to do the appropriate modification. This -;;; allows us to support arbitrary-sized output and sources -;;; that may block. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- downcase-writer - "Returns a proxy that wraps writer, converting all characters to lower case" - [#^java.io.Writer writer] - (proxy [java.io.Writer] [] - (close [] (.close writer)) - (flush [] (.flush writer)) - (write ([#^chars cbuf #^Integer off #^Integer len] - (.write writer cbuf off len)) - ([x] - (condp = (class x) - String - (let [s #^String x] - (.write writer (.toLowerCase s))) - - Integer - (let [c #^Character x] - (.write writer (int (Character/toLowerCase (char c)))))))))) - -(defn- upcase-writer - "Returns a proxy that wraps writer, converting all characters to upper case" - [#^java.io.Writer writer] - (proxy [java.io.Writer] [] - (close [] (.close writer)) - (flush [] (.flush writer)) - (write ([#^chars cbuf #^Integer off #^Integer len] - (.write writer cbuf off len)) - ([x] - (condp = (class x) - String - (let [s #^String x] - (.write writer (.toUpperCase s))) - - Integer - (let [c #^Character x] - (.write writer (int (Character/toUpperCase (char c)))))))))) - -(defn- capitalize-string - "Capitalizes the words in a string. If first? is false, don't capitalize the - first character of the string even if it's a letter." - [s first?] - (let [#^Character f (first s) - s (if (and first? f (Character/isLetter f)) - (str (Character/toUpperCase f) (subs s 1)) - s)] - (apply str - (first - (consume - (fn [s] - (if (empty? s) - [nil nil] - (let [m (re-matcher #"\W\w" s) - match (re-find m) - offset (and match (inc (.start m)))] - (if offset - [(str (subs s 0 offset) - (Character/toUpperCase #^Character (nth s offset))) - (subs s (inc offset))] - [s nil])))) - s))))) - -(defn- capitalize-word-writer - "Returns a proxy that wraps writer, captializing all words" - [#^java.io.Writer writer] - (let [last-was-whitespace? (ref true)] - (proxy [java.io.Writer] [] - (close [] (.close writer)) - (flush [] (.flush writer)) - (write - ([#^chars cbuf #^Integer off #^Integer len] - (.write writer cbuf off len)) - ([x] - (condp = (class x) - String - (let [s #^String x] - (.write writer - #^String (capitalize-string (.toLowerCase s) @last-was-whitespace?)) - (dosync - (ref-set last-was-whitespace? - (Character/isWhitespace - #^Character (nth s (dec (count s))))))) - - Integer - (let [c (char x)] - (let [mod-c (if @last-was-whitespace? (Character/toUpperCase #^Character (char x)) c)] - (.write writer (int mod-c)) - (dosync (ref-set last-was-whitespace? (Character/isWhitespace #^Character (char x)))))))))))) - -(defn- init-cap-writer - "Returns a proxy that wraps writer, capitalizing the first word" - [#^java.io.Writer writer] - (let [capped (ref false)] - (proxy [java.io.Writer] [] - (close [] (.close writer)) - (flush [] (.flush writer)) - (write ([#^chars cbuf #^Integer off #^Integer len] - (.write writer cbuf off len)) - ([x] - (condp = (class x) - String - (let [s (.toLowerCase #^String x)] - (if (not @capped) - (let [m (re-matcher #"\S" s) - match (re-find m) - offset (and match (.start m))] - (if offset - (do (.write writer - (str (subs s 0 offset) - (Character/toUpperCase #^Character (nth s offset)) - (.toLowerCase #^String (subs s (inc offset))))) - (dosync (ref-set capped true))) - (.write writer s))) - (.write writer (.toLowerCase s)))) - - Integer - (let [c #^Character (char x)] - (if (and (not @capped) (Character/isLetter c)) - (do - (dosync (ref-set capped true)) - (.write writer (int (Character/toUpperCase c)))) - (.write writer (int (Character/toLowerCase c))))))))))) - -(defn- modify-case [make-writer params navigator offsets] - (let [clause (first (:clauses params))] - (binding [*out* (make-writer *out*)] - (execute-sub-format clause navigator (:base-args params))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; If necessary, wrap the writer in a PrettyWriter object -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn pretty-writer [writer] - (if (instance? PrettyWriter writer) - writer - (PrettyWriter. writer *print-right-margin* *print-miser-width*))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for column-aware operations ~&, ~T -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO: make an automatic newline for non-ColumnWriters -(defn fresh-line - "Make a newline if the Writer is not already at the beginning of the line. -N.B. Only works on ColumnWriters right now." - [] - (if (not (= 0 (.getColumn #^PrettyWriter *out*))) - (prn))) - -(defn- absolute-tabulation [params navigator offsets] - (let [colnum (:colnum params) - colinc (:colinc params) - current (.getColumn #^PrettyWriter *out*) - space-count (cond - (< current colnum) (- colnum current) - (= colinc 0) 0 - :else (- colinc (rem (- current colnum) colinc)))] - (print (apply str (repeat space-count \space)))) - navigator) - -(defn- relative-tabulation [params navigator offsets] - (let [colrel (:colnum params) - colinc (:colinc params) - start-col (+ colrel (.getColumn #^PrettyWriter *out*)) - offset (if (pos? colinc) (rem start-col colinc) 0) - space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))] - (print (apply str (repeat space-count \space)))) - navigator) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for accessing the pretty printer from a format -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO: support ~@; per-line-prefix separator -;; TODO: get the whole format wrapped so we can start the lb at any column -(defn- format-logical-block [params navigator offsets] - (let [clauses (:clauses params) - clause-count (count clauses) - prefix (cond - (> clause-count 1) (:string (:params (first (first clauses)))) - (:colon params) "(") - body (nth clauses (if (> clause-count 1) 1 0)) - suffix (cond - (> clause-count 2) (:string (:params (first (nth clauses 2)))) - (:colon params) ")") - [arg navigator] (next-arg navigator)] - (pprint-logical-block :prefix prefix :suffix suffix - (execute-sub-format - body - (init-navigator arg) - (:base-args params))) - navigator)) - -(defn- set-indent [params navigator offsets] - (let [relative-to (if (:colon params) :current :block)] - (pprint-indent relative-to (:n params)) - navigator)) - -;;; TODO: support ~:T section options for ~T - -(defn- conditional-newline [params navigator offsets] - (let [kind (if (:colon params) - (if (:at params) :mandatory :fill) - (if (:at params) :miser :linear))] - (pprint-newline kind) - navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The table of directives we support, each with its params, -;;; properties, and the compilation function -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; We start with a couple of helpers -(defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ] - [char, - {:directive char, - :params `(array-map ~@params), - :flags flags, - :bracket-info bracket-info, - :generator-fn (concat '(fn [ params offset]) generator-fn) }]) - -(defmacro #^{:private true} - defdirectives - [ & directives ] - `(def #^{:private true} - directive-table (hash-map ~@(mapcat process-directive-table-element directives)))) - -(defdirectives - (\A - [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] - #{ :at :colon :both} {} - #(format-ascii print-str %1 %2 %3)) - - (\S - [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] - #{ :at :colon :both} {} - #(format-ascii pr-str %1 %2 %3)) - - (\D - [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] - :commainterval [ 3 Integer]] - #{ :at :colon :both } {} - #(format-integer 10 %1 %2 %3)) - - (\B - [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] - :commainterval [ 3 Integer]] - #{ :at :colon :both } {} - #(format-integer 2 %1 %2 %3)) - - (\O - [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] - :commainterval [ 3 Integer]] - #{ :at :colon :both } {} - #(format-integer 8 %1 %2 %3)) - - (\X - [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] - :commainterval [ 3 Integer]] - #{ :at :colon :both } {} - #(format-integer 16 %1 %2 %3)) - - (\R - [:base [nil Integer] :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] - :commainterval [ 3 Integer]] - #{ :at :colon :both } {} - (do - (cond ; ~R is overloaded with bizareness - (first (:base params)) #(format-integer (:base %1) %1 %2 %3) - (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3) - (:at params) #(format-new-roman %1 %2 %3) - (:colon params) #(format-ordinal-english %1 %2 %3) - true #(format-cardinal-english %1 %2 %3)))) - - (\P - [ ] - #{ :at :colon :both } {} - (fn [params navigator offsets] - (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator) - strs (if (:at params) ["y" "ies"] ["" "s"]) - [arg navigator] (next-arg navigator)] - (print (if (= arg 1) (first strs) (second strs))) - navigator))) - - (\C - [:char-format [nil Character]] - #{ :at :colon :both } {} - (cond - (:colon params) pretty-character - (:at params) readable-character - :else plain-character)) - - (\F - [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character] - :padchar [\space Character] ] - #{ :at } {} - fixed-float) - - (\E - [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] - :overflowchar [nil Character] :padchar [\space Character] - :exponentchar [nil Character] ] - #{ :at } {} - exponential-float) - - (\G - [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] - :overflowchar [nil Character] :padchar [\space Character] - :exponentchar [nil Character] ] - #{ :at } {} - general-float) - - (\$ - [ :d [2 Integer] :n [1 Integer] :w [0 Integer] :padchar [\space Character]] - #{ :at :colon :both} {} - dollar-float) - - (\% - [ :count [1 Integer] ] - #{ } {} - (fn [params arg-navigator offsets] - (dotimes [i (:count params)] - (prn)) - arg-navigator)) - - (\& - [ :count [1 Integer] ] - #{ :pretty } {} - (fn [params arg-navigator offsets] - (let [cnt (:count params)] - (if (pos? cnt) (fresh-line)) - (dotimes [i (dec cnt)] - (prn))) - arg-navigator)) - - (\| - [ :count [1 Integer] ] - #{ } {} - (fn [params arg-navigator offsets] - (dotimes [i (:count params)] - (print \formfeed)) - arg-navigator)) - - (\~ - [ :n [1 Integer] ] - #{ } {} - (fn [params arg-navigator offsets] - (let [n (:n params)] - (print (apply str (repeat n \~))) - arg-navigator))) - - (\newline ;; Whitespace supression is handled in the compilation loop - [ ] - #{:colon :at} {} - (fn [params arg-navigator offsets] - (if (:at params) - (prn)) - arg-navigator)) - - (\T - [ :colnum [1 Integer] :colinc [1 Integer] ] - #{ :at :pretty } {} - (if (:at params) - #(relative-tabulation %1 %2 %3) - #(absolute-tabulation %1 %2 %3))) - - (\* - [ :n [1 Integer] ] - #{ :colon :at } {} - (fn [params navigator offsets] - (let [n (:n params)] - (if (:at params) - (absolute-reposition navigator n) - (relative-reposition navigator (if (:colon params) (- n) n))) - ))) - - (\? - [ ] - #{ :at } {} - (if (:at params) - (fn [params navigator offsets] ; args from main arg list - (let [[subformat navigator] (get-format-arg navigator)] - (execute-sub-format subformat navigator (:base-args params)))) - (fn [params navigator offsets] ; args from sub-list - (let [[subformat navigator] (get-format-arg navigator) - [subargs navigator] (next-arg navigator) - sub-navigator (init-navigator subargs)] - (execute-sub-format subformat sub-navigator (:base-args params)) - navigator)))) - - - (\( - [ ] - #{ :colon :at :both} { :right \), :allows-separator nil, :else nil } - (let [mod-case-writer (cond - (and (:at params) (:colon params)) - upcase-writer - - (:colon params) - capitalize-word-writer - - (:at params) - init-cap-writer - - :else - downcase-writer)] - #(modify-case mod-case-writer %1 %2 %3))) - - (\) [] #{} {} nil) - - (\[ - [ :selector [nil Integer] ] - #{ :colon :at } { :right \], :allows-separator true, :else :last } - (cond - (:colon params) - boolean-conditional - - (:at params) - check-arg-conditional - - true - choice-conditional)) - - (\; [:min-remaining [nil Integer] :max-columns [nil Integer]] - #{ :colon } { :separator true } nil) - - (\] [] #{} {} nil) - - (\{ - [ :max-iterations [nil Integer] ] - #{ :colon :at :both} { :right \}, :allows-separator false } - (cond - (and (:at params) (:colon params)) - iterate-main-sublists - - (:colon params) - iterate-list-of-sublists - - (:at params) - iterate-main-list - - true - iterate-sublist)) - - - (\} [] #{:colon} {} nil) - - (\< - [:mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character]] - #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first } - logical-block-or-justify) - - (\> [] #{:colon} {} nil) - - ;; TODO: detect errors in cases where colon not allowed - (\^ [:arg1 [nil Integer] :arg2 [nil Integer] :arg3 [nil Integer]] - #{:colon} {} - (fn [params navigator offsets] - (let [arg1 (:arg1 params) - arg2 (:arg2 params) - arg3 (:arg3 params) - exit (if (:colon params) :colon-up-arrow :up-arrow)] - (cond - (and arg1 arg2 arg3) - (if (<= arg1 arg2 arg3) [exit navigator] navigator) - - (and arg1 arg2) - (if (= arg1 arg2) [exit navigator] navigator) - - arg1 - (if (= arg1 0) [exit navigator] navigator) - - true ; TODO: handle looking up the arglist stack for info - (if (if (:colon params) - (empty? (:rest (:base-args params))) - (empty? (:rest navigator))) - [exit navigator] navigator))))) - - (\W - [] - #{:at :colon :both} {} - (if (or (:at params) (:colon params)) - (let [bindings (concat - (if (:at params) [:level nil :length nil] []) - (if (:colon params) [:pretty true] []))] - (fn [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (apply write arg bindings) - [:up-arrow navigator] - navigator)))) - (fn [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (write-out arg) - [:up-arrow navigator] - navigator))))) - - (\_ - [] - #{:at :colon :both} {} - conditional-newline) - - (\I - [:n [0 Integer]] - #{:colon} {} - set-indent) - ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Code to manage the parameters and flags associated with each -;;; directive in the format string. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def #^{:private true} - param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))") -(def #^{:private true} - special-params #{ :parameter-from-args :remaining-arg-count }) - -(defn- extract-param [[s offset saw-comma]] - (let [m (re-matcher param-pattern s) - param (re-find m)] - (if param - (let [token-str (first (re-groups m)) - remainder (subs s (.end m)) - new-offset (+ offset (.end m))] - (if (not (= \, (nth remainder 0))) - [ [token-str offset] [remainder new-offset false]] - [ [token-str offset] [(subs remainder 1) (inc new-offset) true]])) - (if saw-comma - (format-error "Badly formed parameters in format directive" offset) - [ nil [s offset]])))) - - -(defn- extract-params [s offset] - (consume extract-param [s offset false])) - -(defn- translate-param - "Translate the string representation of a param to the internalized - representation" - [[#^String p offset]] - [(cond - (= (.length p) 0) nil - (and (= (.length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args - (and (= (.length p) 1) (= \# (nth p 0))) :remaining-arg-count - (and (= (.length p) 2) (= \' (nth p 0))) (nth p 1) - true (new Integer p)) - offset]) - -(def #^{:private true} - flag-defs { \: :colon, \@ :at }) - -(defn- extract-flags [s offset] - (consume - (fn [[s offset flags]] - (if (empty? s) - [nil [s offset flags]] - (let [flag (get flag-defs (first s))] - (if flag - (if (contains? flags flag) - (format-error - (str "Flag \"" (first s) "\" appears more than once in a directive") - offset) - [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]]) - [nil [s offset flags]])))) - [s offset {}])) - -(defn- check-flags [def flags] - (let [allowed (:flags def)] - (if (and (not (:at allowed)) (:at flags)) - (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"") - (nth (:at flags) 1))) - (if (and (not (:colon allowed)) (:colon flags)) - (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"") - (nth (:colon flags) 1))) - (if (and (not (:both allowed)) (:at flags) (:colon flags)) - (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \"" - (:directive def) "\"") - (min (nth (:colon flags) 1) (nth (:at flags) 1)))))) - -(defn- map-params - "Takes a directive definition and the list of actual parameters and -a map of flags and returns a map of the parameters and flags with defaults -filled in. We check to make sure that there are the right types and number -of parameters as well." - [def params flags offset] - (check-flags def flags) - (if (> (count params) (count (:params def))) - (format-error - (cl-format - nil - "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed" - (:directive def) (count params) (count (:params def))) - (second (first params)))) - (doall - (map #(let [val (first %1)] - (if (not (or (nil? val) (contains? special-params val) - (instance? (second (second %2)) val))) - (format-error (str "Parameter " (name (first %2)) - " has bad type in directive \"" (:directive def) "\": " - (class val)) - (second %1))) ) - params (:params def))) - - (merge ; create the result map - (into (array-map) ; start with the default values, make sure the order is right - (reverse (for [[name [default]] (:params def)] [name [default offset]]))) - (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils - flags)) ; and finally add the flags - -(defn- compile-directive [s offset] - (let [[raw-params [rest offset]] (extract-params s offset) - [_ [rest offset flags]] (extract-flags rest offset) - directive (first rest) - def (get directive-table (Character/toUpperCase #^Character directive)) - params (if def (map-params def (map translate-param raw-params) flags offset))] - (if (not directive) - (format-error "Format string ended in the middle of a directive" offset)) - (if (not def) - (format-error (str "Directive \"" directive "\" is undefined") offset)) - [(struct compiled-directive ((:generator-fn def) params offset) def params offset) - (let [remainder (subs rest 1) - offset (inc offset) - trim? (and (= \newline (:directive def)) - (not (:colon params))) - trim-count (if trim? (prefix-count remainder [\space \tab]) 0) - remainder (subs remainder trim-count) - offset (+ offset trim-count)] - [remainder offset])])) - -(defn- compile-raw-string [s offset] - (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset)) - -(defn- right-bracket [this] (:right (:bracket-info (:def this)))) -(defn- separator? [this] (:separator (:bracket-info (:def this)))) -(defn- else-separator? [this] - (and (:separator (:bracket-info (:def this))) - (:colon (:params this)))) - - -(declare collect-clauses) - -(defn- process-bracket [this remainder] - (let [[subex remainder] (collect-clauses (:bracket-info (:def this)) - (:offset this) remainder)] - [(struct compiled-directive - (:func this) (:def this) - (merge (:params this) (tuple-map subex (:offset this))) - (:offset this)) - remainder])) - -(defn- process-clause [bracket-info offset remainder] - (consume - (fn [remainder] - (if (empty? remainder) - (format-error "No closing bracket found." offset) - (let [this (first remainder) - remainder (next remainder)] - (cond - (right-bracket this) - (process-bracket this remainder) - - (= (:right bracket-info) (:directive (:def this))) - [ nil [:right-bracket (:params this) nil remainder]] - - (else-separator? this) - [nil [:else nil (:params this) remainder]] - - (separator? this) - [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~; - - true - [this remainder])))) - remainder)) - -(defn- collect-clauses [bracket-info offset remainder] - (second - (consume - (fn [[clause-map saw-else remainder]] - (let [[clause [type right-params else-params remainder]] - (process-clause bracket-info offset remainder)] - (cond - (= type :right-bracket) - [nil [(merge-with concat clause-map - {(if saw-else :else :clauses) [clause] - :right-params right-params}) - remainder]] - - (= type :else) - (cond - (:else clause-map) - (format-error "Two else clauses (\"~:;\") inside bracket construction." offset) - - (not (:else bracket-info)) - (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it." - offset) - - (and (= :first (:else bracket-info)) (seq (:clauses clause-map))) - (format-error - "The else clause (\"~:;\") is only allowed in the first position for this directive." - offset) - - true ; if the ~:; is in the last position, the else clause - ; is next, this was a regular clause - (if (= :first (:else bracket-info)) - [true [(merge-with concat clause-map { :else [clause] :else-params else-params}) - false remainder]] - [true [(merge-with concat clause-map { :clauses [clause] }) - true remainder]])) - - (= type :separator) - (cond - saw-else - (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset) - - (not (:allows-separator bracket-info)) - (format-error "A separator (\"~;\") is in a bracket type that doesn't support it." - offset) - - true - [true [(merge-with concat clause-map { :clauses [clause] }) - false remainder]])))) - [{ :clauses [] } false remainder]))) - -(defn- process-nesting - "Take a linearly compiled format and process the bracket directives to give it - the appropriate tree structure" - [format] - (first - (consume - (fn [remainder] - (let [this (first remainder) - remainder (next remainder) - bracket (:bracket-info (:def this))] - (if (:right bracket) - (process-bracket this remainder) - [this remainder]))) - format))) - -(defn compile-format - "Compiles format-str into a compiled format which can be used as an argument -to cl-format just like a plain format string. Use this function for improved -performance when you're using the same format string repeatedly" - [ format-str ] -; (prlabel compiling format-str) - (binding [*format-str* format-str] - (process-nesting - (first - (consume - (fn [[#^String s offset]] - (if (empty? s) - [nil s] - (let [tilde (.indexOf s (int \~))] - (cond - (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.length s))]] - (zero? tilde) (compile-directive (subs s 1) (inc offset)) - true - [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]])))) - [format-str 0]))))) - -(defn- needs-pretty - "determine whether a given compiled format has any directives that depend on the -column number or pretty printing" - [format] - (loop [format format] - (if (empty? format) - false - (if (or (:pretty (:flags (:def (first format)))) - (some needs-pretty (first (:clauses (:params (first format))))) - (some needs-pretty (first (:else (:params (first format)))))) - true - (recur (next format)))))) - -(defn execute-format - "Executes the format with the arguments. This should never be used directly, but is public -because the formatter macro uses it." - {:skip-wiki true} - ([stream format args] - (let [#^java.io.Writer real-stream (cond - (not stream) (java.io.StringWriter.) - (true? stream) *out* - :else stream) - #^java.io.Writer wrapped-stream (if (and (needs-pretty format) - (not (instance? PrettyWriter real-stream))) - (pretty-writer real-stream) - real-stream)] - (binding [*out* wrapped-stream] - (try - (execute-format format args) - (finally - (if-not (identical? real-stream wrapped-stream) - (.flush wrapped-stream)))) - (if (not stream) (.toString real-stream))))) - ([format args] - (map-passing-context - (fn [element context] - (if (abort? context) - [nil context] - (let [[params args] (realize-parameter-list - (:params element) context) - [params offsets] (unzip-map params) - params (assoc params :base-args args)] - [nil (apply (:func element) [params args offsets])]))) - args - format))) - - -(defmacro formatter - "Makes a function which can directly run format-in. The function is -fn [stream & args] ... and returns nil unless the stream is nil (meaning -output to a string) in which case it returns the resulting string. - -format-in can be either a control string or a previously compiled format." - [format-in] - (let [cf (gensym "compiled-format")] - `(let [format-in# ~format-in] - (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#)) - (fn [stream# & args#] - (let [navigator# (init-navigator args#)] - (execute-format stream# ~cf navigator#))))))) - -(defmacro formatter-out - "Makes a function which can directly run format-in. The function is -fn [& args] ... and returns nil. This version of the formatter macro is -designed to be used with *out* set to an appropriate Writer. In particular, -this is meant to be used as part of a pretty printer dispatch method. - -format-in can be either a control string or a previously compiled format." - [format-in] - (let [cf (gensym "compiled-format")] - `(let [format-in# ~format-in] - (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#)) - (fn [& args#] - (let [navigator# (init-navigator args#)] - (execute-format ~cf navigator#))))))) |