Observe doctype in xuriella:document
[xuriella.git] / number.lisp
blobcde5fdc58fbe934787eaa7556731f793caf88e1e
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,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 (defun xsl-number-value (y)
33 (let ((x (xpath:number-value y)))
34 (if (or (< x 0.5)
35 (xpath::nan-p x)
36 (xpath::inf-p x)
37 (>= x (expt 2 31)) ;-(
39 (xpath:string-value x)
40 (round (xpath::xnum-round x)))))
42 (define-instruction xsl:number (args env)
43 (destructuring-bind (&key level count from value format lang letter-value
44 grouping-separator grouping-size)
45 args
46 (let ((count (and count (without-xslt-current ()
47 (xpath:make-pattern-matcher* count env))))
48 (from (and from (without-xslt-current ()
49 (xpath:make-pattern-matcher* from env))))
50 (value (and value (compile-xpath value env)))
51 (format (compile-avt (or format "1") env))
52 (lang (compile-avt (or lang "") env))
53 (letter-value (compile-avt (or letter-value "foo") env))
54 (grouping-separator
55 (and grouping-separator (compile-avt grouping-separator env)))
56 (grouping-size (and grouping-size (compile-avt grouping-size env))))
57 (lambda (ctx)
58 (let ((value (when value
59 (xsl-number-value (funcall value ctx))))
60 (format (funcall format ctx))
61 (lang (funcall lang ctx))
62 (letter-value (funcall letter-value ctx))
63 (grouping-separator (when grouping-separator
64 (funcall grouping-separator ctx)))
65 (grouping-size (when grouping-size
66 (xpath:number-value
67 (funcall grouping-size ctx)))))
68 (if (stringp value)
69 (write-text value)
70 (write-text
71 (format-number-list
72 (if value
73 (list value)
74 (compute-number-list (or level "single")
75 (xpath::context-node ctx)
76 count
77 from))
78 format
79 lang
80 letter-value
81 grouping-separator
82 grouping-size))))))))
84 (defun pattern-thunk-matches-p (pattern-thunk node)
85 (xpath:matching-value pattern-thunk node))
87 (defun ancestors-using-count-and-from (node count from)
88 (let ((ancestors
89 (xpath::force
90 (funcall (xpath::axis-function :ancestor-or-self) node))))
91 (remove-if-not (lambda (ancestor)
92 (pattern-thunk-matches-p count ancestor))
93 (if from
94 (loop
95 for a in ancestors
96 when (pattern-thunk-matches-p from a)
97 do (return result)
98 collect a into result
99 finally (return ancestors))
100 ancestors))))
102 (defun node-position-among-siblings (node count)
104 (count-if (lambda (sibling)
105 (pattern-thunk-matches-p count sibling))
106 (xpath::force
107 (funcall (xpath::axis-function :preceding-sibling) node)))))
109 (defun node-type (node)
110 (dolist (type '(:element
111 :attribute
112 :text
113 :document
114 :namespace
115 :processing-instruction
116 :comment))
117 (when (xpath-protocol:node-type-p node type)
118 (return type))))
120 (defun compute-number-list (level node count from)
121 (unless count
122 (setf count
123 (let ((uri (xpath-protocol:namespace-uri node))
124 (lname (xpath-protocol:local-name node))
125 (node-type (node-type node)))
126 (lambda (pattern-node)
127 (if (if (eq node-type :element)
128 (and (xpath-protocol:node-type-p pattern-node :element)
129 (equal (xpath-protocol:namespace-uri pattern-node)
130 uri)
131 (equal (xpath-protocol:local-name pattern-node)
132 lname))
133 (xpath-protocol:node-type-p pattern-node node-type))
134 (list t)
135 nil)))))
136 (cond
137 ((equal level "single")
138 (let ((ancestor (car (ancestors-using-count-and-from node count from))))
139 (if ancestor
140 (list (node-position-among-siblings ancestor count))
141 nil)))
142 ((equal level "multiple")
143 (mapcar (lambda (ancestor)
144 (node-position-among-siblings ancestor count))
145 (reverse
146 (ancestors-using-count-and-from node count from))))
147 ((equal level "any")
148 (destructuring-bind (root)
149 (xpath::force (funcall (xpath::axis-function :root) node))
150 (let ((nodes (xpath::force
151 (xpath::append-pipes
152 (xpath::subpipe-before
153 node
154 (funcall (xpath::axis-function :descendant-or-self) root))
155 (list node)))))
156 (when from
157 (loop
158 for (current . rest) on nodes
159 when (pattern-thunk-matches-p from current)
161 (setf nodes rest)))
162 (list
163 (loop
164 for n in nodes
165 count (pattern-thunk-matches-p count n))))))
167 (xslt-error "invalid number level: ~A" level))))
169 (xpath::deflexer (format-lexer :ignore-whitespace nil)
170 ;; zzz just enough unicode "support" here to pass the tests
171 (#.(format nil "([a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :format x))
172 (#.(format nil "([^a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :text x)))
174 (defun format-number-token (str n)
175 (cond
176 ((or (equal str "a")
177 (equal str "A")
178 ;; zzz just enough unicode "support" here to pass the tests
179 (equal str #.(string (code-char 945))))
180 (let ((start (char-code (elt str 0)))
181 (greekp (equal str #.(string (code-char 945)))))
182 (when (zerop n)
183 (xslt-error "cannot format zero"))
184 (nreverse
185 (with-output-to-string (r)
186 (loop
187 for m = n then rest
188 for (rest digit) = (multiple-value-list
189 (truncate (1- m)
190 (if greekp 25 26)))
192 (cond
193 ((plusp rest)
194 (write-char (code-char (+ start digit)) r))
196 (write-char (code-char (+ start digit)) r)
197 (return))))))))
198 ((equal str "i")
199 (if (zerop n)
201 (format nil "~(~@R~)" n)))
202 ((equal str "I")
203 (if (zerop n)
205 (format nil "~@R" n)))
207 (unless (cl-ppcre:all-matches "^0*1$" str)
208 ;; unsupported format
209 (setf str "1"))
210 (format nil "~v,'0D" (length str) n))))
212 (defun group-numbers (str separator size stream)
213 (loop
214 for c across str
215 for i from (1- (length str)) downto 0
217 (write-char c stream)
218 (when (and (plusp size)
219 (and (zerop (mod i size)) (plusp i)))
220 (write-string separator stream))))
222 ;;; fixme: unicode support
223 (defun format-number-list
224 (list format lang letter-value grouping-separator grouping-size)
225 (declare (ignore lang letter-value))
226 (if (some #'xpath::nan-p list)
227 "NaN"
228 (multiple-value-bind (prefix pairs suffix)
229 (parse-number-format format)
230 (with-output-to-string (s)
231 (write-string prefix s)
232 (loop
233 for (separator . subformat) in pairs
234 for n in (remove 0 list)
235 for formatted = (format-number-token subformat n)
237 (when separator
238 (write-string separator s))
239 (if (and grouping-separator
240 grouping-size)
241 (group-numbers formatted
242 grouping-separator
243 grouping-size
245 (write-string formatted s)))
246 (write-string suffix s)))))
248 (defun parse-number-format (format)
249 (let ((lexer (format-lexer format))
250 (prefix "")
251 (conses '())
252 (suffix "")
253 (current-text nil))
254 (loop
255 (multiple-value-bind (type str) (funcall lexer)
256 (ecase type
257 ((nil :eof)
258 (return))
259 (:text
260 (if conses
261 (setf current-text str)
262 (setf prefix str)))
263 (:format
264 (push (cons (if conses
265 (or current-text ".")
266 nil)
267 str)
268 conses)
269 (setf current-text nil)))))
270 (cond
271 (current-text
272 (setf suffix current-text))
273 ((null conses)
274 (setf suffix prefix)))
275 (unless conses
276 (setf conses (list (cons nil "1"))))
277 (let* ((tail-cons (car conses))
278 (tail (if (car tail-cons)
279 conses
280 (push (cons "." (cdr tail-cons)) conses))))
281 (setf conses (nreverse conses))
282 (setf (cdr tail) tail))
283 (values prefix conses suffix)))