xsl:extension-element-prefixes also applies to the element itself
[xuriella.git] / format-number.lisp
blob6b579bb2f978fcbb22e0c4f6b48a44f4cb33ded9
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9 ;;;
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12 ;;;
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17 ;;;
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 (in-package :xuriella)
32 (defstruct (decimal-format (:conc-name "DF/"))
33 ;; picture string and output syntax:
34 (decimal-separator #\.) ;active
35 (grouping-separator #\,) ;active
36 (zero-digit #\0) ;active
37 (percent #\%)
38 (per-mille (code-char #x2030))
40 ;; picture string syntax only
41 (digit #\#) ;active
42 (pattern-separator #\;) ;active
44 ;; output syntax only:
45 (infinity "Infinity")
46 (nan "NaN")
47 (minus-sign #\-))
49 (defstruct (picture (:conc-name "PIC/"))
50 percentp
51 per-mille-p
52 prefix
53 suffix
54 integer-part-grouping-positions
55 minimum-integer-part-size
56 fractional-part-grouping-positions
57 minimum-fractional-part-size
58 maximum-fractional-part-size)
60 (defun df/active-characters (df)
61 (format nil "~C~C~C~C~C"
62 (df/decimal-separator df)
63 (df/grouping-separator df)
64 (df/zero-digit df)
65 (df/digit df)
66 (df/pattern-separator df)))
68 (defun df/digits (df)
69 (let ((result (make-array 10))
70 (start (char-code (df/zero-digit df))))
71 (loop
72 for i from 0 below 10
74 (setf (elt result i) (code-char (+ start i))))
75 result))
77 (defun find-decimal-format (lname uri stylesheet &optional (errorp t))
78 (or (gethash (cons lname uri)
79 (stylesheet-decimal-formats stylesheet))
80 (when errorp
81 (xslt-error "decimal format not found: ~A/~A" lname uri))))
83 (defun (setf find-decimal-format) (newval lname uri stylesheet)
84 (setf (gethash (cons lname uri)
85 (stylesheet-decimal-formats stylesheet))
86 newval))
88 (defun decimal-format= (a b)
89 (every (lambda (accessor)
90 (equal (funcall accessor a)
91 (funcall accessor b)))
92 (list #'df/decimal-separator
93 #'df/grouping-separator
94 #'df/zero-digit
95 #'df/percent
96 #'df/per-mille
97 #'df/digit
98 #'df/pattern-separator
99 #'df/infinity
100 #'df/nan
101 #'df/minus-sign)))
103 (xpath-sys:define-xpath-function/lazy
104 xslt :format-number
105 (value picture &optional format-name)
106 (let ((namespaces *namespaces*))
107 (lambda (ctx)
108 (let ((df
109 (if format-name
110 (let ((qname (funcall format-name ctx)))
111 (multiple-value-bind (local-name uri)
112 (decode-qname/runtime qname namespaces nil)
113 (find-decimal-format local-name
114 (or uri "")
115 *stylesheet*)))
116 (find-decimal-format "" "" *stylesheet*))))
117 (multiple-value-bind (pos neg)
118 (parse-picture (xpath:string-value (funcall picture ctx)) df)
119 (format-number (float (xpath:number-value (funcall value ctx))
120 1.0d0)
123 df))))))
125 (defun test-format-number (value picture)
126 (let ((df (make-decimal-format)))
127 (multiple-value-bind (pos neg)
128 (parse-picture picture df)
129 (format-number value pos neg df))))
131 (defun parse-picture (picture df)
132 (destructuring-bind (&optional positive negative &rest erroneous)
133 (split-sequence:split-sequence
134 (df/pattern-separator df)
135 picture)
136 (unless (and positive (not erroneous))
137 (xpath:xpath-error "invalid pattern separators"))
138 (unless negative
139 (setf negative (concatenate 'string
140 (string (df/minus-sign df))
141 positive)))
142 (values (parse-sub-picture positive df)
143 (parse-sub-picture negative df))))
145 (defmacro df/case (df form &rest clauses)
146 `(let ((.form ,form)
147 (.df ,df))
148 (cond
149 ,@(loop
150 for (accessor . body) in clauses
151 collect `((eql (,accessor .df) .form) ,@body)))))
153 (defun parse-integer-picture (picture df start end)
154 (let ((integer-part-grouping-positions '())
155 (minimum-integer-part-size 0)
156 (zero-digit-p nil))
157 (loop
158 for i from start below end
159 for c = (elt picture i)
160 until (eql c (df/decimal-separator df))
162 (df/case df c
163 (df/grouping-separator
164 (push 0 integer-part-grouping-positions))
165 (df/digit
166 (when zero-digit-p
167 (xslt-error
168 "digit not allowed after zero-digit in integer picture"))
169 (when integer-part-grouping-positions
170 (incf (car integer-part-grouping-positions))))
171 (df/zero-digit
172 (setf zero-digit-p t)
173 (when integer-part-grouping-positions
174 (incf (car integer-part-grouping-positions)))
175 (incf minimum-integer-part-size)))
176 finally
177 (when integer-part-grouping-positions
178 ;; zzz I wrote the above algorithm based on the XSLT 2.0 spec,
179 ;; only to find out that the test suite doesn't want
180 ;; multiple INTEGER-PART-GROUPING-POSITIONS. Sun says
181 ;; that only the last one is used:
182 ;; http://java.sun.com/j2se/1.3/docs/api/java/text/DecimalFormat.html
183 (setf integer-part-grouping-positions
184 (list (car integer-part-grouping-positions))))
185 (return (values (1+ i)
186 (loop
187 for pos in integer-part-grouping-positions
188 for accum = pos then (+ accum pos)
189 collect accum)
190 minimum-integer-part-size)))))
192 (defun parse-fractional-picture (picture df start end)
193 (let ((fractional-part-grouping-positions '())
194 (minimum-fractional-part-size 0)
195 (maximum-fractional-part-size 0)
196 (current-grouping 0)
197 (digitp nil))
198 (loop
199 for i from start below end
200 for c = (elt picture i)
202 (df/case df c
203 (df/grouping-separator
204 (push current-grouping fractional-part-grouping-positions))
205 (df/digit
206 (setf digitp t)
207 (incf current-grouping)
208 (incf maximum-fractional-part-size))
209 (df/zero-digit
210 (when digitp
211 (xslt-error
212 "zero-digit not allowed after digit in fractional picture"))
213 (incf current-grouping)
214 (incf minimum-fractional-part-size)
215 (incf maximum-fractional-part-size))
216 (df/decimal-separator
217 (xslt-error "multiple decimal separators found")))
218 finally
219 (return (values (nreverse fractional-part-grouping-positions)
220 minimum-fractional-part-size
221 maximum-fractional-part-size)))))
223 (defun parse-sub-picture (picture df)
224 (let ((active (df/active-characters df)))
225 (flet ((activep (x) (find x active)))
226 (let ((start (position-if #'activep picture))
227 (last (position-if #'activep picture :from-end t)))
228 (unless start
229 (setf start (length picture))
230 (setf last start)
231 (setf picture (format nil "~A~A" picture (df/zero-digit df))))
232 (let* ((end (1+ last))
233 (result (make-picture
234 :percentp (find (df/percent df) picture)
235 :per-mille-p (find (df/per-mille df) picture)
236 :prefix (subseq picture 0 start)
237 :suffix (subseq picture end))))
238 (setf (values start
239 (pic/integer-part-grouping-positions result)
240 (pic/minimum-integer-part-size result))
241 (parse-integer-picture picture df start end))
242 (setf (values (pic/fractional-part-grouping-positions result)
243 (pic/minimum-fractional-part-size result)
244 (pic/maximum-fractional-part-size result))
245 (parse-fractional-picture picture df start end))
246 result)))))
248 (defun format-number (value positive-picture negative-picture df)
249 (if (xpath::nan-p value)
250 (df/nan df)
251 (let ((picture (if (minusp value) negative-picture positive-picture)))
252 (if (xpath::inf-p value)
253 (concatenate 'string
254 (pic/prefix picture)
255 (df/infinity df)
256 (pic/suffix picture))
257 (format-ordinary-number value picture df)))))
259 (defun format-number-~f (number picture df)
260 (let* ((str (format nil "~,vF"
261 (pic/maximum-fractional-part-size picture)
262 number))
263 (str (string-trim (string (df/zero-digit df)) str)) ;for 0.0
264 (digits (df/digits df)))
265 (map 'string
266 (lambda (x)
267 (if (eql x #\.)
268 (df/decimal-separator df)
269 (elt digits (- (char-code x) #.(char-code #\0)))))
270 str)))
272 (defun make-grouping-test (positions)
273 (if (and positions
274 (let ((first (car positions)))
275 (loop
276 for expected = first then (+ expected first)
277 for pos in positions
278 always (eql pos expected))))
279 (let ((first (car positions)))
280 (lambda (x)
281 (and (plusp x) (zerop (mod x first)))))
282 (lambda (x)
283 (and (plusp x) (find x positions)))))
285 (defun format-ordinary-number (value picture df)
286 (let* ((adjusted-number
287 (cond
288 ((pic/percentp picture)
289 (* value 100))
290 ((pic/per-mille-p picture)
291 (* value 1000))
293 value)))
294 (str (format-number-~f (abs adjusted-number) picture df))
295 (left (position (df/decimal-separator df) str))
296 (right (1- (- (length str) left)))
297 (wanted-left (max left (pic/minimum-integer-part-size picture)))
298 (wanted-right (max right (pic/minimum-fractional-part-size picture)))
299 (zero (df/zero-digit df))
300 (left-test (make-grouping-test
301 (pic/integer-part-grouping-positions picture)))
302 (right-test (make-grouping-test
303 (pic/fractional-part-grouping-positions picture))))
304 (with-output-to-string (s)
305 (write-string (pic/prefix picture) s)
306 (loop
307 for i from (1- wanted-left) downto 0
308 for index from (- left wanted-left)
310 (if (< i left)
311 (write-char (elt str index) s)
312 (write-char zero s))
313 (when (funcall left-test i)
314 (write-char (df/grouping-separator df) s)))
315 (when (plusp wanted-right)
316 (write-char (df/decimal-separator df) s)
317 (loop
318 for i from 0 below wanted-right
319 for index from (+ left 1)
321 (when (funcall right-test i)
322 (write-char (df/grouping-separator df) s))
323 (if (< i right)
324 (write-char (elt str index) s)
325 (write-char zero s))))
326 (write-string (pic/suffix picture) s))))