Comment recovery
[xuriella.git] / number.lisp
bloba9701d9f27eec2761d65f86607cd3dce43cb7f0c
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)))))
86 (defun ancestors-using-count-and-from (node count from)
87 (let ((ancestors
88 (xpath::force
89 (funcall (xpath::axis-function :ancestor-or-self) node))))
90 (remove-if-not (lambda (ancestor)
91 (pattern-thunk-matches-p count ancestor))
92 (if from
93 (loop
94 for a in ancestors
95 when (pattern-thunk-matches-p from a)
96 do (return result)
97 collect a into result
98 finally (return ancestors))
99 ancestors))))
101 (defun node-position-among-siblings (node count)
103 (count-if (lambda (sibling)
104 (pattern-thunk-matches-p count sibling))
105 (xpath::force
106 (funcall (xpath::axis-function :preceding-sibling) node)))))
108 (defun node-type (node)
109 (dolist (type '(:element
110 :attribute
111 :text
112 :document
113 :namespace
114 :processing-instruction
115 :comment))
116 (when (xpath-protocol:node-type-p node type)
117 (return type))))
119 (defun compute-number-list (level node count from)
120 (unless count
121 (setf count
122 (let ((uri (xpath-protocol:namespace-uri node))
123 (lname (xpath-protocol:local-name node))
124 (node-type (node-type node)))
125 (lambda (ctx)
126 (let ((ctx-node (xpath:context-node ctx)))
127 (xpath-sys:make-node-set
128 (if (if (eq node-type :element)
129 (and (xpath-protocol:node-type-p ctx-node :element)
130 (equal (xpath-protocol:namespace-uri ctx-node)
131 uri)
132 (equal (xpath-protocol:local-name ctx-node)
133 lname))
134 (xpath-protocol:node-type-p ctx-node node-type))
135 (list ctx-node)
136 nil)))))))
137 (cond
138 ((equal level "single")
139 (let ((ancestor (car (ancestors-using-count-and-from node count from))))
140 (if ancestor
141 (list (node-position-among-siblings ancestor count))
142 nil)))
143 ((equal level "multiple")
144 (mapcar (lambda (ancestor)
145 (node-position-among-siblings ancestor count))
146 (reverse
147 (ancestors-using-count-and-from node count from))))
148 ((equal level "any")
149 (destructuring-bind (root)
150 (xpath::force (funcall (xpath::axis-function :root) node))
151 (let ((nodes (xpath::force
152 (xpath::append-pipes
153 (xpath::subpipe-before
154 node
155 (funcall (xpath::axis-function :descendant-or-self) root))
156 (list node)))))
157 (when from
158 (loop
159 for (current . rest) on nodes
160 when (pattern-thunk-matches-p from current)
162 (setf nodes rest)))
163 (list
164 (loop
165 for n in nodes
166 count (pattern-thunk-matches-p count n))))))
168 (xslt-error "invalid number level: ~A" level))))
170 (xpath::deflexer (format-lexer :ignore-whitespace nil)
171 ;; zzz just enough unicode "support" here to pass the tests
172 (#.(format nil "([a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :format x))
173 (#.(format nil "([^a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :text x)))
175 (defun format-number-token (str n)
176 (cond
177 ((or (equal str "a")
178 (equal str "A")
179 ;; zzz just enough unicode "support" here to pass the tests
180 (equal str #.(string (code-char 945))))
181 (let ((start (char-code (elt str 0)))
182 (greekp (equal str #.(string (code-char 945)))))
183 (when (zerop n)
184 (xslt-error "cannot format zero"))
185 (nreverse
186 (with-output-to-string (r)
187 (loop
188 for m = n then rest
189 for (rest digit) = (multiple-value-list
190 (truncate (1- m)
191 (if greekp 25 26)))
193 (cond
194 ((plusp rest)
195 (write-char (code-char (+ start digit)) r))
197 (write-char (code-char (+ start digit)) r)
198 (return))))))))
199 ((equal str "i")
200 (if (zerop n)
202 (format nil "~(~@R~)" n)))
203 ((equal str "I")
204 (if (zerop n)
206 (format nil "~@R" n)))
208 (unless (cl-ppcre:all-matches "^0*1$" str)
209 ;; unsupported format
210 (setf str "1"))
211 (format nil "~v,'0D" (length str) n))))
213 (defun group-numbers (str separator size stream)
214 (loop
215 for c across str
216 for i from (1- (length str)) downto 0
218 (write-char c stream)
219 (when (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 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 (when current-text
271 (setf suffix current-text))
272 (unless conses
273 (setf conses (list (cons nil "1"))))
274 (let* ((tail-cons (car conses))
275 (tail (if (car tail-cons)
276 conses
277 (push (cons "." (cdr tail-cons)) conses))))
278 (setf conses (nreverse conses))
279 (setf (cdr tail) tail))
280 (values prefix conses suffix)))