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