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