lasercutter: src/clojure/contrib/pprint/cl

comparison src/clojure/contrib/pprint/cl_format.clj @ 10:ef7dbbd6452c

added clojure source goodness

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

comparison

equal deleted inserted replaced

-:35cf337adfcf
+:ef7dbbd6452c
+;;; 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#)))))))

Mercurial > lasercutter

comparison src/clojure/contrib/pprint/cl_format.clj @ 10:ef7dbbd6452c