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