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