Mercurial > lasercutter
diff 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 |
line wrap: on
line diff
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000 1.2 +++ b/src/clojure/contrib/pprint/cl_format.clj Sat Aug 21 06:25:44 2010 -0400 1.3 @@ -0,0 +1,1844 @@ 1.4 +;;; cl_format.clj -- part of the pretty printer for Clojure 1.5 + 1.6 +;; by Tom Faulhaber 1.7 +;; April 3, 2009 1.8 + 1.9 +; Copyright (c) Tom Faulhaber, Dec 2008. All rights reserved. 1.10 +; The use and distribution terms for this software are covered by the 1.11 +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 1.12 +; which can be found in the file epl-v10.html at the root of this distribution. 1.13 +; By using this software in any fashion, you are agreeing to be bound by 1.14 +; the terms of this license. 1.15 +; You must not remove this notice, or any other, from this software. 1.16 + 1.17 +;; This module implements the Common Lisp compatible format function as documented 1.18 +;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at: 1.19 +;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) 1.20 + 1.21 +(in-ns 'clojure.contrib.pprint) 1.22 + 1.23 +;;; Forward references 1.24 +(declare compile-format) 1.25 +(declare execute-format) 1.26 +(declare init-navigator) 1.27 +;;; End forward references 1.28 + 1.29 +(defn cl-format 1.30 + "An implementation of a Common Lisp compatible format function. cl-format formats its 1.31 +arguments to an output stream or string based on the format control string given. It 1.32 +supports sophisticated formatting of structured data. 1.33 + 1.34 +Writer is an instance of java.io.Writer, true to output to *out* or nil to output 1.35 +to a string, format-in is the format control string and the remaining arguments 1.36 +are the data to be formatted. 1.37 + 1.38 +The format control string is a string to be output with embedded 'format directives' 1.39 +describing how to format the various arguments passed in. 1.40 + 1.41 +If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format 1.42 +returns nil. 1.43 + 1.44 +For example: 1.45 + (let [results [46 38 22]] 1.46 + (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" 1.47 + (count results) results)) 1.48 + 1.49 +Prints to *out*: 1.50 + There are 3 results: 46, 38, 22 1.51 + 1.52 +Detailed documentation on format control strings is available in the \"Common Lisp the 1.53 +Language, 2nd edition\", Chapter 22 (available online at: 1.54 +http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) 1.55 +and in the Common Lisp HyperSpec at 1.56 +http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm 1.57 +" 1.58 + {:see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000" 1.59 + "Common Lisp the Language"] 1.60 + ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm" 1.61 + "Common Lisp HyperSpec"]]} 1.62 + [writer format-in & args] 1.63 + (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) 1.64 + navigator (init-navigator args)] 1.65 + (execute-format writer compiled-format navigator))) 1.66 + 1.67 +(def ^{:private true} *format-str* nil) 1.68 + 1.69 +(defn- format-error [message offset] 1.70 + (let [full-message (str message \newline *format-str* \newline 1.71 + (apply str (repeat offset \space)) "^" \newline)] 1.72 + (throw (RuntimeException. full-message)))) 1.73 + 1.74 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.75 +;;; Argument navigators manage the argument list 1.76 +;;; as the format statement moves through the list 1.77 +;;; (possibly going forwards and backwards as it does so) 1.78 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.79 + 1.80 +(defstruct ^{:private true} 1.81 + arg-navigator :seq :rest :pos ) 1.82 + 1.83 +(defn init-navigator 1.84 + "Create a new arg-navigator from the sequence with the position set to 0" 1.85 + {:skip-wiki true} 1.86 + [s] 1.87 + (let [s (seq s)] 1.88 + (struct arg-navigator s s 0))) 1.89 + 1.90 +;; TODO call format-error with offset 1.91 +(defn- next-arg [ navigator ] 1.92 + (let [ rst (:rest navigator) ] 1.93 + (if rst 1.94 + [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] 1.95 + (throw (new Exception "Not enough arguments for format definition"))))) 1.96 + 1.97 +(defn- next-arg-or-nil [navigator] 1.98 + (let [rst (:rest navigator)] 1.99 + (if rst 1.100 + [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] 1.101 + [nil navigator]))) 1.102 + 1.103 +;; Get an argument off the arg list and compile it if it's not already compiled 1.104 +(defn- get-format-arg [navigator] 1.105 + (let [[raw-format navigator] (next-arg navigator) 1.106 + compiled-format (if (instance? String raw-format) 1.107 + (compile-format raw-format) 1.108 + raw-format)] 1.109 + [compiled-format navigator])) 1.110 + 1.111 +(declare relative-reposition) 1.112 + 1.113 +(defn- absolute-reposition [navigator position] 1.114 + (if (>= position (:pos navigator)) 1.115 + (relative-reposition navigator (- (:pos navigator) position)) 1.116 + (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position))) 1.117 + 1.118 +(defn- relative-reposition [navigator position] 1.119 + (let [newpos (+ (:pos navigator) position)] 1.120 + (if (neg? position) 1.121 + (absolute-reposition navigator newpos) 1.122 + (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos)))) 1.123 + 1.124 +(defstruct ^{:private true} 1.125 + compiled-directive :func :def :params :offset) 1.126 + 1.127 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.128 +;;; When looking at the parameter list, we may need to manipulate 1.129 +;;; the argument list as well (for 'V' and '#' parameter types). 1.130 +;;; We hide all of this behind a function, but clients need to 1.131 +;;; manage changing arg navigator 1.132 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.133 + 1.134 +;; TODO: validate parameters when they come from arg list 1.135 +(defn- realize-parameter [[param [raw-val offset]] navigator] 1.136 + (let [[real-param new-navigator] 1.137 + (cond 1.138 + (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary 1.139 + [raw-val navigator] 1.140 + 1.141 + (= raw-val :parameter-from-args) 1.142 + (next-arg navigator) 1.143 + 1.144 + (= raw-val :remaining-arg-count) 1.145 + [(count (:rest navigator)) navigator] 1.146 + 1.147 + true 1.148 + [raw-val navigator])] 1.149 + [[param [real-param offset]] new-navigator])) 1.150 + 1.151 +(defn- realize-parameter-list [parameter-map navigator] 1.152 + (let [[pairs new-navigator] 1.153 + (map-passing-context realize-parameter navigator parameter-map)] 1.154 + [(into {} pairs) new-navigator])) 1.155 + 1.156 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.157 +;;; Functions that support individual directives 1.158 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.159 + 1.160 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.161 +;;; Common handling code for ~A and ~S 1.162 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.163 + 1.164 +(declare opt-base-str) 1.165 + 1.166 +(def ^{:private true} 1.167 + special-radix-markers {2 "#b" 8 "#o", 16 "#x"}) 1.168 + 1.169 +(defn- format-simple-number [n] 1.170 + (cond 1.171 + (integer? n) (if (= *print-base* 10) 1.172 + (str n (if *print-radix* ".")) 1.173 + (str 1.174 + (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) 1.175 + (opt-base-str *print-base* n))) 1.176 + (ratio? n) (str 1.177 + (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) 1.178 + (opt-base-str *print-base* (.numerator n)) 1.179 + "/" 1.180 + (opt-base-str *print-base* (.denominator n))) 1.181 + :else nil)) 1.182 + 1.183 +(defn- format-ascii [print-func params arg-navigator offsets] 1.184 + (let [ [arg arg-navigator] (next-arg arg-navigator) 1.185 + ^String base-output (or (format-simple-number arg) (print-func arg)) 1.186 + base-width (.length base-output) 1.187 + min-width (+ base-width (:minpad params)) 1.188 + width (if (>= min-width (:mincol params)) 1.189 + min-width 1.190 + (+ min-width 1.191 + (* (+ (quot (- (:mincol params) min-width 1) 1.192 + (:colinc params) ) 1.193 + 1) 1.194 + (:colinc params)))) 1.195 + chars (apply str (repeat (- width base-width) (:padchar params)))] 1.196 + (if (:at params) 1.197 + (print (str chars base-output)) 1.198 + (print (str base-output chars))) 1.199 + arg-navigator)) 1.200 + 1.201 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.202 +;;; Support for the integer directives ~D, ~X, ~O, ~B and some 1.203 +;;; of ~R 1.204 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.205 + 1.206 +(defn- integral? 1.207 + "returns true if a number is actually an integer (that is, has no fractional part)" 1.208 + [x] 1.209 + (cond 1.210 + (integer? x) true 1.211 + (decimal? x) (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part 1.212 + (float? x) (= x (Math/floor x)) 1.213 + (ratio? x) (let [^clojure.lang.Ratio r x] 1.214 + (= 0 (rem (.numerator r) (.denominator r)))) 1.215 + :else false)) 1.216 + 1.217 +(defn- remainders 1.218 + "Return the list of remainders (essentially the 'digits') of val in the given base" 1.219 + [base val] 1.220 + (reverse 1.221 + (first 1.222 + (consume #(if (pos? %) 1.223 + [(rem % base) (quot % base)] 1.224 + [nil nil]) 1.225 + val)))) 1.226 + 1.227 +;;; TODO: xlated-val does not seem to be used here. 1.228 +(defn- base-str 1.229 + "Return val as a string in the given base" 1.230 + [base val] 1.231 + (if (zero? val) 1.232 + "0" 1.233 + (let [xlated-val (cond 1.234 + (float? val) (bigdec val) 1.235 + (ratio? val) (let [^clojure.lang.Ratio r val] 1.236 + (/ (.numerator r) (.denominator r))) 1.237 + :else val)] 1.238 + (apply str 1.239 + (map 1.240 + #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10)))) 1.241 + (remainders base val)))))) 1.242 + 1.243 +(def ^{:private true} 1.244 + java-base-formats {8 "%o", 10 "%d", 16 "%x"}) 1.245 + 1.246 +(defn- opt-base-str 1.247 + "Return val as a string in the given base, using clojure.core/format if supported 1.248 +for improved performance" 1.249 + [base val] 1.250 + (let [format-str (get java-base-formats base)] 1.251 + (if (and format-str (integer? val) (-> val class .getName (.startsWith "java."))) 1.252 + (clojure.core/format format-str val) 1.253 + (base-str base val)))) 1.254 + 1.255 +(defn- group-by* [unit lis] 1.256 + (reverse 1.257 + (first 1.258 + (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis))))) 1.259 + 1.260 +(defn- format-integer [base params arg-navigator offsets] 1.261 + (let [[arg arg-navigator] (next-arg arg-navigator)] 1.262 + (if (integral? arg) 1.263 + (let [neg (neg? arg) 1.264 + pos-arg (if neg (- arg) arg) 1.265 + raw-str (opt-base-str base pos-arg) 1.266 + group-str (if (:colon params) 1.267 + (let [groups (map #(apply str %) (group-by* (:commainterval params) raw-str)) 1.268 + commas (repeat (count groups) (:commachar params))] 1.269 + (apply str (next (interleave commas groups)))) 1.270 + raw-str) 1.271 + ^String signed-str (cond 1.272 + neg (str "-" group-str) 1.273 + (:at params) (str "+" group-str) 1.274 + true group-str) 1.275 + padded-str (if (< (.length signed-str) (:mincol params)) 1.276 + (str (apply str (repeat (- (:mincol params) (.length signed-str)) 1.277 + (:padchar params))) 1.278 + signed-str) 1.279 + signed-str)] 1.280 + (print padded-str)) 1.281 + (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0 1.282 + :padchar (:padchar params) :at true} 1.283 + (init-navigator [arg]) nil)) 1.284 + arg-navigator)) 1.285 + 1.286 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.287 +;;; Support for english formats (~R and ~:R) 1.288 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.289 + 1.290 +(def ^{:private true} 1.291 + english-cardinal-units 1.292 + ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" 1.293 + "ten" "eleven" "twelve" "thirteen" "fourteen" 1.294 + "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"]) 1.295 + 1.296 +(def ^{:private true} 1.297 + english-ordinal-units 1.298 + ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" 1.299 + "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" 1.300 + "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"]) 1.301 + 1.302 +(def ^{:private true} 1.303 + english-cardinal-tens 1.304 + ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"]) 1.305 + 1.306 +(def ^{:private true} 1.307 + english-ordinal-tens 1.308 + ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth" 1.309 + "sixtieth" "seventieth" "eightieth" "ninetieth"]) 1.310 + 1.311 +;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales) 1.312 +;; Number names from http://www.jimloy.com/math/billion.htm 1.313 +;; We follow the rules for writing numbers from the Blue Book 1.314 +;; (http://www.grammarbook.com/numbers/numbers.asp) 1.315 +(def ^{:private true} 1.316 + english-scale-numbers 1.317 + ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" 1.318 + "sextillion" "septillion" "octillion" "nonillion" "decillion" 1.319 + "undecillion" "duodecillion" "tredecillion" "quattuordecillion" 1.320 + "quindecillion" "sexdecillion" "septendecillion" 1.321 + "octodecillion" "novemdecillion" "vigintillion"]) 1.322 + 1.323 +(defn- format-simple-cardinal 1.324 + "Convert a number less than 1000 to a cardinal english string" 1.325 + [num] 1.326 + (let [hundreds (quot num 100) 1.327 + tens (rem num 100)] 1.328 + (str 1.329 + (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) 1.330 + (if (and (pos? hundreds) (pos? tens)) " ") 1.331 + (if (pos? tens) 1.332 + (if (< tens 20) 1.333 + (nth english-cardinal-units tens) 1.334 + (let [ten-digit (quot tens 10) 1.335 + unit-digit (rem tens 10)] 1.336 + (str 1.337 + (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) 1.338 + (if (and (pos? ten-digit) (pos? unit-digit)) "-") 1.339 + (if (pos? unit-digit) (nth english-cardinal-units unit-digit))))))))) 1.340 + 1.341 +(defn- add-english-scales 1.342 + "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string 1.343 +offset is a factor of 10^3 to multiply by" 1.344 + [parts offset] 1.345 + (let [cnt (count parts)] 1.346 + (loop [acc [] 1.347 + pos (dec cnt) 1.348 + this (first parts) 1.349 + remainder (next parts)] 1.350 + (if (nil? remainder) 1.351 + (str (apply str (interpose ", " acc)) 1.352 + (if (and (not (empty? this)) (not (empty? acc))) ", ") 1.353 + this 1.354 + (if (and (not (empty? this)) (pos? (+ pos offset))) 1.355 + (str " " (nth english-scale-numbers (+ pos offset))))) 1.356 + (recur 1.357 + (if (empty? this) 1.358 + acc 1.359 + (conj acc (str this " " (nth english-scale-numbers (+ pos offset))))) 1.360 + (dec pos) 1.361 + (first remainder) 1.362 + (next remainder)))))) 1.363 + 1.364 +(defn- format-cardinal-english [params navigator offsets] 1.365 + (let [[arg navigator] (next-arg navigator)] 1.366 + (if (= 0 arg) 1.367 + (print "zero") 1.368 + (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs 1.369 + parts (remainders 1000 abs-arg)] 1.370 + (if (<= (count parts) (count english-scale-numbers)) 1.371 + (let [parts-strs (map format-simple-cardinal parts) 1.372 + full-str (add-english-scales parts-strs 0)] 1.373 + (print (str (if (neg? arg) "minus ") full-str))) 1.374 + (format-integer ;; for numbers > 10^63, we fall back on ~D 1.375 + 10 1.376 + { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} 1.377 + (init-navigator [arg]) 1.378 + { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})))) 1.379 + navigator)) 1.380 + 1.381 +(defn- format-simple-ordinal 1.382 + "Convert a number less than 1000 to a ordinal english string 1.383 +Note this should only be used for the last one in the sequence" 1.384 + [num] 1.385 + (let [hundreds (quot num 100) 1.386 + tens (rem num 100)] 1.387 + (str 1.388 + (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) 1.389 + (if (and (pos? hundreds) (pos? tens)) " ") 1.390 + (if (pos? tens) 1.391 + (if (< tens 20) 1.392 + (nth english-ordinal-units tens) 1.393 + (let [ten-digit (quot tens 10) 1.394 + unit-digit (rem tens 10)] 1.395 + (if (and (pos? ten-digit) (not (pos? unit-digit))) 1.396 + (nth english-ordinal-tens ten-digit) 1.397 + (str 1.398 + (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) 1.399 + (if (and (pos? ten-digit) (pos? unit-digit)) "-") 1.400 + (if (pos? unit-digit) (nth english-ordinal-units unit-digit)))))) 1.401 + (if (pos? hundreds) "th"))))) 1.402 + 1.403 +(defn- format-ordinal-english [params navigator offsets] 1.404 + (let [[arg navigator] (next-arg navigator)] 1.405 + (if (= 0 arg) 1.406 + (print "zeroth") 1.407 + (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs 1.408 + parts (remainders 1000 abs-arg)] 1.409 + (if (<= (count parts) (count english-scale-numbers)) 1.410 + (let [parts-strs (map format-simple-cardinal (drop-last parts)) 1.411 + head-str (add-english-scales parts-strs 1) 1.412 + tail-str (format-simple-ordinal (last parts))] 1.413 + (print (str (if (neg? arg) "minus ") 1.414 + (cond 1.415 + (and (not (empty? head-str)) (not (empty? tail-str))) 1.416 + (str head-str ", " tail-str) 1.417 + 1.418 + (not (empty? head-str)) (str head-str "th") 1.419 + :else tail-str)))) 1.420 + (do (format-integer ;; for numbers > 10^63, we fall back on ~D 1.421 + 10 1.422 + { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} 1.423 + (init-navigator [arg]) 1.424 + { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}) 1.425 + (let [low-two-digits (rem arg 100) 1.426 + not-teens (or (< 11 low-two-digits) (> 19 low-two-digits)) 1.427 + low-digit (rem low-two-digits 10)] 1.428 + (print (cond 1.429 + (and (== low-digit 1) not-teens) "st" 1.430 + (and (== low-digit 2) not-teens) "nd" 1.431 + (and (== low-digit 3) not-teens) "rd" 1.432 + :else "th"))))))) 1.433 + navigator)) 1.434 + 1.435 + 1.436 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.437 +;;; Support for roman numeral formats (~@R and ~@:R) 1.438 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.439 + 1.440 +(def ^{:private true} 1.441 + old-roman-table 1.442 + [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"] 1.443 + [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"] 1.444 + [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"] 1.445 + [ "M" "MM" "MMM"]]) 1.446 + 1.447 +(def ^{:private true} 1.448 + new-roman-table 1.449 + [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"] 1.450 + [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"] 1.451 + [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"] 1.452 + [ "M" "MM" "MMM"]]) 1.453 + 1.454 +(defn- format-roman 1.455 + "Format a roman numeral using the specified look-up table" 1.456 + [table params navigator offsets] 1.457 + (let [[arg navigator] (next-arg navigator)] 1.458 + (if (and (number? arg) (> arg 0) (< arg 4000)) 1.459 + (let [digits (remainders 10 arg)] 1.460 + (loop [acc [] 1.461 + pos (dec (count digits)) 1.462 + digits digits] 1.463 + (if (empty? digits) 1.464 + (print (apply str acc)) 1.465 + (let [digit (first digits)] 1.466 + (recur (if (= 0 digit) 1.467 + acc 1.468 + (conj acc (nth (nth table pos) (dec digit)))) 1.469 + (dec pos) 1.470 + (next digits)))))) 1.471 + (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D 1.472 + 10 1.473 + { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} 1.474 + (init-navigator [arg]) 1.475 + { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})) 1.476 + navigator)) 1.477 + 1.478 +(defn- format-old-roman [params navigator offsets] 1.479 + (format-roman old-roman-table params navigator offsets)) 1.480 + 1.481 +(defn- format-new-roman [params navigator offsets] 1.482 + (format-roman new-roman-table params navigator offsets)) 1.483 + 1.484 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.485 +;;; Support for character formats (~C) 1.486 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.487 + 1.488 +(def ^{:private true} 1.489 + special-chars { 8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"}) 1.490 + 1.491 +(defn- pretty-character [params navigator offsets] 1.492 + (let [[c navigator] (next-arg navigator) 1.493 + as-int (int c) 1.494 + base-char (bit-and as-int 127) 1.495 + meta (bit-and as-int 128) 1.496 + special (get special-chars base-char)] 1.497 + (if (> meta 0) (print "Meta-")) 1.498 + (print (cond 1.499 + special special 1.500 + (< base-char 32) (str "Control-" (char (+ base-char 64))) 1.501 + (= base-char 127) "Control-?" 1.502 + :else (char base-char))) 1.503 + navigator)) 1.504 + 1.505 +(defn- readable-character [params navigator offsets] 1.506 + (let [[c navigator] (next-arg navigator)] 1.507 + (condp = (:char-format params) 1.508 + \o (cl-format true "\\o~3,'0o" (int c)) 1.509 + \u (cl-format true "\\u~4,'0x" (int c)) 1.510 + nil (pr c)) 1.511 + navigator)) 1.512 + 1.513 +(defn- plain-character [params navigator offsets] 1.514 + (let [[char navigator] (next-arg navigator)] 1.515 + (print char) 1.516 + navigator)) 1.517 + 1.518 +;; Check to see if a result is an abort (~^) construct 1.519 +;; TODO: move these funcs somewhere more appropriate 1.520 +(defn- abort? [context] 1.521 + (let [token (first context)] 1.522 + (or (= :up-arrow token) (= :colon-up-arrow token)))) 1.523 + 1.524 +;; Handle the execution of "sub-clauses" in bracket constructions 1.525 +(defn- execute-sub-format [format args base-args] 1.526 + (second 1.527 + (map-passing-context 1.528 + (fn [element context] 1.529 + (if (abort? context) 1.530 + [nil context] ; just keep passing it along 1.531 + (let [[params args] (realize-parameter-list (:params element) context) 1.532 + [params offsets] (unzip-map params) 1.533 + params (assoc params :base-args base-args)] 1.534 + [nil (apply (:func element) [params args offsets])]))) 1.535 + args 1.536 + format))) 1.537 + 1.538 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.539 +;;; Support for real number formats 1.540 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.541 + 1.542 +;; TODO - return exponent as int to eliminate double conversion 1.543 +(defn- float-parts-base 1.544 + "Produce string parts for the mantissa (normalized 1-9) and exponent" 1.545 + [^Object f] 1.546 + (let [^String s (.toLowerCase (.toString f)) 1.547 + exploc (.indexOf s (int \e))] 1.548 + (if (neg? exploc) 1.549 + (let [dotloc (.indexOf s (int \.))] 1.550 + (if (neg? dotloc) 1.551 + [s (str (dec (count s)))] 1.552 + [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))])) 1.553 + [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))]))) 1.554 + 1.555 + 1.556 +(defn- float-parts 1.557 + "Take care of leading and trailing zeros in decomposed floats" 1.558 + [f] 1.559 + (let [[m ^String e] (float-parts-base f) 1.560 + m1 (rtrim m \0) 1.561 + m2 (ltrim m1 \0) 1.562 + delta (- (count m1) (count m2)) 1.563 + ^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)] 1.564 + (if (empty? m2) 1.565 + ["0" 0] 1.566 + [m2 (- (Integer/valueOf e) delta)]))) 1.567 + 1.568 +(defn- round-str [m e d w] 1.569 + (if (or d w) 1.570 + (let [len (count m) 1.571 + round-pos (if d (+ e d 1)) 1.572 + round-pos (if (and w (< (inc e) (dec w)) 1.573 + (or (nil? round-pos) (< (dec w) round-pos))) 1.574 + (dec w) 1.575 + round-pos) 1.576 + [m1 e1 round-pos len] (if (= round-pos 0) 1.577 + [(str "0" m) (inc e) 1 (inc len)] 1.578 + [m e round-pos len])] 1.579 + (if round-pos 1.580 + (if (neg? round-pos) 1.581 + ["0" 0 false] 1.582 + (if (> len round-pos) 1.583 + (let [round-char (nth m1 round-pos) 1.584 + ^String result (subs m1 0 round-pos)] 1.585 + (if (>= (int round-char) (int \5)) 1.586 + (let [result-val (Integer/valueOf result) 1.587 + leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1))) 1.588 + round-up-result (str leading-zeros 1.589 + (String/valueOf (+ result-val 1.590 + (if (neg? result-val) -1 1)))) 1.591 + expanded (> (count round-up-result) (count result))] 1.592 + [round-up-result e1 expanded]) 1.593 + [result e1 false])) 1.594 + [m e false])) 1.595 + [m e false])) 1.596 + [m e false])) 1.597 + 1.598 +(defn- expand-fixed [m e d] 1.599 + (let [m1 (if (neg? e) (str (apply str (repeat (dec (- e)) \0)) m) m) 1.600 + len (count m1) 1.601 + target-len (if d (+ e d 1) (inc e))] 1.602 + (if (< len target-len) 1.603 + (str m1 (apply str (repeat (- target-len len) \0))) 1.604 + m1))) 1.605 + 1.606 +(defn- insert-decimal 1.607 + "Insert the decimal point at the right spot in the number to match an exponent" 1.608 + [m e] 1.609 + (if (neg? e) 1.610 + (str "." m) 1.611 + (let [loc (inc e)] 1.612 + (str (subs m 0 loc) "." (subs m loc))))) 1.613 + 1.614 +(defn- get-fixed [m e d] 1.615 + (insert-decimal (expand-fixed m e d) e)) 1.616 + 1.617 +(defn- insert-scaled-decimal 1.618 + "Insert the decimal point at the right spot in the number to match an exponent" 1.619 + [m k] 1.620 + (if (neg? k) 1.621 + (str "." m) 1.622 + (str (subs m 0 k) "." (subs m k)))) 1.623 + 1.624 +;; the function to render ~F directives 1.625 +;; TODO: support rationals. Back off to ~D/~A is the appropriate cases 1.626 +(defn- fixed-float [params navigator offsets] 1.627 + (let [w (:w params) 1.628 + d (:d params) 1.629 + [arg navigator] (next-arg navigator) 1.630 + [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg]) 1.631 + [mantissa exp] (float-parts abs) 1.632 + scaled-exp (+ exp (:k params)) 1.633 + add-sign (or (:at params) (neg? arg)) 1.634 + append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp)) 1.635 + [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp 1.636 + d (if w (- w (if add-sign 1 0)))) 1.637 + fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) 1.638 + prepend-zero (= (first fixed-repr) \.)] 1.639 + (if w 1.640 + (let [len (count fixed-repr) 1.641 + signed-len (if add-sign (inc len) len) 1.642 + prepend-zero (and prepend-zero (not (>= signed-len w))) 1.643 + append-zero (and append-zero (not (>= signed-len w))) 1.644 + full-len (if (or prepend-zero append-zero) 1.645 + (inc signed-len) 1.646 + signed-len)] 1.647 + (if (and (> full-len w) (:overflowchar params)) 1.648 + (print (apply str (repeat w (:overflowchar params)))) 1.649 + (print (str 1.650 + (apply str (repeat (- w full-len) (:padchar params))) 1.651 + (if add-sign sign) 1.652 + (if prepend-zero "0") 1.653 + fixed-repr 1.654 + (if append-zero "0"))))) 1.655 + (print (str 1.656 + (if add-sign sign) 1.657 + (if prepend-zero "0") 1.658 + fixed-repr 1.659 + (if append-zero "0")))) 1.660 + navigator)) 1.661 + 1.662 + 1.663 +;; the function to render ~E directives 1.664 +;; TODO: support rationals. Back off to ~D/~A is the appropriate cases 1.665 +;; TODO: define ~E representation for Infinity 1.666 +(defn- exponential-float [params navigator offsets] 1.667 + (let [[arg navigator] (next-arg navigator)] 1.668 + (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))] 1.669 + (let [w (:w params) 1.670 + d (:d params) 1.671 + e (:e params) 1.672 + k (:k params) 1.673 + expchar (or (:exponentchar params) \E) 1.674 + add-sign (or (:at params) (neg? arg)) 1.675 + prepend-zero (<= k 0) 1.676 + ^Integer scaled-exp (- exp (dec k)) 1.677 + scaled-exp-str (str (Math/abs scaled-exp)) 1.678 + scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+) 1.679 + (if e (apply str 1.680 + (repeat 1.681 + (- e 1.682 + (count scaled-exp-str)) 1.683 + \0))) 1.684 + scaled-exp-str) 1.685 + exp-width (count scaled-exp-str) 1.686 + base-mantissa-width (count mantissa) 1.687 + scaled-mantissa (str (apply str (repeat (- k) \0)) 1.688 + mantissa 1.689 + (if d 1.690 + (apply str 1.691 + (repeat 1.692 + (- d (dec base-mantissa-width) 1.693 + (if (neg? k) (- k) 0)) \0)))) 1.694 + w-mantissa (if w (- w exp-width)) 1.695 + [rounded-mantissa _ incr-exp] (round-str 1.696 + scaled-mantissa 0 1.697 + (cond 1.698 + (= k 0) (dec d) 1.699 + (pos? k) d 1.700 + (neg? k) (dec d)) 1.701 + (if w-mantissa 1.702 + (- w-mantissa (if add-sign 1 0)))) 1.703 + full-mantissa (insert-scaled-decimal rounded-mantissa k) 1.704 + append-zero (and (= k (count rounded-mantissa)) (nil? d))] 1.705 + (if (not incr-exp) 1.706 + (if w 1.707 + (let [len (+ (count full-mantissa) exp-width) 1.708 + signed-len (if add-sign (inc len) len) 1.709 + prepend-zero (and prepend-zero (not (= signed-len w))) 1.710 + full-len (if prepend-zero (inc signed-len) signed-len) 1.711 + append-zero (and append-zero (< full-len w))] 1.712 + (if (and (or (> full-len w) (and e (> (- exp-width 2) e))) 1.713 + (:overflowchar params)) 1.714 + (print (apply str (repeat w (:overflowchar params)))) 1.715 + (print (str 1.716 + (apply str 1.717 + (repeat 1.718 + (- w full-len (if append-zero 1 0) ) 1.719 + (:padchar params))) 1.720 + (if add-sign (if (neg? arg) \- \+)) 1.721 + (if prepend-zero "0") 1.722 + full-mantissa 1.723 + (if append-zero "0") 1.724 + scaled-exp-str)))) 1.725 + (print (str 1.726 + (if add-sign (if (neg? arg) \- \+)) 1.727 + (if prepend-zero "0") 1.728 + full-mantissa 1.729 + (if append-zero "0") 1.730 + scaled-exp-str))) 1.731 + (recur [rounded-mantissa (inc exp)])))) 1.732 + navigator)) 1.733 + 1.734 +;; the function to render ~G directives 1.735 +;; This just figures out whether to pass the request off to ~F or ~E based 1.736 +;; on the algorithm in CLtL. 1.737 +;; TODO: support rationals. Back off to ~D/~A is the appropriate cases 1.738 +;; TODO: refactor so that float-parts isn't called twice 1.739 +(defn- general-float [params navigator offsets] 1.740 + (let [[arg _] (next-arg navigator) 1.741 + [mantissa exp] (float-parts (if (neg? arg) (- arg) arg)) 1.742 + w (:w params) 1.743 + d (:d params) 1.744 + e (:e params) 1.745 + n (if (= arg 0.0) 0 (inc exp)) 1.746 + ee (if e (+ e 2) 4) 1.747 + ww (if w (- w ee)) 1.748 + d (if d d (max (count mantissa) (min n 7))) 1.749 + dd (- d n)] 1.750 + (if (<= 0 dd d) 1.751 + (let [navigator (fixed-float {:w ww, :d dd, :k 0, 1.752 + :overflowchar (:overflowchar params), 1.753 + :padchar (:padchar params), :at (:at params)} 1.754 + navigator offsets)] 1.755 + (print (apply str (repeat ee \space))) 1.756 + navigator) 1.757 + (exponential-float params navigator offsets)))) 1.758 + 1.759 +;; the function to render ~$ directives 1.760 +;; TODO: support rationals. Back off to ~D/~A is the appropriate cases 1.761 +(defn- dollar-float [params navigator offsets] 1.762 + (let [[^Double arg navigator] (next-arg navigator) 1.763 + [mantissa exp] (float-parts (Math/abs arg)) 1.764 + d (:d params) ; digits after the decimal 1.765 + n (:n params) ; minimum digits before the decimal 1.766 + w (:w params) ; minimum field width 1.767 + add-sign (or (:at params) (neg? arg)) 1.768 + [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil) 1.769 + ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) 1.770 + full-repr (str (apply str (repeat (- n (.indexOf fixed-repr (int \.))) \0)) fixed-repr) 1.771 + full-len (+ (count full-repr) (if add-sign 1 0))] 1.772 + (print (str 1.773 + (if (and (:colon params) add-sign) (if (neg? arg) \- \+)) 1.774 + (apply str (repeat (- w full-len) (:padchar params))) 1.775 + (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+)) 1.776 + full-repr)) 1.777 + navigator)) 1.778 + 1.779 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.780 +;;; Support for the '~[...~]' conditional construct in its 1.781 +;;; different flavors 1.782 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.783 + 1.784 +;; ~[...~] without any modifiers chooses one of the clauses based on the param or 1.785 +;; next argument 1.786 +;; TODO check arg is positive int 1.787 +(defn- choice-conditional [params arg-navigator offsets] 1.788 + (let [arg (:selector params) 1.789 + [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator)) 1.790 + clauses (:clauses params) 1.791 + clause (if (or (neg? arg) (>= arg (count clauses))) 1.792 + (first (:else params)) 1.793 + (nth clauses arg))] 1.794 + (if clause 1.795 + (execute-sub-format clause navigator (:base-args params)) 1.796 + navigator))) 1.797 + 1.798 +;; ~:[...~] with the colon reads the next argument treating it as a truth value 1.799 +(defn- boolean-conditional [params arg-navigator offsets] 1.800 + (let [[arg navigator] (next-arg arg-navigator) 1.801 + clauses (:clauses params) 1.802 + clause (if arg 1.803 + (second clauses) 1.804 + (first clauses))] 1.805 + (if clause 1.806 + (execute-sub-format clause navigator (:base-args params)) 1.807 + navigator))) 1.808 + 1.809 +;; ~@[...~] with the at sign executes the conditional if the next arg is not 1.810 +;; nil/false without consuming the arg 1.811 +(defn- check-arg-conditional [params arg-navigator offsets] 1.812 + (let [[arg navigator] (next-arg arg-navigator) 1.813 + clauses (:clauses params) 1.814 + clause (if arg (first clauses))] 1.815 + (if arg 1.816 + (if clause 1.817 + (execute-sub-format clause arg-navigator (:base-args params)) 1.818 + arg-navigator) 1.819 + navigator))) 1.820 + 1.821 + 1.822 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.823 +;;; Support for the '~{...~}' iteration construct in its 1.824 +;;; different flavors 1.825 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.826 + 1.827 + 1.828 +;; ~{...~} without any modifiers uses the next argument as an argument list that 1.829 +;; is consumed by all the iterations 1.830 +(defn- iterate-sublist [params navigator offsets] 1.831 + (let [max-count (:max-iterations params) 1.832 + param-clause (first (:clauses params)) 1.833 + [clause navigator] (if (empty? param-clause) 1.834 + (get-format-arg navigator) 1.835 + [param-clause navigator]) 1.836 + [arg-list navigator] (next-arg navigator) 1.837 + args (init-navigator arg-list)] 1.838 + (loop [count 0 1.839 + args args 1.840 + last-pos (num -1)] 1.841 + (if (and (not max-count) (= (:pos args) last-pos) (> count 1)) 1.842 + ;; TODO get the offset in here and call format exception 1.843 + (throw (RuntimeException. "%{ construct not consuming any arguments: Infinite loop!"))) 1.844 + (if (or (and (empty? (:rest args)) 1.845 + (or (not (:colon (:right-params params))) (> count 0))) 1.846 + (and max-count (>= count max-count))) 1.847 + navigator 1.848 + (let [iter-result (execute-sub-format clause args (:base-args params))] 1.849 + (if (= :up-arrow (first iter-result)) 1.850 + navigator 1.851 + (recur (inc count) iter-result (:pos args)))))))) 1.852 + 1.853 +;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the 1.854 +;; sublists is used as the arglist for a single iteration. 1.855 +(defn- iterate-list-of-sublists [params navigator offsets] 1.856 + (let [max-count (:max-iterations params) 1.857 + param-clause (first (:clauses params)) 1.858 + [clause navigator] (if (empty? param-clause) 1.859 + (get-format-arg navigator) 1.860 + [param-clause navigator]) 1.861 + [arg-list navigator] (next-arg navigator)] 1.862 + (loop [count 0 1.863 + arg-list arg-list] 1.864 + (if (or (and (empty? arg-list) 1.865 + (or (not (:colon (:right-params params))) (> count 0))) 1.866 + (and max-count (>= count max-count))) 1.867 + navigator 1.868 + (let [iter-result (execute-sub-format 1.869 + clause 1.870 + (init-navigator (first arg-list)) 1.871 + (init-navigator (next arg-list)))] 1.872 + (if (= :colon-up-arrow (first iter-result)) 1.873 + navigator 1.874 + (recur (inc count) (next arg-list)))))))) 1.875 + 1.876 +;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations 1.877 +;; is consumed by all the iterations 1.878 +(defn- iterate-main-list [params navigator offsets] 1.879 + (let [max-count (:max-iterations params) 1.880 + param-clause (first (:clauses params)) 1.881 + [clause navigator] (if (empty? param-clause) 1.882 + (get-format-arg navigator) 1.883 + [param-clause navigator])] 1.884 + (loop [count 0 1.885 + navigator navigator 1.886 + last-pos (num -1)] 1.887 + (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1)) 1.888 + ;; TODO get the offset in here and call format exception 1.889 + (throw (RuntimeException. "%@{ construct not consuming any arguments: Infinite loop!"))) 1.890 + (if (or (and (empty? (:rest navigator)) 1.891 + (or (not (:colon (:right-params params))) (> count 0))) 1.892 + (and max-count (>= count max-count))) 1.893 + navigator 1.894 + (let [iter-result (execute-sub-format clause navigator (:base-args params))] 1.895 + (if (= :up-arrow (first iter-result)) 1.896 + (second iter-result) 1.897 + (recur 1.898 + (inc count) iter-result (:pos navigator)))))))) 1.899 + 1.900 +;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one 1.901 +;; of which is consumed with each iteration 1.902 +(defn- iterate-main-sublists [params navigator offsets] 1.903 + (let [max-count (:max-iterations params) 1.904 + param-clause (first (:clauses params)) 1.905 + [clause navigator] (if (empty? param-clause) 1.906 + (get-format-arg navigator) 1.907 + [param-clause navigator]) 1.908 + ] 1.909 + (loop [count 0 1.910 + navigator navigator] 1.911 + (if (or (and (empty? (:rest navigator)) 1.912 + (or (not (:colon (:right-params params))) (> count 0))) 1.913 + (and max-count (>= count max-count))) 1.914 + navigator 1.915 + (let [[sublist navigator] (next-arg-or-nil navigator) 1.916 + iter-result (execute-sub-format clause (init-navigator sublist) navigator)] 1.917 + (if (= :colon-up-arrow (first iter-result)) 1.918 + navigator 1.919 + (recur (inc count) navigator))))))) 1.920 + 1.921 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.922 +;;; The '~< directive has two completely different meanings 1.923 +;;; in the '~<...~>' form it does justification, but with 1.924 +;;; ~<...~:>' it represents the logical block operation of the 1.925 +;;; pretty printer. 1.926 +;;; 1.927 +;;; Unfortunately, the current architecture decides what function 1.928 +;;; to call at form parsing time before the sub-clauses have been 1.929 +;;; folded, so it is left to run-time to make the decision. 1.930 +;;; 1.931 +;;; TODO: make it possible to make these decisions at compile-time. 1.932 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.933 + 1.934 +(declare format-logical-block) 1.935 +(declare justify-clauses) 1.936 + 1.937 +(defn- logical-block-or-justify [params navigator offsets] 1.938 + (if (:colon (:right-params params)) 1.939 + (format-logical-block params navigator offsets) 1.940 + (justify-clauses params navigator offsets))) 1.941 + 1.942 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.943 +;;; Support for the '~<...~>' justification directive 1.944 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.945 + 1.946 +(defn- render-clauses [clauses navigator base-navigator] 1.947 + (loop [clauses clauses 1.948 + acc [] 1.949 + navigator navigator] 1.950 + (if (empty? clauses) 1.951 + [acc navigator] 1.952 + (let [clause (first clauses) 1.953 + [iter-result result-str] (binding [*out* (java.io.StringWriter.)] 1.954 + [(execute-sub-format clause navigator base-navigator) 1.955 + (.toString *out*)])] 1.956 + (if (= :up-arrow (first iter-result)) 1.957 + [acc (second iter-result)] 1.958 + (recur (next clauses) (conj acc result-str) iter-result)))))) 1.959 + 1.960 +;; TODO support for ~:; constructions 1.961 +(defn- justify-clauses [params navigator offsets] 1.962 + (let [[[eol-str] new-navigator] (when-let [else (:else params)] 1.963 + (render-clauses else navigator (:base-args params))) 1.964 + navigator (or new-navigator navigator) 1.965 + [else-params new-navigator] (when-let [p (:else-params params)] 1.966 + (realize-parameter-list p navigator)) 1.967 + navigator (or new-navigator navigator) 1.968 + min-remaining (or (first (:min-remaining else-params)) 0) 1.969 + max-columns (or (first (:max-columns else-params)) 1.970 + (get-max-column *out*)) 1.971 + clauses (:clauses params) 1.972 + [strs navigator] (render-clauses clauses navigator (:base-args params)) 1.973 + slots (max 1 1.974 + (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0))) 1.975 + chars (reduce + (map count strs)) 1.976 + mincol (:mincol params) 1.977 + minpad (:minpad params) 1.978 + colinc (:colinc params) 1.979 + minout (+ chars (* slots minpad)) 1.980 + result-columns (if (<= minout mincol) 1.981 + mincol 1.982 + (+ mincol (* colinc 1.983 + (+ 1 (quot (- minout mincol 1) colinc))))) 1.984 + total-pad (- result-columns chars) 1.985 + pad (max minpad (quot total-pad slots)) 1.986 + extra-pad (- total-pad (* pad slots)) 1.987 + pad-str (apply str (repeat pad (:padchar params)))] 1.988 + (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns) 1.989 + max-columns)) 1.990 + (print eol-str)) 1.991 + (loop [slots slots 1.992 + extra-pad extra-pad 1.993 + strs strs 1.994 + pad-only (or (:colon params) 1.995 + (and (= (count strs) 1) (not (:at params))))] 1.996 + (if (seq strs) 1.997 + (do 1.998 + (print (str (if (not pad-only) (first strs)) 1.999 + (if (or pad-only (next strs) (:at params)) pad-str) 1.1000 + (if (pos? extra-pad) (:padchar params)))) 1.1001 + (recur 1.1002 + (dec slots) 1.1003 + (dec extra-pad) 1.1004 + (if pad-only strs (next strs)) 1.1005 + false)))) 1.1006 + navigator)) 1.1007 + 1.1008 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1009 +;;; Support for case modification with ~(...~). 1.1010 +;;; We do this by wrapping the underlying writer with 1.1011 +;;; a special writer to do the appropriate modification. This 1.1012 +;;; allows us to support arbitrary-sized output and sources 1.1013 +;;; that may block. 1.1014 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1015 + 1.1016 +(defn- downcase-writer 1.1017 + "Returns a proxy that wraps writer, converting all characters to lower case" 1.1018 + [^java.io.Writer writer] 1.1019 + (proxy [java.io.Writer] [] 1.1020 + (close [] (.close writer)) 1.1021 + (flush [] (.flush writer)) 1.1022 + (write ([^chars cbuf ^Integer off ^Integer len] 1.1023 + (.write writer cbuf off len)) 1.1024 + ([x] 1.1025 + (condp = (class x) 1.1026 + String 1.1027 + (let [s ^String x] 1.1028 + (.write writer (.toLowerCase s))) 1.1029 + 1.1030 + Integer 1.1031 + (let [c ^Character x] 1.1032 + (.write writer (int (Character/toLowerCase (char c)))))))))) 1.1033 + 1.1034 +(defn- upcase-writer 1.1035 + "Returns a proxy that wraps writer, converting all characters to upper case" 1.1036 + [^java.io.Writer writer] 1.1037 + (proxy [java.io.Writer] [] 1.1038 + (close [] (.close writer)) 1.1039 + (flush [] (.flush writer)) 1.1040 + (write ([^chars cbuf ^Integer off ^Integer len] 1.1041 + (.write writer cbuf off len)) 1.1042 + ([x] 1.1043 + (condp = (class x) 1.1044 + String 1.1045 + (let [s ^String x] 1.1046 + (.write writer (.toUpperCase s))) 1.1047 + 1.1048 + Integer 1.1049 + (let [c ^Character x] 1.1050 + (.write writer (int (Character/toUpperCase (char c)))))))))) 1.1051 + 1.1052 +(defn- capitalize-string 1.1053 + "Capitalizes the words in a string. If first? is false, don't capitalize the 1.1054 + first character of the string even if it's a letter." 1.1055 + [s first?] 1.1056 + (let [^Character f (first s) 1.1057 + s (if (and first? f (Character/isLetter f)) 1.1058 + (str (Character/toUpperCase f) (subs s 1)) 1.1059 + s)] 1.1060 + (apply str 1.1061 + (first 1.1062 + (consume 1.1063 + (fn [s] 1.1064 + (if (empty? s) 1.1065 + [nil nil] 1.1066 + (let [m (re-matcher #"\W\w" s) 1.1067 + match (re-find m) 1.1068 + offset (and match (inc (.start m)))] 1.1069 + (if offset 1.1070 + [(str (subs s 0 offset) 1.1071 + (Character/toUpperCase ^Character (nth s offset))) 1.1072 + (subs s (inc offset))] 1.1073 + [s nil])))) 1.1074 + s))))) 1.1075 + 1.1076 +(defn- capitalize-word-writer 1.1077 + "Returns a proxy that wraps writer, captializing all words" 1.1078 + [^java.io.Writer writer] 1.1079 + (let [last-was-whitespace? (ref true)] 1.1080 + (proxy [java.io.Writer] [] 1.1081 + (close [] (.close writer)) 1.1082 + (flush [] (.flush writer)) 1.1083 + (write 1.1084 + ([^chars cbuf ^Integer off ^Integer len] 1.1085 + (.write writer cbuf off len)) 1.1086 + ([x] 1.1087 + (condp = (class x) 1.1088 + String 1.1089 + (let [s ^String x] 1.1090 + (.write writer 1.1091 + ^String (capitalize-string (.toLowerCase s) @last-was-whitespace?)) 1.1092 + (dosync 1.1093 + (ref-set last-was-whitespace? 1.1094 + (Character/isWhitespace 1.1095 + ^Character (nth s (dec (count s))))))) 1.1096 + 1.1097 + Integer 1.1098 + (let [c (char x)] 1.1099 + (let [mod-c (if @last-was-whitespace? (Character/toUpperCase ^Character (char x)) c)] 1.1100 + (.write writer (int mod-c)) 1.1101 + (dosync (ref-set last-was-whitespace? (Character/isWhitespace ^Character (char x)))))))))))) 1.1102 + 1.1103 +(defn- init-cap-writer 1.1104 + "Returns a proxy that wraps writer, capitalizing the first word" 1.1105 + [^java.io.Writer writer] 1.1106 + (let [capped (ref false)] 1.1107 + (proxy [java.io.Writer] [] 1.1108 + (close [] (.close writer)) 1.1109 + (flush [] (.flush writer)) 1.1110 + (write ([^chars cbuf ^Integer off ^Integer len] 1.1111 + (.write writer cbuf off len)) 1.1112 + ([x] 1.1113 + (condp = (class x) 1.1114 + String 1.1115 + (let [s (.toLowerCase ^String x)] 1.1116 + (if (not @capped) 1.1117 + (let [m (re-matcher #"\S" s) 1.1118 + match (re-find m) 1.1119 + offset (and match (.start m))] 1.1120 + (if offset 1.1121 + (do (.write writer 1.1122 + (str (subs s 0 offset) 1.1123 + (Character/toUpperCase ^Character (nth s offset)) 1.1124 + (.toLowerCase ^String (subs s (inc offset))))) 1.1125 + (dosync (ref-set capped true))) 1.1126 + (.write writer s))) 1.1127 + (.write writer (.toLowerCase s)))) 1.1128 + 1.1129 + Integer 1.1130 + (let [c ^Character (char x)] 1.1131 + (if (and (not @capped) (Character/isLetter c)) 1.1132 + (do 1.1133 + (dosync (ref-set capped true)) 1.1134 + (.write writer (int (Character/toUpperCase c)))) 1.1135 + (.write writer (int (Character/toLowerCase c))))))))))) 1.1136 + 1.1137 +(defn- modify-case [make-writer params navigator offsets] 1.1138 + (let [clause (first (:clauses params))] 1.1139 + (binding [*out* (make-writer *out*)] 1.1140 + (execute-sub-format clause navigator (:base-args params))))) 1.1141 + 1.1142 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1143 +;;; If necessary, wrap the writer in a PrettyWriter object 1.1144 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1145 + 1.1146 +(defn get-pretty-writer [writer] 1.1147 + (if (pretty-writer? writer) 1.1148 + writer 1.1149 + (pretty-writer writer *print-right-margin* *print-miser-width*))) 1.1150 + 1.1151 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1152 +;;; Support for column-aware operations ~&, ~T 1.1153 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1154 + 1.1155 +;; TODO: make an automatic newline for non-ColumnWriters 1.1156 +(defn fresh-line 1.1157 + "Make a newline if the Writer is not already at the beginning of the line. 1.1158 +N.B. Only works on ColumnWriters right now." 1.1159 + [] 1.1160 + (if (not (= 0 (get-column (:base @@*out*)))) 1.1161 + (prn))) 1.1162 + 1.1163 +(defn- absolute-tabulation [params navigator offsets] 1.1164 + (let [colnum (:colnum params) 1.1165 + colinc (:colinc params) 1.1166 + current (get-column (:base @@*out*)) 1.1167 + space-count (cond 1.1168 + (< current colnum) (- colnum current) 1.1169 + (= colinc 0) 0 1.1170 + :else (- colinc (rem (- current colnum) colinc)))] 1.1171 + (print (apply str (repeat space-count \space)))) 1.1172 + navigator) 1.1173 + 1.1174 +(defn- relative-tabulation [params navigator offsets] 1.1175 + (let [colrel (:colnum params) 1.1176 + colinc (:colinc params) 1.1177 + start-col (+ colrel (get-column (:base @@*out*))) 1.1178 + offset (if (pos? colinc) (rem start-col colinc) 0) 1.1179 + space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))] 1.1180 + (print (apply str (repeat space-count \space)))) 1.1181 + navigator) 1.1182 + 1.1183 + 1.1184 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1185 +;;; Support for accessing the pretty printer from a format 1.1186 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1187 + 1.1188 +;; TODO: support ~@; per-line-prefix separator 1.1189 +;; TODO: get the whole format wrapped so we can start the lb at any column 1.1190 +(defn- format-logical-block [params navigator offsets] 1.1191 + (let [clauses (:clauses params) 1.1192 + clause-count (count clauses) 1.1193 + prefix (cond 1.1194 + (> clause-count 1) (:string (:params (first (first clauses)))) 1.1195 + (:colon params) "(") 1.1196 + body (nth clauses (if (> clause-count 1) 1 0)) 1.1197 + suffix (cond 1.1198 + (> clause-count 2) (:string (:params (first (nth clauses 2)))) 1.1199 + (:colon params) ")") 1.1200 + [arg navigator] (next-arg navigator)] 1.1201 + (pprint-logical-block :prefix prefix :suffix suffix 1.1202 + (execute-sub-format 1.1203 + body 1.1204 + (init-navigator arg) 1.1205 + (:base-args params))) 1.1206 + navigator)) 1.1207 + 1.1208 +(defn- set-indent [params navigator offsets] 1.1209 + (let [relative-to (if (:colon params) :current :block)] 1.1210 + (pprint-indent relative-to (:n params)) 1.1211 + navigator)) 1.1212 + 1.1213 +;;; TODO: support ~:T section options for ~T 1.1214 + 1.1215 +(defn- conditional-newline [params navigator offsets] 1.1216 + (let [kind (if (:colon params) 1.1217 + (if (:at params) :mandatory :fill) 1.1218 + (if (:at params) :miser :linear))] 1.1219 + (pprint-newline kind) 1.1220 + navigator)) 1.1221 + 1.1222 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1223 +;;; The table of directives we support, each with its params, 1.1224 +;;; properties, and the compilation function 1.1225 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1226 + 1.1227 +;; We start with a couple of helpers 1.1228 +(defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ] 1.1229 + [char, 1.1230 + {:directive char, 1.1231 + :params `(array-map ~@params), 1.1232 + :flags flags, 1.1233 + :bracket-info bracket-info, 1.1234 + :generator-fn (concat '(fn [ params offset]) generator-fn) }]) 1.1235 + 1.1236 +(defmacro ^{:private true} 1.1237 + defdirectives 1.1238 + [ & directives ] 1.1239 + `(def ^{:private true} 1.1240 + directive-table (hash-map ~@(mapcat process-directive-table-element directives)))) 1.1241 + 1.1242 +(defdirectives 1.1243 + (\A 1.1244 + [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] 1.1245 + #{ :at :colon :both} {} 1.1246 + #(format-ascii print-str %1 %2 %3)) 1.1247 + 1.1248 + (\S 1.1249 + [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] 1.1250 + #{ :at :colon :both} {} 1.1251 + #(format-ascii pr-str %1 %2 %3)) 1.1252 + 1.1253 + (\D 1.1254 + [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 1.1255 + :commainterval [ 3 Integer]] 1.1256 + #{ :at :colon :both } {} 1.1257 + #(format-integer 10 %1 %2 %3)) 1.1258 + 1.1259 + (\B 1.1260 + [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 1.1261 + :commainterval [ 3 Integer]] 1.1262 + #{ :at :colon :both } {} 1.1263 + #(format-integer 2 %1 %2 %3)) 1.1264 + 1.1265 + (\O 1.1266 + [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 1.1267 + :commainterval [ 3 Integer]] 1.1268 + #{ :at :colon :both } {} 1.1269 + #(format-integer 8 %1 %2 %3)) 1.1270 + 1.1271 + (\X 1.1272 + [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 1.1273 + :commainterval [ 3 Integer]] 1.1274 + #{ :at :colon :both } {} 1.1275 + #(format-integer 16 %1 %2 %3)) 1.1276 + 1.1277 + (\R 1.1278 + [:base [nil Integer] :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 1.1279 + :commainterval [ 3 Integer]] 1.1280 + #{ :at :colon :both } {} 1.1281 + (do 1.1282 + (cond ; ~R is overloaded with bizareness 1.1283 + (first (:base params)) #(format-integer (:base %1) %1 %2 %3) 1.1284 + (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3) 1.1285 + (:at params) #(format-new-roman %1 %2 %3) 1.1286 + (:colon params) #(format-ordinal-english %1 %2 %3) 1.1287 + true #(format-cardinal-english %1 %2 %3)))) 1.1288 + 1.1289 + (\P 1.1290 + [ ] 1.1291 + #{ :at :colon :both } {} 1.1292 + (fn [params navigator offsets] 1.1293 + (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator) 1.1294 + strs (if (:at params) ["y" "ies"] ["" "s"]) 1.1295 + [arg navigator] (next-arg navigator)] 1.1296 + (print (if (= arg 1) (first strs) (second strs))) 1.1297 + navigator))) 1.1298 + 1.1299 + (\C 1.1300 + [:char-format [nil Character]] 1.1301 + #{ :at :colon :both } {} 1.1302 + (cond 1.1303 + (:colon params) pretty-character 1.1304 + (:at params) readable-character 1.1305 + :else plain-character)) 1.1306 + 1.1307 + (\F 1.1308 + [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character] 1.1309 + :padchar [\space Character] ] 1.1310 + #{ :at } {} 1.1311 + fixed-float) 1.1312 + 1.1313 + (\E 1.1314 + [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] 1.1315 + :overflowchar [nil Character] :padchar [\space Character] 1.1316 + :exponentchar [nil Character] ] 1.1317 + #{ :at } {} 1.1318 + exponential-float) 1.1319 + 1.1320 + (\G 1.1321 + [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] 1.1322 + :overflowchar [nil Character] :padchar [\space Character] 1.1323 + :exponentchar [nil Character] ] 1.1324 + #{ :at } {} 1.1325 + general-float) 1.1326 + 1.1327 + (\$ 1.1328 + [ :d [2 Integer] :n [1 Integer] :w [0 Integer] :padchar [\space Character]] 1.1329 + #{ :at :colon :both} {} 1.1330 + dollar-float) 1.1331 + 1.1332 + (\% 1.1333 + [ :count [1 Integer] ] 1.1334 + #{ } {} 1.1335 + (fn [params arg-navigator offsets] 1.1336 + (dotimes [i (:count params)] 1.1337 + (prn)) 1.1338 + arg-navigator)) 1.1339 + 1.1340 + (\& 1.1341 + [ :count [1 Integer] ] 1.1342 + #{ :pretty } {} 1.1343 + (fn [params arg-navigator offsets] 1.1344 + (let [cnt (:count params)] 1.1345 + (if (pos? cnt) (fresh-line)) 1.1346 + (dotimes [i (dec cnt)] 1.1347 + (prn))) 1.1348 + arg-navigator)) 1.1349 + 1.1350 + (\| 1.1351 + [ :count [1 Integer] ] 1.1352 + #{ } {} 1.1353 + (fn [params arg-navigator offsets] 1.1354 + (dotimes [i (:count params)] 1.1355 + (print \formfeed)) 1.1356 + arg-navigator)) 1.1357 + 1.1358 + (\~ 1.1359 + [ :n [1 Integer] ] 1.1360 + #{ } {} 1.1361 + (fn [params arg-navigator offsets] 1.1362 + (let [n (:n params)] 1.1363 + (print (apply str (repeat n \~))) 1.1364 + arg-navigator))) 1.1365 + 1.1366 + (\newline ;; Whitespace supression is handled in the compilation loop 1.1367 + [ ] 1.1368 + #{:colon :at} {} 1.1369 + (fn [params arg-navigator offsets] 1.1370 + (if (:at params) 1.1371 + (prn)) 1.1372 + arg-navigator)) 1.1373 + 1.1374 + (\T 1.1375 + [ :colnum [1 Integer] :colinc [1 Integer] ] 1.1376 + #{ :at :pretty } {} 1.1377 + (if (:at params) 1.1378 + #(relative-tabulation %1 %2 %3) 1.1379 + #(absolute-tabulation %1 %2 %3))) 1.1380 + 1.1381 + (\* 1.1382 + [ :n [1 Integer] ] 1.1383 + #{ :colon :at } {} 1.1384 + (fn [params navigator offsets] 1.1385 + (let [n (:n params)] 1.1386 + (if (:at params) 1.1387 + (absolute-reposition navigator n) 1.1388 + (relative-reposition navigator (if (:colon params) (- n) n))) 1.1389 + ))) 1.1390 + 1.1391 + (\? 1.1392 + [ ] 1.1393 + #{ :at } {} 1.1394 + (if (:at params) 1.1395 + (fn [params navigator offsets] ; args from main arg list 1.1396 + (let [[subformat navigator] (get-format-arg navigator)] 1.1397 + (execute-sub-format subformat navigator (:base-args params)))) 1.1398 + (fn [params navigator offsets] ; args from sub-list 1.1399 + (let [[subformat navigator] (get-format-arg navigator) 1.1400 + [subargs navigator] (next-arg navigator) 1.1401 + sub-navigator (init-navigator subargs)] 1.1402 + (execute-sub-format subformat sub-navigator (:base-args params)) 1.1403 + navigator)))) 1.1404 + 1.1405 + 1.1406 + (\( 1.1407 + [ ] 1.1408 + #{ :colon :at :both} { :right \), :allows-separator nil, :else nil } 1.1409 + (let [mod-case-writer (cond 1.1410 + (and (:at params) (:colon params)) 1.1411 + upcase-writer 1.1412 + 1.1413 + (:colon params) 1.1414 + capitalize-word-writer 1.1415 + 1.1416 + (:at params) 1.1417 + init-cap-writer 1.1418 + 1.1419 + :else 1.1420 + downcase-writer)] 1.1421 + #(modify-case mod-case-writer %1 %2 %3))) 1.1422 + 1.1423 + (\) [] #{} {} nil) 1.1424 + 1.1425 + (\[ 1.1426 + [ :selector [nil Integer] ] 1.1427 + #{ :colon :at } { :right \], :allows-separator true, :else :last } 1.1428 + (cond 1.1429 + (:colon params) 1.1430 + boolean-conditional 1.1431 + 1.1432 + (:at params) 1.1433 + check-arg-conditional 1.1434 + 1.1435 + true 1.1436 + choice-conditional)) 1.1437 + 1.1438 + (\; [:min-remaining [nil Integer] :max-columns [nil Integer]] 1.1439 + #{ :colon } { :separator true } nil) 1.1440 + 1.1441 + (\] [] #{} {} nil) 1.1442 + 1.1443 + (\{ 1.1444 + [ :max-iterations [nil Integer] ] 1.1445 + #{ :colon :at :both} { :right \}, :allows-separator false } 1.1446 + (cond 1.1447 + (and (:at params) (:colon params)) 1.1448 + iterate-main-sublists 1.1449 + 1.1450 + (:colon params) 1.1451 + iterate-list-of-sublists 1.1452 + 1.1453 + (:at params) 1.1454 + iterate-main-list 1.1455 + 1.1456 + true 1.1457 + iterate-sublist)) 1.1458 + 1.1459 + 1.1460 + (\} [] #{:colon} {} nil) 1.1461 + 1.1462 + (\< 1.1463 + [:mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character]] 1.1464 + #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first } 1.1465 + logical-block-or-justify) 1.1466 + 1.1467 + (\> [] #{:colon} {} nil) 1.1468 + 1.1469 + ;; TODO: detect errors in cases where colon not allowed 1.1470 + (\^ [:arg1 [nil Integer] :arg2 [nil Integer] :arg3 [nil Integer]] 1.1471 + #{:colon} {} 1.1472 + (fn [params navigator offsets] 1.1473 + (let [arg1 (:arg1 params) 1.1474 + arg2 (:arg2 params) 1.1475 + arg3 (:arg3 params) 1.1476 + exit (if (:colon params) :colon-up-arrow :up-arrow)] 1.1477 + (cond 1.1478 + (and arg1 arg2 arg3) 1.1479 + (if (<= arg1 arg2 arg3) [exit navigator] navigator) 1.1480 + 1.1481 + (and arg1 arg2) 1.1482 + (if (= arg1 arg2) [exit navigator] navigator) 1.1483 + 1.1484 + arg1 1.1485 + (if (= arg1 0) [exit navigator] navigator) 1.1486 + 1.1487 + true ; TODO: handle looking up the arglist stack for info 1.1488 + (if (if (:colon params) 1.1489 + (empty? (:rest (:base-args params))) 1.1490 + (empty? (:rest navigator))) 1.1491 + [exit navigator] navigator))))) 1.1492 + 1.1493 + (\W 1.1494 + [] 1.1495 + #{:at :colon :both} {} 1.1496 + (if (or (:at params) (:colon params)) 1.1497 + (let [bindings (concat 1.1498 + (if (:at params) [:level nil :length nil] []) 1.1499 + (if (:colon params) [:pretty true] []))] 1.1500 + (fn [params navigator offsets] 1.1501 + (let [[arg navigator] (next-arg navigator)] 1.1502 + (if (apply write arg bindings) 1.1503 + [:up-arrow navigator] 1.1504 + navigator)))) 1.1505 + (fn [params navigator offsets] 1.1506 + (let [[arg navigator] (next-arg navigator)] 1.1507 + (if (write-out arg) 1.1508 + [:up-arrow navigator] 1.1509 + navigator))))) 1.1510 + 1.1511 + (\_ 1.1512 + [] 1.1513 + #{:at :colon :both} {} 1.1514 + conditional-newline) 1.1515 + 1.1516 + (\I 1.1517 + [:n [0 Integer]] 1.1518 + #{:colon} {} 1.1519 + set-indent) 1.1520 + ) 1.1521 + 1.1522 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1523 +;;; Code to manage the parameters and flags associated with each 1.1524 +;;; directive in the format string. 1.1525 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1526 + 1.1527 +(def ^{:private true} 1.1528 + param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))") 1.1529 +(def ^{:private true} 1.1530 + special-params #{ :parameter-from-args :remaining-arg-count }) 1.1531 + 1.1532 +(defn- extract-param [[s offset saw-comma]] 1.1533 + (let [m (re-matcher param-pattern s) 1.1534 + param (re-find m)] 1.1535 + (if param 1.1536 + (let [token-str (first (re-groups m)) 1.1537 + remainder (subs s (.end m)) 1.1538 + new-offset (+ offset (.end m))] 1.1539 + (if (not (= \, (nth remainder 0))) 1.1540 + [ [token-str offset] [remainder new-offset false]] 1.1541 + [ [token-str offset] [(subs remainder 1) (inc new-offset) true]])) 1.1542 + (if saw-comma 1.1543 + (format-error "Badly formed parameters in format directive" offset) 1.1544 + [ nil [s offset]])))) 1.1545 + 1.1546 + 1.1547 +(defn- extract-params [s offset] 1.1548 + (consume extract-param [s offset false])) 1.1549 + 1.1550 +(defn- translate-param 1.1551 + "Translate the string representation of a param to the internalized 1.1552 + representation" 1.1553 + [[^String p offset]] 1.1554 + [(cond 1.1555 + (= (.length p) 0) nil 1.1556 + (and (= (.length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args 1.1557 + (and (= (.length p) 1) (= \# (nth p 0))) :remaining-arg-count 1.1558 + (and (= (.length p) 2) (= \' (nth p 0))) (nth p 1) 1.1559 + true (new Integer p)) 1.1560 + offset]) 1.1561 + 1.1562 +(def ^{:private true} 1.1563 + flag-defs { \: :colon, \@ :at }) 1.1564 + 1.1565 +(defn- extract-flags [s offset] 1.1566 + (consume 1.1567 + (fn [[s offset flags]] 1.1568 + (if (empty? s) 1.1569 + [nil [s offset flags]] 1.1570 + (let [flag (get flag-defs (first s))] 1.1571 + (if flag 1.1572 + (if (contains? flags flag) 1.1573 + (format-error 1.1574 + (str "Flag \"" (first s) "\" appears more than once in a directive") 1.1575 + offset) 1.1576 + [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]]) 1.1577 + [nil [s offset flags]])))) 1.1578 + [s offset {}])) 1.1579 + 1.1580 +(defn- check-flags [def flags] 1.1581 + (let [allowed (:flags def)] 1.1582 + (if (and (not (:at allowed)) (:at flags)) 1.1583 + (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"") 1.1584 + (nth (:at flags) 1))) 1.1585 + (if (and (not (:colon allowed)) (:colon flags)) 1.1586 + (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"") 1.1587 + (nth (:colon flags) 1))) 1.1588 + (if (and (not (:both allowed)) (:at flags) (:colon flags)) 1.1589 + (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \"" 1.1590 + (:directive def) "\"") 1.1591 + (min (nth (:colon flags) 1) (nth (:at flags) 1)))))) 1.1592 + 1.1593 +(defn- map-params 1.1594 + "Takes a directive definition and the list of actual parameters and 1.1595 +a map of flags and returns a map of the parameters and flags with defaults 1.1596 +filled in. We check to make sure that there are the right types and number 1.1597 +of parameters as well." 1.1598 + [def params flags offset] 1.1599 + (check-flags def flags) 1.1600 + (if (> (count params) (count (:params def))) 1.1601 + (format-error 1.1602 + (cl-format 1.1603 + nil 1.1604 + "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed" 1.1605 + (:directive def) (count params) (count (:params def))) 1.1606 + (second (first params)))) 1.1607 + (doall 1.1608 + (map #(let [val (first %1)] 1.1609 + (if (not (or (nil? val) (contains? special-params val) 1.1610 + (instance? (second (second %2)) val))) 1.1611 + (format-error (str "Parameter " (name (first %2)) 1.1612 + " has bad type in directive \"" (:directive def) "\": " 1.1613 + (class val)) 1.1614 + (second %1))) ) 1.1615 + params (:params def))) 1.1616 + 1.1617 + (merge ; create the result map 1.1618 + (into (array-map) ; start with the default values, make sure the order is right 1.1619 + (reverse (for [[name [default]] (:params def)] [name [default offset]]))) 1.1620 + (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils 1.1621 + flags)) ; and finally add the flags 1.1622 + 1.1623 +(defn- compile-directive [s offset] 1.1624 + (let [[raw-params [rest offset]] (extract-params s offset) 1.1625 + [_ [rest offset flags]] (extract-flags rest offset) 1.1626 + directive (first rest) 1.1627 + def (get directive-table (Character/toUpperCase ^Character directive)) 1.1628 + params (if def (map-params def (map translate-param raw-params) flags offset))] 1.1629 + (if (not directive) 1.1630 + (format-error "Format string ended in the middle of a directive" offset)) 1.1631 + (if (not def) 1.1632 + (format-error (str "Directive \"" directive "\" is undefined") offset)) 1.1633 + [(struct compiled-directive ((:generator-fn def) params offset) def params offset) 1.1634 + (let [remainder (subs rest 1) 1.1635 + offset (inc offset) 1.1636 + trim? (and (= \newline (:directive def)) 1.1637 + (not (:colon params))) 1.1638 + trim-count (if trim? (prefix-count remainder [\space \tab]) 0) 1.1639 + remainder (subs remainder trim-count) 1.1640 + offset (+ offset trim-count)] 1.1641 + [remainder offset])])) 1.1642 + 1.1643 +(defn- compile-raw-string [s offset] 1.1644 + (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset)) 1.1645 + 1.1646 +(defn- right-bracket [this] (:right (:bracket-info (:def this)))) 1.1647 +(defn- separator? [this] (:separator (:bracket-info (:def this)))) 1.1648 +(defn- else-separator? [this] 1.1649 + (and (:separator (:bracket-info (:def this))) 1.1650 + (:colon (:params this)))) 1.1651 + 1.1652 + 1.1653 +(declare collect-clauses) 1.1654 + 1.1655 +(defn- process-bracket [this remainder] 1.1656 + (let [[subex remainder] (collect-clauses (:bracket-info (:def this)) 1.1657 + (:offset this) remainder)] 1.1658 + [(struct compiled-directive 1.1659 + (:func this) (:def this) 1.1660 + (merge (:params this) (tuple-map subex (:offset this))) 1.1661 + (:offset this)) 1.1662 + remainder])) 1.1663 + 1.1664 +(defn- process-clause [bracket-info offset remainder] 1.1665 + (consume 1.1666 + (fn [remainder] 1.1667 + (if (empty? remainder) 1.1668 + (format-error "No closing bracket found." offset) 1.1669 + (let [this (first remainder) 1.1670 + remainder (next remainder)] 1.1671 + (cond 1.1672 + (right-bracket this) 1.1673 + (process-bracket this remainder) 1.1674 + 1.1675 + (= (:right bracket-info) (:directive (:def this))) 1.1676 + [ nil [:right-bracket (:params this) nil remainder]] 1.1677 + 1.1678 + (else-separator? this) 1.1679 + [nil [:else nil (:params this) remainder]] 1.1680 + 1.1681 + (separator? this) 1.1682 + [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~; 1.1683 + 1.1684 + true 1.1685 + [this remainder])))) 1.1686 + remainder)) 1.1687 + 1.1688 +(defn- collect-clauses [bracket-info offset remainder] 1.1689 + (second 1.1690 + (consume 1.1691 + (fn [[clause-map saw-else remainder]] 1.1692 + (let [[clause [type right-params else-params remainder]] 1.1693 + (process-clause bracket-info offset remainder)] 1.1694 + (cond 1.1695 + (= type :right-bracket) 1.1696 + [nil [(merge-with concat clause-map 1.1697 + {(if saw-else :else :clauses) [clause] 1.1698 + :right-params right-params}) 1.1699 + remainder]] 1.1700 + 1.1701 + (= type :else) 1.1702 + (cond 1.1703 + (:else clause-map) 1.1704 + (format-error "Two else clauses (\"~:;\") inside bracket construction." offset) 1.1705 + 1.1706 + (not (:else bracket-info)) 1.1707 + (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it." 1.1708 + offset) 1.1709 + 1.1710 + (and (= :first (:else bracket-info)) (seq (:clauses clause-map))) 1.1711 + (format-error 1.1712 + "The else clause (\"~:;\") is only allowed in the first position for this directive." 1.1713 + offset) 1.1714 + 1.1715 + true ; if the ~:; is in the last position, the else clause 1.1716 + ; is next, this was a regular clause 1.1717 + (if (= :first (:else bracket-info)) 1.1718 + [true [(merge-with concat clause-map { :else [clause] :else-params else-params}) 1.1719 + false remainder]] 1.1720 + [true [(merge-with concat clause-map { :clauses [clause] }) 1.1721 + true remainder]])) 1.1722 + 1.1723 + (= type :separator) 1.1724 + (cond 1.1725 + saw-else 1.1726 + (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset) 1.1727 + 1.1728 + (not (:allows-separator bracket-info)) 1.1729 + (format-error "A separator (\"~;\") is in a bracket type that doesn't support it." 1.1730 + offset) 1.1731 + 1.1732 + true 1.1733 + [true [(merge-with concat clause-map { :clauses [clause] }) 1.1734 + false remainder]])))) 1.1735 + [{ :clauses [] } false remainder]))) 1.1736 + 1.1737 +(defn- process-nesting 1.1738 + "Take a linearly compiled format and process the bracket directives to give it 1.1739 + the appropriate tree structure" 1.1740 + [format] 1.1741 + (first 1.1742 + (consume 1.1743 + (fn [remainder] 1.1744 + (let [this (first remainder) 1.1745 + remainder (next remainder) 1.1746 + bracket (:bracket-info (:def this))] 1.1747 + (if (:right bracket) 1.1748 + (process-bracket this remainder) 1.1749 + [this remainder]))) 1.1750 + format))) 1.1751 + 1.1752 +(defn compile-format 1.1753 + "Compiles format-str into a compiled format which can be used as an argument 1.1754 +to cl-format just like a plain format string. Use this function for improved 1.1755 +performance when you're using the same format string repeatedly" 1.1756 + [ format-str ] 1.1757 +; (prlabel compiling format-str) 1.1758 + (binding [*format-str* format-str] 1.1759 + (process-nesting 1.1760 + (first 1.1761 + (consume 1.1762 + (fn [[^String s offset]] 1.1763 + (if (empty? s) 1.1764 + [nil s] 1.1765 + (let [tilde (.indexOf s (int \~))] 1.1766 + (cond 1.1767 + (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.length s))]] 1.1768 + (zero? tilde) (compile-directive (subs s 1) (inc offset)) 1.1769 + true 1.1770 + [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]])))) 1.1771 + [format-str 0]))))) 1.1772 + 1.1773 +(defn- needs-pretty 1.1774 + "determine whether a given compiled format has any directives that depend on the 1.1775 +column number or pretty printing" 1.1776 + [format] 1.1777 + (loop [format format] 1.1778 + (if (empty? format) 1.1779 + false 1.1780 + (if (or (:pretty (:flags (:def (first format)))) 1.1781 + (some needs-pretty (first (:clauses (:params (first format))))) 1.1782 + (some needs-pretty (first (:else (:params (first format)))))) 1.1783 + true 1.1784 + (recur (next format)))))) 1.1785 + 1.1786 +(defn execute-format 1.1787 + "Executes the format with the arguments. This should never be used directly, but is public 1.1788 +because the formatter macro uses it." 1.1789 + {:skip-wiki true} 1.1790 + ([stream format args] 1.1791 + (let [^java.io.Writer real-stream (cond 1.1792 + (not stream) (java.io.StringWriter.) 1.1793 + (true? stream) *out* 1.1794 + :else stream) 1.1795 + ^java.io.Writer wrapped-stream (if (and (needs-pretty format) 1.1796 + (not (pretty-writer? real-stream))) 1.1797 + (get-pretty-writer real-stream) 1.1798 + real-stream)] 1.1799 + (binding [*out* wrapped-stream] 1.1800 + (try 1.1801 + (execute-format format args) 1.1802 + (finally 1.1803 + (if-not (identical? real-stream wrapped-stream) 1.1804 + (.flush wrapped-stream)))) 1.1805 + (if (not stream) (.toString real-stream))))) 1.1806 + ([format args] 1.1807 + (map-passing-context 1.1808 + (fn [element context] 1.1809 + (if (abort? context) 1.1810 + [nil context] 1.1811 + (let [[params args] (realize-parameter-list 1.1812 + (:params element) context) 1.1813 + [params offsets] (unzip-map params) 1.1814 + params (assoc params :base-args args)] 1.1815 + [nil (apply (:func element) [params args offsets])]))) 1.1816 + args 1.1817 + format))) 1.1818 + 1.1819 + 1.1820 +(defmacro formatter 1.1821 + "Makes a function which can directly run format-in. The function is 1.1822 +fn [stream & args] ... and returns nil unless the stream is nil (meaning 1.1823 +output to a string) in which case it returns the resulting string. 1.1824 + 1.1825 +format-in can be either a control string or a previously compiled format." 1.1826 + [format-in] 1.1827 + (let [cf (gensym "compiled-format")] 1.1828 + `(let [format-in# ~format-in] 1.1829 + (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#)) 1.1830 + (fn [stream# & args#] 1.1831 + (let [navigator# (init-navigator args#)] 1.1832 + (execute-format stream# ~cf navigator#))))))) 1.1833 + 1.1834 +(defmacro formatter-out 1.1835 + "Makes a function which can directly run format-in. The function is 1.1836 +fn [& args] ... and returns nil. This version of the formatter macro is 1.1837 +designed to be used with *out* set to an appropriate Writer. In particular, 1.1838 +this is meant to be used as part of a pretty printer dispatch method. 1.1839 + 1.1840 +format-in can be either a control string or a previously compiled format." 1.1841 + [format-in] 1.1842 + (let [cf (gensym "compiled-format")] 1.1843 + `(let [format-in# ~format-in] 1.1844 + (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#)) 1.1845 + (fn [& args#] 1.1846 + (let [navigator# (init-navigator args#)] 1.1847 + (execute-format ~cf navigator#)))))))