Forwards compatible processing: Unknown instruction elements
[xuriella.git] / number.lisp
blob253bb74873db35afd2e5147ca2a8ed466d46710b
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 (compile-pattern count env)))
37 (from (and from (compile-pattern 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 compile-pattern (str env)
76 (compile-xpath
77 `(xpath:xpath
78 (:union
79 ,@(mapcar #'naive-pattern-expression (parse-pattern str))))
80 env))
82 (defun pattern-thunk-matches-p (pattern-thunk node)
83 (find node
84 (xpath:all-nodes (funcall pattern-thunk (xpath:make-context node)))
85 :test #'xpath-protocol:node-equal))
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 (ctx)
127 (let ((ctx-node (xpath:context-node ctx)))
128 (xpath-sys:make-node-set
129 (if (if (eq node-type :element)
130 (and (xpath-protocol:node-type-p ctx-node :element)
131 (equal (xpath-protocol:namespace-uri ctx-node)
132 uri)
133 (equal (xpath-protocol:local-name ctx-node)
134 lname))
135 (xpath-protocol:node-type-p ctx-node node-type))
136 (list ctx-node)
137 nil)))))))
138 (cond
139 ((equal level "single")
140 (let ((ancestor (car (ancestors-using-count-and-from node count from))))
141 (if ancestor
142 (list (node-position-among-siblings ancestor count))
143 nil)))
144 ((equal level "multiple")
145 (mapcar (lambda (ancestor)
146 (node-position-among-siblings ancestor count))
147 (reverse
148 (ancestors-using-count-and-from node count from))))
149 ((equal level "any")
150 (destructuring-bind (root)
151 (xpath::force (funcall (xpath::axis-function :root) node))
152 (let ((nodes (xpath::force
153 (xpath::append-pipes
154 (xpath::subpipe-before
155 node
156 (funcall (xpath::axis-function :descendant-or-self) root))
157 (list node)))))
158 (when from
159 (loop
160 for (current . rest) on nodes
161 when (pattern-thunk-matches-p from current)
163 (setf nodes rest)))
164 (list
165 (loop
166 for n in nodes
167 count (pattern-thunk-matches-p count n))))))
169 (xslt-error "invalid number level: ~A" level))))
171 (xpath::deflexer (format-lexer :ignore-whitespace nil)
172 ;; zzz just enough unicode "support" here to pass the tests
173 (#.(format nil "([a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :format x))
174 (#.(format nil "([^a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :text x)))
176 (defun format-number-token (str n)
177 (cond
178 ((or (equal str "a")
179 (equal str "A")
180 ;; zzz just enough unicode "support" here to pass the tests
181 (equal str #.(string (code-char 945))))
182 (let ((start (char-code (elt str 0)))
183 (greekp (equal str #.(string (code-char 945)))))
184 (when (zerop n)
185 (xslt-error "cannot format zero"))
186 (nreverse
187 (with-output-to-string (r)
188 (loop
189 for m = n then rest
190 for (rest digit) = (multiple-value-list
191 (truncate (1- m)
192 (if greekp 25 26)))
194 (cond
195 ((plusp rest)
196 (write-char (code-char (+ start digit)) r))
198 (write-char (code-char (+ start digit)) r)
199 (return))))))))
200 ((equal str "i")
201 (if (zerop n)
203 (format nil "~(~@R~)" n)))
204 ((equal str "I")
205 (if (zerop n)
207 (format nil "~@R" n)))
209 (unless (cl-ppcre:all-matches "^0*1$" str)
210 ;; unsupported format
211 (setf str "1"))
212 (format nil "~v,'0D" (length str) n))))
214 (defun group-numbers (str separator size stream)
215 (loop
216 for c across str
217 for i from (1- (length str)) downto 0
219 (write-char c stream)
220 (when (and (zerop (mod i size)) (plusp i))
221 (write-string separator stream))))
223 ;;; fixme: unicode support
224 (defun format-number-list
225 (list format lang letter-value grouping-separator grouping-size)
226 (declare (ignore lang letter-value))
227 (if (some #'xpath::nan-p list)
228 "NaN"
229 (multiple-value-bind (prefix pairs suffix)
230 (parse-number-format format)
231 (with-output-to-string (s)
232 (write-string prefix s)
233 (loop
234 for (separator . subformat) in pairs
235 for n in list
236 for formatted = (format-number-token subformat n)
238 (when separator
239 (write-string separator s))
240 (if (and grouping-separator
241 grouping-size)
242 (group-numbers formatted
243 grouping-separator
244 grouping-size
246 (write-string formatted s)))
247 (write-string suffix s)))))
249 (defun parse-number-format (format)
250 (let ((lexer (format-lexer format))
251 (prefix "")
252 (conses '())
253 (suffix "")
254 (current-text nil))
255 (loop
256 (multiple-value-bind (type str) (funcall lexer)
257 (ecase type
258 ((nil :eof)
259 (return))
260 (:text
261 (if conses
262 (setf current-text str)
263 (setf prefix str)))
264 (:format
265 (push (cons (if conses
266 (or current-text ".")
267 nil)
268 str)
269 conses)
270 (setf current-text nil)))))
271 (when current-text
272 (setf suffix current-text))
273 (unless conses
274 (setf conses (list (cons nil "1"))))
275 (let* ((tail-cons (car conses))
276 (tail (if (car tail-cons)
277 conses
278 (push (cons "." (cdr tail-cons)) conses))))
279 (setf conses (nreverse conses))
280 (setf (cdr tail) tail))
281 (values prefix conses suffix)))