Mercurial > lasercutter
comparison 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 |
comparison
equal
deleted
inserted
replaced
| 9:35cf337adfcf | 10:ef7dbbd6452c |
|---|---|
| 1 ;;; cl_format.clj -- part of the pretty printer for Clojure | |
| 2 | |
| 3 ; Copyright (c) Rich Hickey. All rights reserved. | |
| 4 ; The use and distribution terms for this software are covered by the | |
| 5 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
| 6 ; which can be found in the file epl-v10.html at the root of this distribution. | |
| 7 ; By using this software in any fashion, you are agreeing to be bound by | |
| 8 ; the terms of this license. | |
| 9 ; You must not remove this notice, or any other, from this software. | |
| 10 | |
| 11 ;; Author: Tom Faulhaber | |
| 12 ;; April 3, 2009 | |
| 13 | |
| 14 | |
| 15 ;; This module implements the Common Lisp compatible format function as documented | |
| 16 ;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at: | |
| 17 ;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) | |
| 18 | |
| 19 (in-ns 'clojure.pprint) | |
| 20 | |
| 21 ;;; Forward references | |
| 22 (declare compile-format) | |
| 23 (declare execute-format) | |
| 24 (declare init-navigator) | |
| 25 ;;; End forward references | |
| 26 | |
| 27 (defn cl-format | |
| 28 "An implementation of a Common Lisp compatible format function. cl-format formats its | |
| 29 arguments to an output stream or string based on the format control string given. It | |
| 30 supports sophisticated formatting of structured data. | |
| 31 | |
| 32 Writer is an instance of java.io.Writer, true to output to *out* or nil to output | |
| 33 to a string, format-in is the format control string and the remaining arguments | |
| 34 are the data to be formatted. | |
| 35 | |
| 36 The format control string is a string to be output with embedded 'format directives' | |
| 37 describing how to format the various arguments passed in. | |
| 38 | |
| 39 If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format | |
| 40 returns nil. | |
| 41 | |
| 42 For example: | |
| 43 (let [results [46 38 22]] | |
| 44 (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" | |
| 45 (count results) results)) | |
| 46 | |
| 47 Prints to *out*: | |
| 48 There are 3 results: 46, 38, 22 | |
| 49 | |
| 50 Detailed documentation on format control strings is available in the \"Common Lisp the | |
| 51 Language, 2nd edition\", Chapter 22 (available online at: | |
| 52 http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) | |
| 53 and in the Common Lisp HyperSpec at | |
| 54 http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm | |
| 55 " | |
| 56 {:added "1.2", | |
| 57 :see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000" | |
| 58 "Common Lisp the Language"] | |
| 59 ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm" | |
| 60 "Common Lisp HyperSpec"]]} | |
| 61 [writer format-in & args] | |
| 62 (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) | |
| 63 navigator (init-navigator args)] | |
| 64 (execute-format writer compiled-format navigator))) | |
| 65 | |
| 66 (def ^{:private true} *format-str* nil) | |
| 67 | |
| 68 (defn- format-error [message offset] | |
| 69 (let [full-message (str message \newline *format-str* \newline | |
| 70 (apply str (repeat offset \space)) "^" \newline)] | |
| 71 (throw (RuntimeException. full-message)))) | |
| 72 | |
| 73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 74 ;;; Argument navigators manage the argument list | |
| 75 ;;; as the format statement moves through the list | |
| 76 ;;; (possibly going forwards and backwards as it does so) | |
| 77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 78 | |
| 79 (defstruct ^{:private true} | |
| 80 arg-navigator :seq :rest :pos ) | |
| 81 | |
| 82 (defn- init-navigator | |
| 83 "Create a new arg-navigator from the sequence with the position set to 0" | |
| 84 {:skip-wiki true} | |
| 85 [s] | |
| 86 (let [s (seq s)] | |
| 87 (struct arg-navigator s s 0))) | |
| 88 | |
| 89 ;; TODO call format-error with offset | |
| 90 (defn- next-arg [ navigator ] | |
| 91 (let [ rst (:rest navigator) ] | |
| 92 (if rst | |
| 93 [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] | |
| 94 (throw (new Exception "Not enough arguments for format definition"))))) | |
| 95 | |
| 96 (defn- next-arg-or-nil [navigator] | |
| 97 (let [rst (:rest navigator)] | |
| 98 (if rst | |
| 99 [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] | |
| 100 [nil navigator]))) | |
| 101 | |
| 102 ;; Get an argument off the arg list and compile it if it's not already compiled | |
| 103 (defn- get-format-arg [navigator] | |
| 104 (let [[raw-format navigator] (next-arg navigator) | |
| 105 compiled-format (if (instance? String raw-format) | |
| 106 (compile-format raw-format) | |
| 107 raw-format)] | |
| 108 [compiled-format navigator])) | |
| 109 | |
| 110 (declare relative-reposition) | |
| 111 | |
| 112 (defn- absolute-reposition [navigator position] | |
| 113 (if (>= position (:pos navigator)) | |
| 114 (relative-reposition navigator (- (:pos navigator) position)) | |
| 115 (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position))) | |
| 116 | |
| 117 (defn- relative-reposition [navigator position] | |
| 118 (let [newpos (+ (:pos navigator) position)] | |
| 119 (if (neg? position) | |
| 120 (absolute-reposition navigator newpos) | |
| 121 (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos)))) | |
| 122 | |
| 123 (defstruct ^{:private true} | |
| 124 compiled-directive :func :def :params :offset) | |
| 125 | |
| 126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 127 ;;; When looking at the parameter list, we may need to manipulate | |
| 128 ;;; the argument list as well (for 'V' and '#' parameter types). | |
| 129 ;;; We hide all of this behind a function, but clients need to | |
| 130 ;;; manage changing arg navigator | |
| 131 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 132 | |
| 133 ;; TODO: validate parameters when they come from arg list | |
| 134 (defn- realize-parameter [[param [raw-val offset]] navigator] | |
| 135 (let [[real-param new-navigator] | |
| 136 (cond | |
| 137 (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary | |
| 138 [raw-val navigator] | |
| 139 | |
| 140 (= raw-val :parameter-from-args) | |
| 141 (next-arg navigator) | |
| 142 | |
| 143 (= raw-val :remaining-arg-count) | |
| 144 [(count (:rest navigator)) navigator] | |
| 145 | |
| 146 true | |
| 147 [raw-val navigator])] | |
| 148 [[param [real-param offset]] new-navigator])) | |
| 149 | |
| 150 (defn- realize-parameter-list [parameter-map navigator] | |
| 151 (let [[pairs new-navigator] | |
| 152 (map-passing-context realize-parameter navigator parameter-map)] | |
| 153 [(into {} pairs) new-navigator])) | |
| 154 | |
| 155 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 156 ;;; Functions that support individual directives | |
| 157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 158 | |
| 159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 160 ;;; Common handling code for ~A and ~S | |
| 161 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 162 | |
| 163 (declare opt-base-str) | |
| 164 | |
| 165 (def ^{:private true} | |
| 166 special-radix-markers {2 "#b" 8 "#o", 16 "#x"}) | |
| 167 | |
| 168 (defn- format-simple-number [n] | |
| 169 (cond | |
| 170 (integer? n) (if (= *print-base* 10) | |
| 171 (str n (if *print-radix* ".")) | |
| 172 (str | |
| 173 (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) | |
| 174 (opt-base-str *print-base* n))) | |
| 175 (ratio? n) (str | |
| 176 (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) | |
| 177 (opt-base-str *print-base* (.numerator n)) | |
| 178 "/" | |
| 179 (opt-base-str *print-base* (.denominator n))) | |
| 180 :else nil)) | |
| 181 | |
| 182 (defn- format-ascii [print-func params arg-navigator offsets] | |
| 183 (let [ [arg arg-navigator] (next-arg arg-navigator) | |
| 184 ^String base-output (or (format-simple-number arg) (print-func arg)) | |
| 185 base-width (.length base-output) | |
| 186 min-width (+ base-width (:minpad params)) | |
| 187 width (if (>= min-width (:mincol params)) | |
| 188 min-width | |
| 189 (+ min-width | |
| 190 (* (+ (quot (- (:mincol params) min-width 1) | |
| 191 (:colinc params) ) | |
| 192 1) | |
| 193 (:colinc params)))) | |
| 194 chars (apply str (repeat (- width base-width) (:padchar params)))] | |
| 195 (if (:at params) | |
| 196 (print (str chars base-output)) | |
| 197 (print (str base-output chars))) | |
| 198 arg-navigator)) | |
| 199 | |
| 200 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 201 ;;; Support for the integer directives ~D, ~X, ~O, ~B and some | |
| 202 ;;; of ~R | |
| 203 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 204 | |
| 205 (defn- integral? | |
| 206 "returns true if a number is actually an integer (that is, has no fractional part)" | |
| 207 [x] | |
| 208 (cond | |
| 209 (integer? x) true | |
| 210 (decimal? x) (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part | |
| 211 (float? x) (= x (Math/floor x)) | |
| 212 (ratio? x) (let [^clojure.lang.Ratio r x] | |
| 213 (= 0 (rem (.numerator r) (.denominator r)))) | |
| 214 :else false)) | |
| 215 | |
| 216 (defn- remainders | |
| 217 "Return the list of remainders (essentially the 'digits') of val in the given base" | |
| 218 [base val] | |
| 219 (reverse | |
| 220 (first | |
| 221 (consume #(if (pos? %) | |
| 222 [(rem % base) (quot % base)] | |
| 223 [nil nil]) | |
| 224 val)))) | |
| 225 | |
| 226 ;;; TODO: xlated-val does not seem to be used here. | |
| 227 (defn- base-str | |
| 228 "Return val as a string in the given base" | |
| 229 [base val] | |
| 230 (if (zero? val) | |
| 231 "0" | |
| 232 (let [xlated-val (cond | |
| 233 (float? val) (bigdec val) | |
| 234 (ratio? val) (let [^clojure.lang.Ratio r val] | |
| 235 (/ (.numerator r) (.denominator r))) | |
| 236 :else val)] | |
| 237 (apply str | |
| 238 (map | |
| 239 #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10)))) | |
| 240 (remainders base val)))))) | |
| 241 | |
| 242 (def ^{:private true} | |
| 243 java-base-formats {8 "%o", 10 "%d", 16 "%x"}) | |
| 244 | |
| 245 (defn- opt-base-str | |
| 246 "Return val as a string in the given base, using clojure.core/format if supported | |
| 247 for improved performance" | |
| 248 [base val] | |
| 249 (let [format-str (get java-base-formats base)] | |
| 250 (if (and format-str (integer? val)) | |
| 251 (clojure.core/format format-str val) | |
| 252 (base-str base val)))) | |
| 253 | |
| 254 (defn- group-by* [unit lis] | |
| 255 (reverse | |
| 256 (first | |
| 257 (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis))))) | |
| 258 | |
| 259 (defn- format-integer [base params arg-navigator offsets] | |
| 260 (let [[arg arg-navigator] (next-arg arg-navigator)] | |
| 261 (if (integral? arg) | |
| 262 (let [neg (neg? arg) | |
| 263 pos-arg (if neg (- arg) arg) | |
| 264 raw-str (opt-base-str base pos-arg) | |
| 265 group-str (if (:colon params) | |
| 266 (let [groups (map #(apply str %) (group-by* (:commainterval params) raw-str)) | |
| 267 commas (repeat (count groups) (:commachar params))] | |
| 268 (apply str (next (interleave commas groups)))) | |
| 269 raw-str) | |
| 270 ^String signed-str (cond | |
| 271 neg (str "-" group-str) | |
| 272 (:at params) (str "+" group-str) | |
| 273 true group-str) | |
| 274 padded-str (if (< (.length signed-str) (:mincol params)) | |
| 275 (str (apply str (repeat (- (:mincol params) (.length signed-str)) | |
| 276 (:padchar params))) | |
| 277 signed-str) | |
| 278 signed-str)] | |
| 279 (print padded-str)) | |
| 280 (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0 | |
| 281 :padchar (:padchar params) :at true} | |
| 282 (init-navigator [arg]) nil)) | |
| 283 arg-navigator)) | |
| 284 | |
| 285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 286 ;;; Support for english formats (~R and ~:R) | |
| 287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 288 | |
| 289 (def ^{:private true} | |
| 290 english-cardinal-units | |
| 291 ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" | |
| 292 "ten" "eleven" "twelve" "thirteen" "fourteen" | |
| 293 "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"]) | |
| 294 | |
| 295 (def ^{:private true} | |
| 296 english-ordinal-units | |
| 297 ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" | |
| 298 "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" | |
| 299 "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"]) | |
| 300 | |
| 301 (def ^{:private true} | |
| 302 english-cardinal-tens | |
| 303 ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"]) | |
| 304 | |
| 305 (def ^{:private true} | |
| 306 english-ordinal-tens | |
| 307 ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth" | |
| 308 "sixtieth" "seventieth" "eightieth" "ninetieth"]) | |
| 309 | |
| 310 ;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales) | |
| 311 ;; Number names from http://www.jimloy.com/math/billion.htm | |
| 312 ;; We follow the rules for writing numbers from the Blue Book | |
| 313 ;; (http://www.grammarbook.com/numbers/numbers.asp) | |
| 314 (def ^{:private true} | |
| 315 english-scale-numbers | |
| 316 ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" | |
| 317 "sextillion" "septillion" "octillion" "nonillion" "decillion" | |
| 318 "undecillion" "duodecillion" "tredecillion" "quattuordecillion" | |
| 319 "quindecillion" "sexdecillion" "septendecillion" | |
| 320 "octodecillion" "novemdecillion" "vigintillion"]) | |
| 321 | |
| 322 (defn- format-simple-cardinal | |
| 323 "Convert a number less than 1000 to a cardinal english string" | |
| 324 [num] | |
| 325 (let [hundreds (quot num 100) | |
| 326 tens (rem num 100)] | |
| 327 (str | |
| 328 (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) | |
| 329 (if (and (pos? hundreds) (pos? tens)) " ") | |
| 330 (if (pos? tens) | |
| 331 (if (< tens 20) | |
| 332 (nth english-cardinal-units tens) | |
| 333 (let [ten-digit (quot tens 10) | |
| 334 unit-digit (rem tens 10)] | |
| 335 (str | |
| 336 (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) | |
| 337 (if (and (pos? ten-digit) (pos? unit-digit)) "-") | |
| 338 (if (pos? unit-digit) (nth english-cardinal-units unit-digit))))))))) | |
| 339 | |
| 340 (defn- add-english-scales | |
| 341 "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string | |
| 342 offset is a factor of 10^3 to multiply by" | |
| 343 [parts offset] | |
| 344 (let [cnt (count parts)] | |
| 345 (loop [acc [] | |
| 346 pos (dec cnt) | |
| 347 this (first parts) | |
| 348 remainder (next parts)] | |
| 349 (if (nil? remainder) | |
| 350 (str (apply str (interpose ", " acc)) | |
| 351 (if (and (not (empty? this)) (not (empty? acc))) ", ") | |
| 352 this | |
| 353 (if (and (not (empty? this)) (pos? (+ pos offset))) | |
| 354 (str " " (nth english-scale-numbers (+ pos offset))))) | |
| 355 (recur | |
| 356 (if (empty? this) | |
| 357 acc | |
| 358 (conj acc (str this " " (nth english-scale-numbers (+ pos offset))))) | |
| 359 (dec pos) | |
| 360 (first remainder) | |
| 361 (next remainder)))))) | |
| 362 | |
| 363 (defn- format-cardinal-english [params navigator offsets] | |
| 364 (let [[arg navigator] (next-arg navigator)] | |
| 365 (if (= 0 arg) | |
| 366 (print "zero") | |
| 367 (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs | |
| 368 parts (remainders 1000 abs-arg)] | |
| 369 (if (<= (count parts) (count english-scale-numbers)) | |
| 370 (let [parts-strs (map format-simple-cardinal parts) | |
| 371 full-str (add-english-scales parts-strs 0)] | |
| 372 (print (str (if (neg? arg) "minus ") full-str))) | |
| 373 (format-integer ;; for numbers > 10^63, we fall back on ~D | |
| 374 10 | |
| 375 { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} | |
| 376 (init-navigator [arg]) | |
| 377 { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})))) | |
| 378 navigator)) | |
| 379 | |
| 380 (defn- format-simple-ordinal | |
| 381 "Convert a number less than 1000 to a ordinal english string | |
| 382 Note this should only be used for the last one in the sequence" | |
| 383 [num] | |
| 384 (let [hundreds (quot num 100) | |
| 385 tens (rem num 100)] | |
| 386 (str | |
| 387 (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) | |
| 388 (if (and (pos? hundreds) (pos? tens)) " ") | |
| 389 (if (pos? tens) | |
| 390 (if (< tens 20) | |
| 391 (nth english-ordinal-units tens) | |
| 392 (let [ten-digit (quot tens 10) | |
| 393 unit-digit (rem tens 10)] | |
| 394 (if (and (pos? ten-digit) (not (pos? unit-digit))) | |
| 395 (nth english-ordinal-tens ten-digit) | |
| 396 (str | |
| 397 (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) | |
| 398 (if (and (pos? ten-digit) (pos? unit-digit)) "-") | |
| 399 (if (pos? unit-digit) (nth english-ordinal-units unit-digit)))))) | |
| 400 (if (pos? hundreds) "th"))))) | |
| 401 | |
| 402 (defn- format-ordinal-english [params navigator offsets] | |
| 403 (let [[arg navigator] (next-arg navigator)] | |
| 404 (if (= 0 arg) | |
| 405 (print "zeroth") | |
| 406 (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs | |
| 407 parts (remainders 1000 abs-arg)] | |
| 408 (if (<= (count parts) (count english-scale-numbers)) | |
| 409 (let [parts-strs (map format-simple-cardinal (drop-last parts)) | |
| 410 head-str (add-english-scales parts-strs 1) | |
| 411 tail-str (format-simple-ordinal (last parts))] | |
| 412 (print (str (if (neg? arg) "minus ") | |
| 413 (cond | |
| 414 (and (not (empty? head-str)) (not (empty? tail-str))) | |
| 415 (str head-str ", " tail-str) | |
| 416 | |
| 417 (not (empty? head-str)) (str head-str "th") | |
| 418 :else tail-str)))) | |
| 419 (do (format-integer ;; for numbers > 10^63, we fall back on ~D | |
| 420 10 | |
| 421 { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} | |
| 422 (init-navigator [arg]) | |
| 423 { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}) | |
| 424 (let [low-two-digits (rem arg 100) | |
| 425 not-teens (or (< 11 low-two-digits) (> 19 low-two-digits)) | |
| 426 low-digit (rem low-two-digits 10)] | |
| 427 (print (cond | |
| 428 (and (= low-digit 1) not-teens) "st" | |
| 429 (and (= low-digit 2) not-teens) "nd" | |
| 430 (and (= low-digit 3) not-teens) "rd" | |
| 431 :else "th"))))))) | |
| 432 navigator)) | |
| 433 | |
| 434 | |
| 435 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 436 ;;; Support for roman numeral formats (~@R and ~@:R) | |
| 437 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 438 | |
| 439 (def ^{:private true} | |
| 440 old-roman-table | |
| 441 [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"] | |
| 442 [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"] | |
| 443 [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"] | |
| 444 [ "M" "MM" "MMM"]]) | |
| 445 | |
| 446 (def ^{:private true} | |
| 447 new-roman-table | |
| 448 [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"] | |
| 449 [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"] | |
| 450 [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"] | |
| 451 [ "M" "MM" "MMM"]]) | |
| 452 | |
| 453 (defn- format-roman | |
| 454 "Format a roman numeral using the specified look-up table" | |
| 455 [table params navigator offsets] | |
| 456 (let [[arg navigator] (next-arg navigator)] | |
| 457 (if (and (number? arg) (> arg 0) (< arg 4000)) | |
| 458 (let [digits (remainders 10 arg)] | |
| 459 (loop [acc [] | |
| 460 pos (dec (count digits)) | |
| 461 digits digits] | |
| 462 (if (empty? digits) | |
| 463 (print (apply str acc)) | |
| 464 (let [digit (first digits)] | |
| 465 (recur (if (= 0 digit) | |
| 466 acc | |
| 467 (conj acc (nth (nth table pos) (dec digit)))) | |
| 468 (dec pos) | |
| 469 (next digits)))))) | |
| 470 (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D | |
| 471 10 | |
| 472 { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} | |
| 473 (init-navigator [arg]) | |
| 474 { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})) | |
| 475 navigator)) | |
| 476 | |
| 477 (defn- format-old-roman [params navigator offsets] | |
| 478 (format-roman old-roman-table params navigator offsets)) | |
| 479 | |
| 480 (defn- format-new-roman [params navigator offsets] | |
| 481 (format-roman new-roman-table params navigator offsets)) | |
| 482 | |
| 483 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 484 ;;; Support for character formats (~C) | |
| 485 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 486 | |
| 487 (def ^{:private true} | |
| 488 special-chars { 8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"}) | |
| 489 | |
| 490 (defn- pretty-character [params navigator offsets] | |
| 491 (let [[c navigator] (next-arg navigator) | |
| 492 as-int (int c) | |
| 493 base-char (bit-and as-int 127) | |
| 494 meta (bit-and as-int 128) | |
| 495 special (get special-chars base-char)] | |
| 496 (if (> meta 0) (print "Meta-")) | |
| 497 (print (cond | |
| 498 special special | |
| 499 (< base-char 32) (str "Control-" (char (+ base-char 64))) | |
| 500 (= base-char 127) "Control-?" | |
| 501 :else (char base-char))) | |
| 502 navigator)) | |
| 503 | |
| 504 (defn- readable-character [params navigator offsets] | |
| 505 (let [[c navigator] (next-arg navigator)] | |
| 506 (condp = (:char-format params) | |
| 507 \o (cl-format true "\\o~3,'0o" (int c)) | |
| 508 \u (cl-format true "\\u~4,'0x" (int c)) | |
| 509 nil (pr c)) | |
| 510 navigator)) | |
| 511 | |
| 512 (defn- plain-character [params navigator offsets] | |
| 513 (let [[char navigator] (next-arg navigator)] | |
| 514 (print char) | |
| 515 navigator)) | |
| 516 | |
| 517 ;; Check to see if a result is an abort (~^) construct | |
| 518 ;; TODO: move these funcs somewhere more appropriate | |
| 519 (defn- abort? [context] | |
| 520 (let [token (first context)] | |
| 521 (or (= :up-arrow token) (= :colon-up-arrow token)))) | |
| 522 | |
| 523 ;; Handle the execution of "sub-clauses" in bracket constructions | |
| 524 (defn- execute-sub-format [format args base-args] | |
| 525 (second | |
| 526 (map-passing-context | |
| 527 (fn [element context] | |
| 528 (if (abort? context) | |
| 529 [nil context] ; just keep passing it along | |
| 530 (let [[params args] (realize-parameter-list (:params element) context) | |
| 531 [params offsets] (unzip-map params) | |
| 532 params (assoc params :base-args base-args)] | |
| 533 [nil (apply (:func element) [params args offsets])]))) | |
| 534 args | |
| 535 format))) | |
| 536 | |
| 537 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 538 ;;; Support for real number formats | |
| 539 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 540 | |
| 541 ;; TODO - return exponent as int to eliminate double conversion | |
| 542 (defn- float-parts-base | |
| 543 "Produce string parts for the mantissa (normalized 1-9) and exponent" | |
| 544 [^Object f] | |
| 545 (let [^String s (.toLowerCase (.toString f)) | |
| 546 exploc (.indexOf s (int \e))] | |
| 547 (if (neg? exploc) | |
| 548 (let [dotloc (.indexOf s (int \.))] | |
| 549 (if (neg? dotloc) | |
| 550 [s (str (dec (count s)))] | |
| 551 [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))])) | |
| 552 [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))]))) | |
| 553 | |
| 554 | |
| 555 (defn- float-parts | |
| 556 "Take care of leading and trailing zeros in decomposed floats" | |
| 557 [f] | |
| 558 (let [[m ^String e] (float-parts-base f) | |
| 559 m1 (rtrim m \0) | |
| 560 m2 (ltrim m1 \0) | |
| 561 delta (- (count m1) (count m2)) | |
| 562 ^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)] | |
| 563 (if (empty? m2) | |
| 564 ["0" 0] | |
| 565 [m2 (- (Integer/valueOf e) delta)]))) | |
| 566 | |
| 567 (defn- round-str [m e d w] | |
| 568 (if (or d w) | |
| 569 (let [len (count m) | |
| 570 round-pos (if d (+ e d 1)) | |
| 571 round-pos (if (and w (< (inc e) (dec w)) | |
| 572 (or (nil? round-pos) (< (dec w) round-pos))) | |
| 573 (dec w) | |
| 574 round-pos) | |
| 575 [m1 e1 round-pos len] (if (= round-pos 0) | |
| 576 [(str "0" m) (inc e) 1 (inc len)] | |
| 577 [m e round-pos len])] | |
| 578 (if round-pos | |
| 579 (if (neg? round-pos) | |
| 580 ["0" 0 false] | |
| 581 (if (> len round-pos) | |
| 582 (let [round-char (nth m1 round-pos) | |
| 583 ^String result (subs m1 0 round-pos)] | |
| 584 (if (>= (int round-char) (int \5)) | |
| 585 (let [result-val (Integer/valueOf result) | |
| 586 leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1))) | |
| 587 round-up-result (str leading-zeros | |
| 588 (String/valueOf (+ result-val | |
| 589 (if (neg? result-val) -1 1)))) | |
| 590 expanded (> (count round-up-result) (count result))] | |
| 591 [round-up-result e1 expanded]) | |
| 592 [result e1 false])) | |
| 593 [m e false])) | |
| 594 [m e false])) | |
| 595 [m e false])) | |
| 596 | |
| 597 (defn- expand-fixed [m e d] | |
| 598 (let [m1 (if (neg? e) (str (apply str (repeat (dec (- e)) \0)) m) m) | |
| 599 len (count m1) | |
| 600 target-len (if d (+ e d 1) (inc e))] | |
| 601 (if (< len target-len) | |
| 602 (str m1 (apply str (repeat (- target-len len) \0))) | |
| 603 m1))) | |
| 604 | |
| 605 (defn- insert-decimal | |
| 606 "Insert the decimal point at the right spot in the number to match an exponent" | |
| 607 [m e] | |
| 608 (if (neg? e) | |
| 609 (str "." m) | |
| 610 (let [loc (inc e)] | |
| 611 (str (subs m 0 loc) "." (subs m loc))))) | |
| 612 | |
| 613 (defn- get-fixed [m e d] | |
| 614 (insert-decimal (expand-fixed m e d) e)) | |
| 615 | |
| 616 (defn- insert-scaled-decimal | |
| 617 "Insert the decimal point at the right spot in the number to match an exponent" | |
| 618 [m k] | |
| 619 (if (neg? k) | |
| 620 (str "." m) | |
| 621 (str (subs m 0 k) "." (subs m k)))) | |
| 622 | |
| 623 ;; the function to render ~F directives | |
| 624 ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases | |
| 625 (defn- fixed-float [params navigator offsets] | |
| 626 (let [w (:w params) | |
| 627 d (:d params) | |
| 628 [arg navigator] (next-arg navigator) | |
| 629 [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg]) | |
| 630 [mantissa exp] (float-parts abs) | |
| 631 scaled-exp (+ exp (:k params)) | |
| 632 add-sign (or (:at params) (neg? arg)) | |
| 633 append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp)) | |
| 634 [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp | |
| 635 d (if w (- w (if add-sign 1 0)))) | |
| 636 fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) | |
| 637 prepend-zero (= (first fixed-repr) \.)] | |
| 638 (if w | |
| 639 (let [len (count fixed-repr) | |
| 640 signed-len (if add-sign (inc len) len) | |
| 641 prepend-zero (and prepend-zero (not (>= signed-len w))) | |
| 642 append-zero (and append-zero (not (>= signed-len w))) | |
| 643 full-len (if (or prepend-zero append-zero) | |
| 644 (inc signed-len) | |
| 645 signed-len)] | |
| 646 (if (and (> full-len w) (:overflowchar params)) | |
| 647 (print (apply str (repeat w (:overflowchar params)))) | |
| 648 (print (str | |
| 649 (apply str (repeat (- w full-len) (:padchar params))) | |
| 650 (if add-sign sign) | |
| 651 (if prepend-zero "0") | |
| 652 fixed-repr | |
| 653 (if append-zero "0"))))) | |
| 654 (print (str | |
| 655 (if add-sign sign) | |
| 656 (if prepend-zero "0") | |
| 657 fixed-repr | |
| 658 (if append-zero "0")))) | |
| 659 navigator)) | |
| 660 | |
| 661 | |
| 662 ;; the function to render ~E directives | |
| 663 ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases | |
| 664 ;; TODO: define ~E representation for Infinity | |
| 665 (defn- exponential-float [params navigator offsets] | |
| 666 (let [[arg navigator] (next-arg navigator)] | |
| 667 (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))] | |
| 668 (let [w (:w params) | |
| 669 d (:d params) | |
| 670 e (:e params) | |
| 671 k (:k params) | |
| 672 expchar (or (:exponentchar params) \E) | |
| 673 add-sign (or (:at params) (neg? arg)) | |
| 674 prepend-zero (<= k 0) | |
| 675 ^Integer scaled-exp (- exp (dec k)) | |
| 676 scaled-exp-str (str (Math/abs scaled-exp)) | |
| 677 scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+) | |
| 678 (if e (apply str | |
| 679 (repeat | |
| 680 (- e | |
| 681 (count scaled-exp-str)) | |
| 682 \0))) | |
| 683 scaled-exp-str) | |
| 684 exp-width (count scaled-exp-str) | |
| 685 base-mantissa-width (count mantissa) | |
| 686 scaled-mantissa (str (apply str (repeat (- k) \0)) | |
| 687 mantissa | |
| 688 (if d | |
| 689 (apply str | |
| 690 (repeat | |
| 691 (- d (dec base-mantissa-width) | |
| 692 (if (neg? k) (- k) 0)) \0)))) | |
| 693 w-mantissa (if w (- w exp-width)) | |
| 694 [rounded-mantissa _ incr-exp] (round-str | |
| 695 scaled-mantissa 0 | |
| 696 (cond | |
| 697 (= k 0) (dec d) | |
| 698 (pos? k) d | |
| 699 (neg? k) (dec d)) | |
| 700 (if w-mantissa | |
| 701 (- w-mantissa (if add-sign 1 0)))) | |
| 702 full-mantissa (insert-scaled-decimal rounded-mantissa k) | |
| 703 append-zero (and (= k (count rounded-mantissa)) (nil? d))] | |
| 704 (if (not incr-exp) | |
| 705 (if w | |
| 706 (let [len (+ (count full-mantissa) exp-width) | |
| 707 signed-len (if add-sign (inc len) len) | |
| 708 prepend-zero (and prepend-zero (not (= signed-len w))) | |
| 709 full-len (if prepend-zero (inc signed-len) signed-len) | |
| 710 append-zero (and append-zero (< full-len w))] | |
| 711 (if (and (or (> full-len w) (and e (> (- exp-width 2) e))) | |
| 712 (:overflowchar params)) | |
| 713 (print (apply str (repeat w (:overflowchar params)))) | |
| 714 (print (str | |
| 715 (apply str | |
| 716 (repeat | |
| 717 (- w full-len (if append-zero 1 0) ) | |
| 718 (:padchar params))) | |
| 719 (if add-sign (if (neg? arg) \- \+)) | |
| 720 (if prepend-zero "0") | |
| 721 full-mantissa | |
| 722 (if append-zero "0") | |
| 723 scaled-exp-str)))) | |
| 724 (print (str | |
| 725 (if add-sign (if (neg? arg) \- \+)) | |
| 726 (if prepend-zero "0") | |
| 727 full-mantissa | |
| 728 (if append-zero "0") | |
| 729 scaled-exp-str))) | |
| 730 (recur [rounded-mantissa (inc exp)])))) | |
| 731 navigator)) | |
| 732 | |
| 733 ;; the function to render ~G directives | |
| 734 ;; This just figures out whether to pass the request off to ~F or ~E based | |
| 735 ;; on the algorithm in CLtL. | |
| 736 ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases | |
| 737 ;; TODO: refactor so that float-parts isn't called twice | |
| 738 (defn- general-float [params navigator offsets] | |
| 739 (let [[arg _] (next-arg navigator) | |
| 740 [mantissa exp] (float-parts (if (neg? arg) (- arg) arg)) | |
| 741 w (:w params) | |
| 742 d (:d params) | |
| 743 e (:e params) | |
| 744 n (if (= arg 0.0) 0 (inc exp)) | |
| 745 ee (if e (+ e 2) 4) | |
| 746 ww (if w (- w ee)) | |
| 747 d (if d d (max (count mantissa) (min n 7))) | |
| 748 dd (- d n)] | |
| 749 (if (<= 0 dd d) | |
| 750 (let [navigator (fixed-float {:w ww, :d dd, :k 0, | |
| 751 :overflowchar (:overflowchar params), | |
| 752 :padchar (:padchar params), :at (:at params)} | |
| 753 navigator offsets)] | |
| 754 (print (apply str (repeat ee \space))) | |
| 755 navigator) | |
| 756 (exponential-float params navigator offsets)))) | |
| 757 | |
| 758 ;; the function to render ~$ directives | |
| 759 ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases | |
| 760 (defn- dollar-float [params navigator offsets] | |
| 761 (let [[^Double arg navigator] (next-arg navigator) | |
| 762 [mantissa exp] (float-parts (Math/abs arg)) | |
| 763 d (:d params) ; digits after the decimal | |
| 764 n (:n params) ; minimum digits before the decimal | |
| 765 w (:w params) ; minimum field width | |
| 766 add-sign (or (:at params) (neg? arg)) | |
| 767 [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil) | |
| 768 ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) | |
| 769 full-repr (str (apply str (repeat (- n (.indexOf fixed-repr (int \.))) \0)) fixed-repr) | |
| 770 full-len (+ (count full-repr) (if add-sign 1 0))] | |
| 771 (print (str | |
| 772 (if (and (:colon params) add-sign) (if (neg? arg) \- \+)) | |
| 773 (apply str (repeat (- w full-len) (:padchar params))) | |
| 774 (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+)) | |
| 775 full-repr)) | |
| 776 navigator)) | |
| 777 | |
| 778 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 779 ;;; Support for the '~[...~]' conditional construct in its | |
| 780 ;;; different flavors | |
| 781 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 782 | |
| 783 ;; ~[...~] without any modifiers chooses one of the clauses based on the param or | |
| 784 ;; next argument | |
| 785 ;; TODO check arg is positive int | |
| 786 (defn- choice-conditional [params arg-navigator offsets] | |
| 787 (let [arg (:selector params) | |
| 788 [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator)) | |
| 789 clauses (:clauses params) | |
| 790 clause (if (or (neg? arg) (>= arg (count clauses))) | |
| 791 (first (:else params)) | |
| 792 (nth clauses arg))] | |
| 793 (if clause | |
| 794 (execute-sub-format clause navigator (:base-args params)) | |
| 795 navigator))) | |
| 796 | |
| 797 ;; ~:[...~] with the colon reads the next argument treating it as a truth value | |
| 798 (defn- boolean-conditional [params arg-navigator offsets] | |
| 799 (let [[arg navigator] (next-arg arg-navigator) | |
| 800 clauses (:clauses params) | |
| 801 clause (if arg | |
| 802 (second clauses) | |
| 803 (first clauses))] | |
| 804 (if clause | |
| 805 (execute-sub-format clause navigator (:base-args params)) | |
| 806 navigator))) | |
| 807 | |
| 808 ;; ~@[...~] with the at sign executes the conditional if the next arg is not | |
| 809 ;; nil/false without consuming the arg | |
| 810 (defn- check-arg-conditional [params arg-navigator offsets] | |
| 811 (let [[arg navigator] (next-arg arg-navigator) | |
| 812 clauses (:clauses params) | |
| 813 clause (if arg (first clauses))] | |
| 814 (if arg | |
| 815 (if clause | |
| 816 (execute-sub-format clause arg-navigator (:base-args params)) | |
| 817 arg-navigator) | |
| 818 navigator))) | |
| 819 | |
| 820 | |
| 821 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 822 ;;; Support for the '~{...~}' iteration construct in its | |
| 823 ;;; different flavors | |
| 824 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 825 | |
| 826 | |
| 827 ;; ~{...~} without any modifiers uses the next argument as an argument list that | |
| 828 ;; is consumed by all the iterations | |
| 829 (defn- iterate-sublist [params navigator offsets] | |
| 830 (let [max-count (:max-iterations params) | |
| 831 param-clause (first (:clauses params)) | |
| 832 [clause navigator] (if (empty? param-clause) | |
| 833 (get-format-arg navigator) | |
| 834 [param-clause navigator]) | |
| 835 [arg-list navigator] (next-arg navigator) | |
| 836 args (init-navigator arg-list)] | |
| 837 (loop [count 0 | |
| 838 args args | |
| 839 last-pos -1] | |
| 840 (if (and (not max-count) (= (:pos args) last-pos) (> count 1)) | |
| 841 ;; TODO get the offset in here and call format exception | |
| 842 (throw (RuntimeException. "%{ construct not consuming any arguments: Infinite loop!"))) | |
| 843 (if (or (and (empty? (:rest args)) | |
| 844 (or (not (:colon (:right-params params))) (> count 0))) | |
| 845 (and max-count (>= count max-count))) | |
| 846 navigator | |
| 847 (let [iter-result (execute-sub-format clause args (:base-args params))] | |
| 848 (if (= :up-arrow (first iter-result)) | |
| 849 navigator | |
| 850 (recur (inc count) iter-result (:pos args)))))))) | |
| 851 | |
| 852 ;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the | |
| 853 ;; sublists is used as the arglist for a single iteration. | |
| 854 (defn- iterate-list-of-sublists [params navigator offsets] | |
| 855 (let [max-count (:max-iterations params) | |
| 856 param-clause (first (:clauses params)) | |
| 857 [clause navigator] (if (empty? param-clause) | |
| 858 (get-format-arg navigator) | |
| 859 [param-clause navigator]) | |
| 860 [arg-list navigator] (next-arg navigator)] | |
| 861 (loop [count 0 | |
| 862 arg-list arg-list] | |
| 863 (if (or (and (empty? arg-list) | |
| 864 (or (not (:colon (:right-params params))) (> count 0))) | |
| 865 (and max-count (>= count max-count))) | |
| 866 navigator | |
| 867 (let [iter-result (execute-sub-format | |
| 868 clause | |
| 869 (init-navigator (first arg-list)) | |
| 870 (init-navigator (next arg-list)))] | |
| 871 (if (= :colon-up-arrow (first iter-result)) | |
| 872 navigator | |
| 873 (recur (inc count) (next arg-list)))))))) | |
| 874 | |
| 875 ;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations | |
| 876 ;; is consumed by all the iterations | |
| 877 (defn- iterate-main-list [params navigator offsets] | |
| 878 (let [max-count (:max-iterations params) | |
| 879 param-clause (first (:clauses params)) | |
| 880 [clause navigator] (if (empty? param-clause) | |
| 881 (get-format-arg navigator) | |
| 882 [param-clause navigator])] | |
| 883 (loop [count 0 | |
| 884 navigator navigator | |
| 885 last-pos -1] | |
| 886 (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1)) | |
| 887 ;; TODO get the offset in here and call format exception | |
| 888 (throw (RuntimeException. "%@{ construct not consuming any arguments: Infinite loop!"))) | |
| 889 (if (or (and (empty? (:rest navigator)) | |
| 890 (or (not (:colon (:right-params params))) (> count 0))) | |
| 891 (and max-count (>= count max-count))) | |
| 892 navigator | |
| 893 (let [iter-result (execute-sub-format clause navigator (:base-args params))] | |
| 894 (if (= :up-arrow (first iter-result)) | |
| 895 (second iter-result) | |
| 896 (recur | |
| 897 (inc count) iter-result (:pos navigator)))))))) | |
| 898 | |
| 899 ;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one | |
| 900 ;; of which is consumed with each iteration | |
| 901 (defn- iterate-main-sublists [params navigator offsets] | |
| 902 (let [max-count (:max-iterations params) | |
| 903 param-clause (first (:clauses params)) | |
| 904 [clause navigator] (if (empty? param-clause) | |
| 905 (get-format-arg navigator) | |
| 906 [param-clause navigator]) | |
| 907 ] | |
| 908 (loop [count 0 | |
| 909 navigator navigator] | |
| 910 (if (or (and (empty? (:rest navigator)) | |
| 911 (or (not (:colon (:right-params params))) (> count 0))) | |
| 912 (and max-count (>= count max-count))) | |
| 913 navigator | |
| 914 (let [[sublist navigator] (next-arg-or-nil navigator) | |
| 915 iter-result (execute-sub-format clause (init-navigator sublist) navigator)] | |
| 916 (if (= :colon-up-arrow (first iter-result)) | |
| 917 navigator | |
| 918 (recur (inc count) navigator))))))) | |
| 919 | |
| 920 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 921 ;;; The '~< directive has two completely different meanings | |
| 922 ;;; in the '~<...~>' form it does justification, but with | |
| 923 ;;; ~<...~:>' it represents the logical block operation of the | |
| 924 ;;; pretty printer. | |
| 925 ;;; | |
| 926 ;;; Unfortunately, the current architecture decides what function | |
| 927 ;;; to call at form parsing time before the sub-clauses have been | |
| 928 ;;; folded, so it is left to run-time to make the decision. | |
| 929 ;;; | |
| 930 ;;; TODO: make it possible to make these decisions at compile-time. | |
| 931 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 932 | |
| 933 (declare format-logical-block) | |
| 934 (declare justify-clauses) | |
| 935 | |
| 936 (defn- logical-block-or-justify [params navigator offsets] | |
| 937 (if (:colon (:right-params params)) | |
| 938 (format-logical-block params navigator offsets) | |
| 939 (justify-clauses params navigator offsets))) | |
| 940 | |
| 941 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 942 ;;; Support for the '~<...~>' justification directive | |
| 943 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 944 | |
| 945 (defn- render-clauses [clauses navigator base-navigator] | |
| 946 (loop [clauses clauses | |
| 947 acc [] | |
| 948 navigator navigator] | |
| 949 (if (empty? clauses) | |
| 950 [acc navigator] | |
| 951 (let [clause (first clauses) | |
| 952 [iter-result result-str] (binding [*out* (java.io.StringWriter.)] | |
| 953 [(execute-sub-format clause navigator base-navigator) | |
| 954 (.toString *out*)])] | |
| 955 (if (= :up-arrow (first iter-result)) | |
| 956 [acc (second iter-result)] | |
| 957 (recur (next clauses) (conj acc result-str) iter-result)))))) | |
| 958 | |
| 959 ;; TODO support for ~:; constructions | |
| 960 (defn- justify-clauses [params navigator offsets] | |
| 961 (let [[[eol-str] new-navigator] (when-let [else (:else params)] | |
| 962 (render-clauses else navigator (:base-args params))) | |
| 963 navigator (or new-navigator navigator) | |
| 964 [else-params new-navigator] (when-let [p (:else-params params)] | |
| 965 (realize-parameter-list p navigator)) | |
| 966 navigator (or new-navigator navigator) | |
| 967 min-remaining (or (first (:min-remaining else-params)) 0) | |
| 968 max-columns (or (first (:max-columns else-params)) | |
| 969 (get-max-column *out*)) | |
| 970 clauses (:clauses params) | |
| 971 [strs navigator] (render-clauses clauses navigator (:base-args params)) | |
| 972 slots (max 1 | |
| 973 (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0))) | |
| 974 chars (reduce + (map count strs)) | |
| 975 mincol (:mincol params) | |
| 976 minpad (:minpad params) | |
| 977 colinc (:colinc params) | |
| 978 minout (+ chars (* slots minpad)) | |
| 979 result-columns (if (<= minout mincol) | |
| 980 mincol | |
| 981 (+ mincol (* colinc | |
| 982 (+ 1 (quot (- minout mincol 1) colinc))))) | |
| 983 total-pad (- result-columns chars) | |
| 984 pad (max minpad (quot total-pad slots)) | |
| 985 extra-pad (- total-pad (* pad slots)) | |
| 986 pad-str (apply str (repeat pad (:padchar params)))] | |
| 987 (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns) | |
| 988 max-columns)) | |
| 989 (print eol-str)) | |
| 990 (loop [slots slots | |
| 991 extra-pad extra-pad | |
| 992 strs strs | |
| 993 pad-only (or (:colon params) | |
| 994 (and (= (count strs) 1) (not (:at params))))] | |
| 995 (if (seq strs) | |
| 996 (do | |
| 997 (print (str (if (not pad-only) (first strs)) | |
| 998 (if (or pad-only (next strs) (:at params)) pad-str) | |
| 999 (if (pos? extra-pad) (:padchar params)))) | |
| 1000 (recur | |
| 1001 (dec slots) | |
| 1002 (dec extra-pad) | |
| 1003 (if pad-only strs (next strs)) | |
| 1004 false)))) | |
| 1005 navigator)) | |
| 1006 | |
| 1007 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1008 ;;; Support for case modification with ~(...~). | |
| 1009 ;;; We do this by wrapping the underlying writer with | |
| 1010 ;;; a special writer to do the appropriate modification. This | |
| 1011 ;;; allows us to support arbitrary-sized output and sources | |
| 1012 ;;; that may block. | |
| 1013 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1014 | |
| 1015 (defn- downcase-writer | |
| 1016 "Returns a proxy that wraps writer, converting all characters to lower case" | |
| 1017 [^java.io.Writer writer] | |
| 1018 (proxy [java.io.Writer] [] | |
| 1019 (close [] (.close writer)) | |
| 1020 (flush [] (.flush writer)) | |
| 1021 (write ([^chars cbuf ^Integer off ^Integer len] | |
| 1022 (.write writer cbuf off len)) | |
| 1023 ([x] | |
| 1024 (condp = (class x) | |
| 1025 String | |
| 1026 (let [s ^String x] | |
| 1027 (.write writer (.toLowerCase s))) | |
| 1028 | |
| 1029 Integer | |
| 1030 (let [c ^Character x] | |
| 1031 (.write writer (int (Character/toLowerCase (char c)))))))))) | |
| 1032 | |
| 1033 (defn- upcase-writer | |
| 1034 "Returns a proxy that wraps writer, converting all characters to upper case" | |
| 1035 [^java.io.Writer writer] | |
| 1036 (proxy [java.io.Writer] [] | |
| 1037 (close [] (.close writer)) | |
| 1038 (flush [] (.flush writer)) | |
| 1039 (write ([^chars cbuf ^Integer off ^Integer len] | |
| 1040 (.write writer cbuf off len)) | |
| 1041 ([x] | |
| 1042 (condp = (class x) | |
| 1043 String | |
| 1044 (let [s ^String x] | |
| 1045 (.write writer (.toUpperCase s))) | |
| 1046 | |
| 1047 Integer | |
| 1048 (let [c ^Character x] | |
| 1049 (.write writer (int (Character/toUpperCase (char c)))))))))) | |
| 1050 | |
| 1051 (defn- capitalize-string | |
| 1052 "Capitalizes the words in a string. If first? is false, don't capitalize the | |
| 1053 first character of the string even if it's a letter." | |
| 1054 [s first?] | |
| 1055 (let [^Character f (first s) | |
| 1056 s (if (and first? f (Character/isLetter f)) | |
| 1057 (str (Character/toUpperCase f) (subs s 1)) | |
| 1058 s)] | |
| 1059 (apply str | |
| 1060 (first | |
| 1061 (consume | |
| 1062 (fn [s] | |
| 1063 (if (empty? s) | |
| 1064 [nil nil] | |
| 1065 (let [m (re-matcher #"\W\w" s) | |
| 1066 match (re-find m) | |
| 1067 offset (and match (inc (.start m)))] | |
| 1068 (if offset | |
| 1069 [(str (subs s 0 offset) | |
| 1070 (Character/toUpperCase ^Character (nth s offset))) | |
| 1071 (subs s (inc offset))] | |
| 1072 [s nil])))) | |
| 1073 s))))) | |
| 1074 | |
| 1075 (defn- capitalize-word-writer | |
| 1076 "Returns a proxy that wraps writer, captializing all words" | |
| 1077 [^java.io.Writer writer] | |
| 1078 (let [last-was-whitespace? (ref true)] | |
| 1079 (proxy [java.io.Writer] [] | |
| 1080 (close [] (.close writer)) | |
| 1081 (flush [] (.flush writer)) | |
| 1082 (write | |
| 1083 ([^chars cbuf ^Integer off ^Integer len] | |
| 1084 (.write writer cbuf off len)) | |
| 1085 ([x] | |
| 1086 (condp = (class x) | |
| 1087 String | |
| 1088 (let [s ^String x] | |
| 1089 (.write writer | |
| 1090 ^String (capitalize-string (.toLowerCase s) @last-was-whitespace?)) | |
| 1091 (dosync | |
| 1092 (ref-set last-was-whitespace? | |
| 1093 (Character/isWhitespace | |
| 1094 ^Character (nth s (dec (count s))))))) | |
| 1095 | |
| 1096 Integer | |
| 1097 (let [c (char x)] | |
| 1098 (let [mod-c (if @last-was-whitespace? (Character/toUpperCase ^Character (char x)) c)] | |
| 1099 (.write writer (int mod-c)) | |
| 1100 (dosync (ref-set last-was-whitespace? (Character/isWhitespace ^Character (char x)))))))))))) | |
| 1101 | |
| 1102 (defn- init-cap-writer | |
| 1103 "Returns a proxy that wraps writer, capitalizing the first word" | |
| 1104 [^java.io.Writer writer] | |
| 1105 (let [capped (ref false)] | |
| 1106 (proxy [java.io.Writer] [] | |
| 1107 (close [] (.close writer)) | |
| 1108 (flush [] (.flush writer)) | |
| 1109 (write ([^chars cbuf ^Integer off ^Integer len] | |
| 1110 (.write writer cbuf off len)) | |
| 1111 ([x] | |
| 1112 (condp = (class x) | |
| 1113 String | |
| 1114 (let [s (.toLowerCase ^String x)] | |
| 1115 (if (not @capped) | |
| 1116 (let [m (re-matcher #"\S" s) | |
| 1117 match (re-find m) | |
| 1118 offset (and match (.start m))] | |
| 1119 (if offset | |
| 1120 (do (.write writer | |
| 1121 (str (subs s 0 offset) | |
| 1122 (Character/toUpperCase ^Character (nth s offset)) | |
| 1123 (.toLowerCase ^String (subs s (inc offset))))) | |
| 1124 (dosync (ref-set capped true))) | |
| 1125 (.write writer s))) | |
| 1126 (.write writer (.toLowerCase s)))) | |
| 1127 | |
| 1128 Integer | |
| 1129 (let [c ^Character (char x)] | |
| 1130 (if (and (not @capped) (Character/isLetter c)) | |
| 1131 (do | |
| 1132 (dosync (ref-set capped true)) | |
| 1133 (.write writer (int (Character/toUpperCase c)))) | |
| 1134 (.write writer (int (Character/toLowerCase c))))))))))) | |
| 1135 | |
| 1136 (defn- modify-case [make-writer params navigator offsets] | |
| 1137 (let [clause (first (:clauses params))] | |
| 1138 (binding [*out* (make-writer *out*)] | |
| 1139 (execute-sub-format clause navigator (:base-args params))))) | |
| 1140 | |
| 1141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1142 ;;; If necessary, wrap the writer in a PrettyWriter object | |
| 1143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1144 | |
| 1145 (defn get-pretty-writer | |
| 1146 "Returns the java.io.Writer passed in wrapped in a pretty writer proxy, unless it's | |
| 1147 already a pretty writer. Generally, it is unneccesary to call this function, since pprint, | |
| 1148 write, and cl-format all call it if they need to. However if you want the state to be | |
| 1149 preserved across calls, you will want to wrap them with this. | |
| 1150 | |
| 1151 For example, when you want to generate column-aware output with multiple calls to cl-format, | |
| 1152 do it like in this example: | |
| 1153 | |
| 1154 (defn print-table [aseq column-width] | |
| 1155 (binding [*out* (get-pretty-writer *out*)] | |
| 1156 (doseq [row aseq] | |
| 1157 (doseq [col row] | |
| 1158 (cl-format true \"~4D~7,vT\" col column-width)) | |
| 1159 (prn)))) | |
| 1160 | |
| 1161 Now when you run: | |
| 1162 | |
| 1163 user> (print-table (map #(vector % (* % %) (* % % %)) (range 1 11)) 8) | |
| 1164 | |
| 1165 It prints a table of squares and cubes for the numbers from 1 to 10: | |
| 1166 | |
| 1167 1 1 1 | |
| 1168 2 4 8 | |
| 1169 3 9 27 | |
| 1170 4 16 64 | |
| 1171 5 25 125 | |
| 1172 6 36 216 | |
| 1173 7 49 343 | |
| 1174 8 64 512 | |
| 1175 9 81 729 | |
| 1176 10 100 1000" | |
| 1177 {:added "1.2"} | |
| 1178 [writer] | |
| 1179 (if (pretty-writer? writer) | |
| 1180 writer | |
| 1181 (pretty-writer writer *print-right-margin* *print-miser-width*))) | |
| 1182 | |
| 1183 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1184 ;;; Support for column-aware operations ~&, ~T | |
| 1185 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1186 | |
| 1187 (defn fresh-line | |
| 1188 "Make a newline if *out* is not already at the beginning of the line. If *out* is | |
| 1189 not a pretty writer (which keeps track of columns), this function always outputs a newline." | |
| 1190 {:added "1.2"} | |
| 1191 [] | |
| 1192 (if (instance? clojure.lang.IDeref *out*) | |
| 1193 (if (not (= 0 (get-column (:base @@*out*)))) | |
| 1194 (prn)) | |
| 1195 (prn))) | |
| 1196 | |
| 1197 (defn- absolute-tabulation [params navigator offsets] | |
| 1198 (let [colnum (:colnum params) | |
| 1199 colinc (:colinc params) | |
| 1200 current (get-column (:base @@*out*)) | |
| 1201 space-count (cond | |
| 1202 (< current colnum) (- colnum current) | |
| 1203 (= colinc 0) 0 | |
| 1204 :else (- colinc (rem (- current colnum) colinc)))] | |
| 1205 (print (apply str (repeat space-count \space)))) | |
| 1206 navigator) | |
| 1207 | |
| 1208 (defn- relative-tabulation [params navigator offsets] | |
| 1209 (let [colrel (:colnum params) | |
| 1210 colinc (:colinc params) | |
| 1211 start-col (+ colrel (get-column (:base @@*out*))) | |
| 1212 offset (if (pos? colinc) (rem start-col colinc) 0) | |
| 1213 space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))] | |
| 1214 (print (apply str (repeat space-count \space)))) | |
| 1215 navigator) | |
| 1216 | |
| 1217 | |
| 1218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1219 ;;; Support for accessing the pretty printer from a format | |
| 1220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1221 | |
| 1222 ;; TODO: support ~@; per-line-prefix separator | |
| 1223 ;; TODO: get the whole format wrapped so we can start the lb at any column | |
| 1224 (defn- format-logical-block [params navigator offsets] | |
| 1225 (let [clauses (:clauses params) | |
| 1226 clause-count (count clauses) | |
| 1227 prefix (cond | |
| 1228 (> clause-count 1) (:string (:params (first (first clauses)))) | |
| 1229 (:colon params) "(") | |
| 1230 body (nth clauses (if (> clause-count 1) 1 0)) | |
| 1231 suffix (cond | |
| 1232 (> clause-count 2) (:string (:params (first (nth clauses 2)))) | |
| 1233 (:colon params) ")") | |
| 1234 [arg navigator] (next-arg navigator)] | |
| 1235 (pprint-logical-block :prefix prefix :suffix suffix | |
| 1236 (execute-sub-format | |
| 1237 body | |
| 1238 (init-navigator arg) | |
| 1239 (:base-args params))) | |
| 1240 navigator)) | |
| 1241 | |
| 1242 (defn- set-indent [params navigator offsets] | |
| 1243 (let [relative-to (if (:colon params) :current :block)] | |
| 1244 (pprint-indent relative-to (:n params)) | |
| 1245 navigator)) | |
| 1246 | |
| 1247 ;;; TODO: support ~:T section options for ~T | |
| 1248 | |
| 1249 (defn- conditional-newline [params navigator offsets] | |
| 1250 (let [kind (if (:colon params) | |
| 1251 (if (:at params) :mandatory :fill) | |
| 1252 (if (:at params) :miser :linear))] | |
| 1253 (pprint-newline kind) | |
| 1254 navigator)) | |
| 1255 | |
| 1256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1257 ;;; The table of directives we support, each with its params, | |
| 1258 ;;; properties, and the compilation function | |
| 1259 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1260 | |
| 1261 ;; We start with a couple of helpers | |
| 1262 (defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ] | |
| 1263 [char, | |
| 1264 {:directive char, | |
| 1265 :params `(array-map ~@params), | |
| 1266 :flags flags, | |
| 1267 :bracket-info bracket-info, | |
| 1268 :generator-fn (concat '(fn [ params offset]) generator-fn) }]) | |
| 1269 | |
| 1270 (defmacro ^{:private true} | |
| 1271 defdirectives | |
| 1272 [ & directives ] | |
| 1273 `(def ^{:private true} | |
| 1274 directive-table (hash-map ~@(mapcat process-directive-table-element directives)))) | |
| 1275 | |
| 1276 (defdirectives | |
| 1277 (\A | |
| 1278 [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] | |
| 1279 #{ :at :colon :both} {} | |
| 1280 #(format-ascii print-str %1 %2 %3)) | |
| 1281 | |
| 1282 (\S | |
| 1283 [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] | |
| 1284 #{ :at :colon :both} {} | |
| 1285 #(format-ascii pr-str %1 %2 %3)) | |
| 1286 | |
| 1287 (\D | |
| 1288 [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] | |
| 1289 :commainterval [ 3 Integer]] | |
| 1290 #{ :at :colon :both } {} | |
| 1291 #(format-integer 10 %1 %2 %3)) | |
| 1292 | |
| 1293 (\B | |
| 1294 [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] | |
| 1295 :commainterval [ 3 Integer]] | |
| 1296 #{ :at :colon :both } {} | |
| 1297 #(format-integer 2 %1 %2 %3)) | |
| 1298 | |
| 1299 (\O | |
| 1300 [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] | |
| 1301 :commainterval [ 3 Integer]] | |
| 1302 #{ :at :colon :both } {} | |
| 1303 #(format-integer 8 %1 %2 %3)) | |
| 1304 | |
| 1305 (\X | |
| 1306 [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] | |
| 1307 :commainterval [ 3 Integer]] | |
| 1308 #{ :at :colon :both } {} | |
| 1309 #(format-integer 16 %1 %2 %3)) | |
| 1310 | |
| 1311 (\R | |
| 1312 [:base [nil Integer] :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] | |
| 1313 :commainterval [ 3 Integer]] | |
| 1314 #{ :at :colon :both } {} | |
| 1315 (do | |
| 1316 (cond ; ~R is overloaded with bizareness | |
| 1317 (first (:base params)) #(format-integer (:base %1) %1 %2 %3) | |
| 1318 (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3) | |
| 1319 (:at params) #(format-new-roman %1 %2 %3) | |
| 1320 (:colon params) #(format-ordinal-english %1 %2 %3) | |
| 1321 true #(format-cardinal-english %1 %2 %3)))) | |
| 1322 | |
| 1323 (\P | |
| 1324 [ ] | |
| 1325 #{ :at :colon :both } {} | |
| 1326 (fn [params navigator offsets] | |
| 1327 (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator) | |
| 1328 strs (if (:at params) ["y" "ies"] ["" "s"]) | |
| 1329 [arg navigator] (next-arg navigator)] | |
| 1330 (print (if (= arg 1) (first strs) (second strs))) | |
| 1331 navigator))) | |
| 1332 | |
| 1333 (\C | |
| 1334 [:char-format [nil Character]] | |
| 1335 #{ :at :colon :both } {} | |
| 1336 (cond | |
| 1337 (:colon params) pretty-character | |
| 1338 (:at params) readable-character | |
| 1339 :else plain-character)) | |
| 1340 | |
| 1341 (\F | |
| 1342 [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character] | |
| 1343 :padchar [\space Character] ] | |
| 1344 #{ :at } {} | |
| 1345 fixed-float) | |
| 1346 | |
| 1347 (\E | |
| 1348 [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] | |
| 1349 :overflowchar [nil Character] :padchar [\space Character] | |
| 1350 :exponentchar [nil Character] ] | |
| 1351 #{ :at } {} | |
| 1352 exponential-float) | |
| 1353 | |
| 1354 (\G | |
| 1355 [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] | |
| 1356 :overflowchar [nil Character] :padchar [\space Character] | |
| 1357 :exponentchar [nil Character] ] | |
| 1358 #{ :at } {} | |
| 1359 general-float) | |
| 1360 | |
| 1361 (\$ | |
| 1362 [ :d [2 Integer] :n [1 Integer] :w [0 Integer] :padchar [\space Character]] | |
| 1363 #{ :at :colon :both} {} | |
| 1364 dollar-float) | |
| 1365 | |
| 1366 (\% | |
| 1367 [ :count [1 Integer] ] | |
| 1368 #{ } {} | |
| 1369 (fn [params arg-navigator offsets] | |
| 1370 (dotimes [i (:count params)] | |
| 1371 (prn)) | |
| 1372 arg-navigator)) | |
| 1373 | |
| 1374 (\& | |
| 1375 [ :count [1 Integer] ] | |
| 1376 #{ :pretty } {} | |
| 1377 (fn [params arg-navigator offsets] | |
| 1378 (let [cnt (:count params)] | |
| 1379 (if (pos? cnt) (fresh-line)) | |
| 1380 (dotimes [i (dec cnt)] | |
| 1381 (prn))) | |
| 1382 arg-navigator)) | |
| 1383 | |
| 1384 (\| | |
| 1385 [ :count [1 Integer] ] | |
| 1386 #{ } {} | |
| 1387 (fn [params arg-navigator offsets] | |
| 1388 (dotimes [i (:count params)] | |
| 1389 (print \formfeed)) | |
| 1390 arg-navigator)) | |
| 1391 | |
| 1392 (\~ | |
| 1393 [ :n [1 Integer] ] | |
| 1394 #{ } {} | |
| 1395 (fn [params arg-navigator offsets] | |
| 1396 (let [n (:n params)] | |
| 1397 (print (apply str (repeat n \~))) | |
| 1398 arg-navigator))) | |
| 1399 | |
| 1400 (\newline ;; Whitespace supression is handled in the compilation loop | |
| 1401 [ ] | |
| 1402 #{:colon :at} {} | |
| 1403 (fn [params arg-navigator offsets] | |
| 1404 (if (:at params) | |
| 1405 (prn)) | |
| 1406 arg-navigator)) | |
| 1407 | |
| 1408 (\T | |
| 1409 [ :colnum [1 Integer] :colinc [1 Integer] ] | |
| 1410 #{ :at :pretty } {} | |
| 1411 (if (:at params) | |
| 1412 #(relative-tabulation %1 %2 %3) | |
| 1413 #(absolute-tabulation %1 %2 %3))) | |
| 1414 | |
| 1415 (\* | |
| 1416 [ :n [1 Integer] ] | |
| 1417 #{ :colon :at } {} | |
| 1418 (fn [params navigator offsets] | |
| 1419 (let [n (:n params)] | |
| 1420 (if (:at params) | |
| 1421 (absolute-reposition navigator n) | |
| 1422 (relative-reposition navigator (if (:colon params) (- n) n))) | |
| 1423 ))) | |
| 1424 | |
| 1425 (\? | |
| 1426 [ ] | |
| 1427 #{ :at } {} | |
| 1428 (if (:at params) | |
| 1429 (fn [params navigator offsets] ; args from main arg list | |
| 1430 (let [[subformat navigator] (get-format-arg navigator)] | |
| 1431 (execute-sub-format subformat navigator (:base-args params)))) | |
| 1432 (fn [params navigator offsets] ; args from sub-list | |
| 1433 (let [[subformat navigator] (get-format-arg navigator) | |
| 1434 [subargs navigator] (next-arg navigator) | |
| 1435 sub-navigator (init-navigator subargs)] | |
| 1436 (execute-sub-format subformat sub-navigator (:base-args params)) | |
| 1437 navigator)))) | |
| 1438 | |
| 1439 | |
| 1440 (\( | |
| 1441 [ ] | |
| 1442 #{ :colon :at :both} { :right \), :allows-separator nil, :else nil } | |
| 1443 (let [mod-case-writer (cond | |
| 1444 (and (:at params) (:colon params)) | |
| 1445 upcase-writer | |
| 1446 | |
| 1447 (:colon params) | |
| 1448 capitalize-word-writer | |
| 1449 | |
| 1450 (:at params) | |
| 1451 init-cap-writer | |
| 1452 | |
| 1453 :else | |
| 1454 downcase-writer)] | |
| 1455 #(modify-case mod-case-writer %1 %2 %3))) | |
| 1456 | |
| 1457 (\) [] #{} {} nil) | |
| 1458 | |
| 1459 (\[ | |
| 1460 [ :selector [nil Integer] ] | |
| 1461 #{ :colon :at } { :right \], :allows-separator true, :else :last } | |
| 1462 (cond | |
| 1463 (:colon params) | |
| 1464 boolean-conditional | |
| 1465 | |
| 1466 (:at params) | |
| 1467 check-arg-conditional | |
| 1468 | |
| 1469 true | |
| 1470 choice-conditional)) | |
| 1471 | |
| 1472 (\; [:min-remaining [nil Integer] :max-columns [nil Integer]] | |
| 1473 #{ :colon } { :separator true } nil) | |
| 1474 | |
| 1475 (\] [] #{} {} nil) | |
| 1476 | |
| 1477 (\{ | |
| 1478 [ :max-iterations [nil Integer] ] | |
| 1479 #{ :colon :at :both} { :right \}, :allows-separator false } | |
| 1480 (cond | |
| 1481 (and (:at params) (:colon params)) | |
| 1482 iterate-main-sublists | |
| 1483 | |
| 1484 (:colon params) | |
| 1485 iterate-list-of-sublists | |
| 1486 | |
| 1487 (:at params) | |
| 1488 iterate-main-list | |
| 1489 | |
| 1490 true | |
| 1491 iterate-sublist)) | |
| 1492 | |
| 1493 | |
| 1494 (\} [] #{:colon} {} nil) | |
| 1495 | |
| 1496 (\< | |
| 1497 [:mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character]] | |
| 1498 #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first } | |
| 1499 logical-block-or-justify) | |
| 1500 | |
| 1501 (\> [] #{:colon} {} nil) | |
| 1502 | |
| 1503 ;; TODO: detect errors in cases where colon not allowed | |
| 1504 (\^ [:arg1 [nil Integer] :arg2 [nil Integer] :arg3 [nil Integer]] | |
| 1505 #{:colon} {} | |
| 1506 (fn [params navigator offsets] | |
| 1507 (let [arg1 (:arg1 params) | |
| 1508 arg2 (:arg2 params) | |
| 1509 arg3 (:arg3 params) | |
| 1510 exit (if (:colon params) :colon-up-arrow :up-arrow)] | |
| 1511 (cond | |
| 1512 (and arg1 arg2 arg3) | |
| 1513 (if (<= arg1 arg2 arg3) [exit navigator] navigator) | |
| 1514 | |
| 1515 (and arg1 arg2) | |
| 1516 (if (= arg1 arg2) [exit navigator] navigator) | |
| 1517 | |
| 1518 arg1 | |
| 1519 (if (= arg1 0) [exit navigator] navigator) | |
| 1520 | |
| 1521 true ; TODO: handle looking up the arglist stack for info | |
| 1522 (if (if (:colon params) | |
| 1523 (empty? (:rest (:base-args params))) | |
| 1524 (empty? (:rest navigator))) | |
| 1525 [exit navigator] navigator))))) | |
| 1526 | |
| 1527 (\W | |
| 1528 [] | |
| 1529 #{:at :colon :both} {} | |
| 1530 (if (or (:at params) (:colon params)) | |
| 1531 (let [bindings (concat | |
| 1532 (if (:at params) [:level nil :length nil] []) | |
| 1533 (if (:colon params) [:pretty true] []))] | |
| 1534 (fn [params navigator offsets] | |
| 1535 (let [[arg navigator] (next-arg navigator)] | |
| 1536 (if (apply write arg bindings) | |
| 1537 [:up-arrow navigator] | |
| 1538 navigator)))) | |
| 1539 (fn [params navigator offsets] | |
| 1540 (let [[arg navigator] (next-arg navigator)] | |
| 1541 (if (write-out arg) | |
| 1542 [:up-arrow navigator] | |
| 1543 navigator))))) | |
| 1544 | |
| 1545 (\_ | |
| 1546 [] | |
| 1547 #{:at :colon :both} {} | |
| 1548 conditional-newline) | |
| 1549 | |
| 1550 (\I | |
| 1551 [:n [0 Integer]] | |
| 1552 #{:colon} {} | |
| 1553 set-indent) | |
| 1554 ) | |
| 1555 | |
| 1556 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1557 ;;; Code to manage the parameters and flags associated with each | |
| 1558 ;;; directive in the format string. | |
| 1559 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1560 | |
| 1561 (def ^{:private true} | |
| 1562 param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))") | |
| 1563 (def ^{:private true} | |
| 1564 special-params #{ :parameter-from-args :remaining-arg-count }) | |
| 1565 | |
| 1566 (defn- extract-param [[s offset saw-comma]] | |
| 1567 (let [m (re-matcher param-pattern s) | |
| 1568 param (re-find m)] | |
| 1569 (if param | |
| 1570 (let [token-str (first (re-groups m)) | |
| 1571 remainder (subs s (.end m)) | |
| 1572 new-offset (+ offset (.end m))] | |
| 1573 (if (not (= \, (nth remainder 0))) | |
| 1574 [ [token-str offset] [remainder new-offset false]] | |
| 1575 [ [token-str offset] [(subs remainder 1) (inc new-offset) true]])) | |
| 1576 (if saw-comma | |
| 1577 (format-error "Badly formed parameters in format directive" offset) | |
| 1578 [ nil [s offset]])))) | |
| 1579 | |
| 1580 | |
| 1581 (defn- extract-params [s offset] | |
| 1582 (consume extract-param [s offset false])) | |
| 1583 | |
| 1584 (defn- translate-param | |
| 1585 "Translate the string representation of a param to the internalized | |
| 1586 representation" | |
| 1587 [[^String p offset]] | |
| 1588 [(cond | |
| 1589 (= (.length p) 0) nil | |
| 1590 (and (= (.length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args | |
| 1591 (and (= (.length p) 1) (= \# (nth p 0))) :remaining-arg-count | |
| 1592 (and (= (.length p) 2) (= \' (nth p 0))) (nth p 1) | |
| 1593 true (new Integer p)) | |
| 1594 offset]) | |
| 1595 | |
| 1596 (def ^{:private true} | |
| 1597 flag-defs { \: :colon, \@ :at }) | |
| 1598 | |
| 1599 (defn- extract-flags [s offset] | |
| 1600 (consume | |
| 1601 (fn [[s offset flags]] | |
| 1602 (if (empty? s) | |
| 1603 [nil [s offset flags]] | |
| 1604 (let [flag (get flag-defs (first s))] | |
| 1605 (if flag | |
| 1606 (if (contains? flags flag) | |
| 1607 (format-error | |
| 1608 (str "Flag \"" (first s) "\" appears more than once in a directive") | |
| 1609 offset) | |
| 1610 [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]]) | |
| 1611 [nil [s offset flags]])))) | |
| 1612 [s offset {}])) | |
| 1613 | |
| 1614 (defn- check-flags [def flags] | |
| 1615 (let [allowed (:flags def)] | |
| 1616 (if (and (not (:at allowed)) (:at flags)) | |
| 1617 (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"") | |
| 1618 (nth (:at flags) 1))) | |
| 1619 (if (and (not (:colon allowed)) (:colon flags)) | |
| 1620 (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"") | |
| 1621 (nth (:colon flags) 1))) | |
| 1622 (if (and (not (:both allowed)) (:at flags) (:colon flags)) | |
| 1623 (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \"" | |
| 1624 (:directive def) "\"") | |
| 1625 (min (nth (:colon flags) 1) (nth (:at flags) 1)))))) | |
| 1626 | |
| 1627 (defn- map-params | |
| 1628 "Takes a directive definition and the list of actual parameters and | |
| 1629 a map of flags and returns a map of the parameters and flags with defaults | |
| 1630 filled in. We check to make sure that there are the right types and number | |
| 1631 of parameters as well." | |
| 1632 [def params flags offset] | |
| 1633 (check-flags def flags) | |
| 1634 (if (> (count params) (count (:params def))) | |
| 1635 (format-error | |
| 1636 (cl-format | |
| 1637 nil | |
| 1638 "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed" | |
| 1639 (:directive def) (count params) (count (:params def))) | |
| 1640 (second (first params)))) | |
| 1641 (doall | |
| 1642 (map #(let [val (first %1)] | |
| 1643 (if (not (or (nil? val) (contains? special-params val) | |
| 1644 (instance? (second (second %2)) val))) | |
| 1645 (format-error (str "Parameter " (name (first %2)) | |
| 1646 " has bad type in directive \"" (:directive def) "\": " | |
| 1647 (class val)) | |
| 1648 (second %1))) ) | |
| 1649 params (:params def))) | |
| 1650 | |
| 1651 (merge ; create the result map | |
| 1652 (into (array-map) ; start with the default values, make sure the order is right | |
| 1653 (reverse (for [[name [default]] (:params def)] [name [default offset]]))) | |
| 1654 (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils | |
| 1655 flags)) ; and finally add the flags | |
| 1656 | |
| 1657 (defn- compile-directive [s offset] | |
| 1658 (let [[raw-params [rest offset]] (extract-params s offset) | |
| 1659 [_ [rest offset flags]] (extract-flags rest offset) | |
| 1660 directive (first rest) | |
| 1661 def (get directive-table (Character/toUpperCase ^Character directive)) | |
| 1662 params (if def (map-params def (map translate-param raw-params) flags offset))] | |
| 1663 (if (not directive) | |
| 1664 (format-error "Format string ended in the middle of a directive" offset)) | |
| 1665 (if (not def) | |
| 1666 (format-error (str "Directive \"" directive "\" is undefined") offset)) | |
| 1667 [(struct compiled-directive ((:generator-fn def) params offset) def params offset) | |
| 1668 (let [remainder (subs rest 1) | |
| 1669 offset (inc offset) | |
| 1670 trim? (and (= \newline (:directive def)) | |
| 1671 (not (:colon params))) | |
| 1672 trim-count (if trim? (prefix-count remainder [\space \tab]) 0) | |
| 1673 remainder (subs remainder trim-count) | |
| 1674 offset (+ offset trim-count)] | |
| 1675 [remainder offset])])) | |
| 1676 | |
| 1677 (defn- compile-raw-string [s offset] | |
| 1678 (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset)) | |
| 1679 | |
| 1680 (defn- right-bracket [this] (:right (:bracket-info (:def this)))) | |
| 1681 (defn- separator? [this] (:separator (:bracket-info (:def this)))) | |
| 1682 (defn- else-separator? [this] | |
| 1683 (and (:separator (:bracket-info (:def this))) | |
| 1684 (:colon (:params this)))) | |
| 1685 | |
| 1686 | |
| 1687 (declare collect-clauses) | |
| 1688 | |
| 1689 (defn- process-bracket [this remainder] | |
| 1690 (let [[subex remainder] (collect-clauses (:bracket-info (:def this)) | |
| 1691 (:offset this) remainder)] | |
| 1692 [(struct compiled-directive | |
| 1693 (:func this) (:def this) | |
| 1694 (merge (:params this) (tuple-map subex (:offset this))) | |
| 1695 (:offset this)) | |
| 1696 remainder])) | |
| 1697 | |
| 1698 (defn- process-clause [bracket-info offset remainder] | |
| 1699 (consume | |
| 1700 (fn [remainder] | |
| 1701 (if (empty? remainder) | |
| 1702 (format-error "No closing bracket found." offset) | |
| 1703 (let [this (first remainder) | |
| 1704 remainder (next remainder)] | |
| 1705 (cond | |
| 1706 (right-bracket this) | |
| 1707 (process-bracket this remainder) | |
| 1708 | |
| 1709 (= (:right bracket-info) (:directive (:def this))) | |
| 1710 [ nil [:right-bracket (:params this) nil remainder]] | |
| 1711 | |
| 1712 (else-separator? this) | |
| 1713 [nil [:else nil (:params this) remainder]] | |
| 1714 | |
| 1715 (separator? this) | |
| 1716 [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~; | |
| 1717 | |
| 1718 true | |
| 1719 [this remainder])))) | |
| 1720 remainder)) | |
| 1721 | |
| 1722 (defn- collect-clauses [bracket-info offset remainder] | |
| 1723 (second | |
| 1724 (consume | |
| 1725 (fn [[clause-map saw-else remainder]] | |
| 1726 (let [[clause [type right-params else-params remainder]] | |
| 1727 (process-clause bracket-info offset remainder)] | |
| 1728 (cond | |
| 1729 (= type :right-bracket) | |
| 1730 [nil [(merge-with concat clause-map | |
| 1731 {(if saw-else :else :clauses) [clause] | |
| 1732 :right-params right-params}) | |
| 1733 remainder]] | |
| 1734 | |
| 1735 (= type :else) | |
| 1736 (cond | |
| 1737 (:else clause-map) | |
| 1738 (format-error "Two else clauses (\"~:;\") inside bracket construction." offset) | |
| 1739 | |
| 1740 (not (:else bracket-info)) | |
| 1741 (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it." | |
| 1742 offset) | |
| 1743 | |
| 1744 (and (= :first (:else bracket-info)) (seq (:clauses clause-map))) | |
| 1745 (format-error | |
| 1746 "The else clause (\"~:;\") is only allowed in the first position for this directive." | |
| 1747 offset) | |
| 1748 | |
| 1749 true ; if the ~:; is in the last position, the else clause | |
| 1750 ; is next, this was a regular clause | |
| 1751 (if (= :first (:else bracket-info)) | |
| 1752 [true [(merge-with concat clause-map { :else [clause] :else-params else-params}) | |
| 1753 false remainder]] | |
| 1754 [true [(merge-with concat clause-map { :clauses [clause] }) | |
| 1755 true remainder]])) | |
| 1756 | |
| 1757 (= type :separator) | |
| 1758 (cond | |
| 1759 saw-else | |
| 1760 (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset) | |
| 1761 | |
| 1762 (not (:allows-separator bracket-info)) | |
| 1763 (format-error "A separator (\"~;\") is in a bracket type that doesn't support it." | |
| 1764 offset) | |
| 1765 | |
| 1766 true | |
| 1767 [true [(merge-with concat clause-map { :clauses [clause] }) | |
| 1768 false remainder]])))) | |
| 1769 [{ :clauses [] } false remainder]))) | |
| 1770 | |
| 1771 (defn- process-nesting | |
| 1772 "Take a linearly compiled format and process the bracket directives to give it | |
| 1773 the appropriate tree structure" | |
| 1774 [format] | |
| 1775 (first | |
| 1776 (consume | |
| 1777 (fn [remainder] | |
| 1778 (let [this (first remainder) | |
| 1779 remainder (next remainder) | |
| 1780 bracket (:bracket-info (:def this))] | |
| 1781 (if (:right bracket) | |
| 1782 (process-bracket this remainder) | |
| 1783 [this remainder]))) | |
| 1784 format))) | |
| 1785 | |
| 1786 (defn- compile-format | |
| 1787 "Compiles format-str into a compiled format which can be used as an argument | |
| 1788 to cl-format just like a plain format string. Use this function for improved | |
| 1789 performance when you're using the same format string repeatedly" | |
| 1790 [ format-str ] | |
| 1791 ; (prlabel compiling format-str) | |
| 1792 (binding [*format-str* format-str] | |
| 1793 (process-nesting | |
| 1794 (first | |
| 1795 (consume | |
| 1796 (fn [[^String s offset]] | |
| 1797 (if (empty? s) | |
| 1798 [nil s] | |
| 1799 (let [tilde (.indexOf s (int \~))] | |
| 1800 (cond | |
| 1801 (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.length s))]] | |
| 1802 (zero? tilde) (compile-directive (subs s 1) (inc offset)) | |
| 1803 true | |
| 1804 [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]])))) | |
| 1805 [format-str 0]))))) | |
| 1806 | |
| 1807 (defn- needs-pretty | |
| 1808 "determine whether a given compiled format has any directives that depend on the | |
| 1809 column number or pretty printing" | |
| 1810 [format] | |
| 1811 (loop [format format] | |
| 1812 (if (empty? format) | |
| 1813 false | |
| 1814 (if (or (:pretty (:flags (:def (first format)))) | |
| 1815 (some needs-pretty (first (:clauses (:params (first format))))) | |
| 1816 (some needs-pretty (first (:else (:params (first format)))))) | |
| 1817 true | |
| 1818 (recur (next format)))))) | |
| 1819 | |
| 1820 (defn- execute-format | |
| 1821 "Executes the format with the arguments." | |
| 1822 {:skip-wiki true} | |
| 1823 ([stream format args] | |
| 1824 (let [^java.io.Writer real-stream (cond | |
| 1825 (not stream) (java.io.StringWriter.) | |
| 1826 (true? stream) *out* | |
| 1827 :else stream) | |
| 1828 ^java.io.Writer wrapped-stream (if (and (needs-pretty format) | |
| 1829 (not (pretty-writer? real-stream))) | |
| 1830 (get-pretty-writer real-stream) | |
| 1831 real-stream)] | |
| 1832 (binding [*out* wrapped-stream] | |
| 1833 (try | |
| 1834 (execute-format format args) | |
| 1835 (finally | |
| 1836 (if-not (identical? real-stream wrapped-stream) | |
| 1837 (.flush wrapped-stream)))) | |
| 1838 (if (not stream) (.toString real-stream))))) | |
| 1839 ([format args] | |
| 1840 (map-passing-context | |
| 1841 (fn [element context] | |
| 1842 (if (abort? context) | |
| 1843 [nil context] | |
| 1844 (let [[params args] (realize-parameter-list | |
| 1845 (:params element) context) | |
| 1846 [params offsets] (unzip-map params) | |
| 1847 params (assoc params :base-args args)] | |
| 1848 [nil (apply (:func element) [params args offsets])]))) | |
| 1849 args | |
| 1850 format) | |
| 1851 nil)) | |
| 1852 | |
| 1853 ;;; This is a bad idea, but it prevents us from leaking private symbols | |
| 1854 ;;; This should all be replaced by really compiled formats anyway. | |
| 1855 (def ^{:private true} cached-compile (memoize compile-format)) | |
| 1856 | |
| 1857 (defmacro formatter | |
| 1858 "Makes a function which can directly run format-in. The function is | |
| 1859 fn [stream & args] ... and returns nil unless the stream is nil (meaning | |
| 1860 output to a string) in which case it returns the resulting string. | |
| 1861 | |
| 1862 format-in can be either a control string or a previously compiled format." | |
| 1863 {:added "1.2"} | |
| 1864 [format-in] | |
| 1865 `(let [format-in# ~format-in | |
| 1866 my-c-c# (var-get (get (ns-interns (the-ns 'clojure.pprint)) | |
| 1867 '~'cached-compile)) | |
| 1868 my-e-f# (var-get (get (ns-interns (the-ns 'clojure.pprint)) | |
| 1869 '~'execute-format)) | |
| 1870 my-i-n# (var-get (get (ns-interns (the-ns 'clojure.pprint)) | |
| 1871 '~'init-navigator)) | |
| 1872 cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)] | |
| 1873 (fn [stream# & args#] | |
| 1874 (let [navigator# (my-i-n# args#)] | |
| 1875 (my-e-f# stream# cf# navigator#))))) | |
| 1876 | |
| 1877 (defmacro formatter-out | |
| 1878 "Makes a function which can directly run format-in. The function is | |
| 1879 fn [& args] ... and returns nil. This version of the formatter macro is | |
| 1880 designed to be used with *out* set to an appropriate Writer. In particular, | |
| 1881 this is meant to be used as part of a pretty printer dispatch method. | |
| 1882 | |
| 1883 format-in can be either a control string or a previously compiled format." | |
| 1884 {:added "1.2"} | |
| 1885 [format-in] | |
| 1886 `(let [format-in# ~format-in | |
| 1887 cf# (if (string? format-in#) (#'clojure.pprint/cached-compile format-in#) format-in#)] | |
| 1888 (fn [& args#] | |
| 1889 (let [navigator# (#'clojure.pprint/init-navigator args#)] | |
| 1890 (#'clojure.pprint/execute-format cf# navigator#))))) |