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
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
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.
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
)
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
))
43 (and grouping-separator
(compile-avt grouping-separator env
)))
44 (grouping-size (and grouping-size
(compile-avt grouping-size env
))))
46 (let ((value (when value
47 (round (xpath:number-value
48 (funcall value ctx
)))))
49 (format (funcall format ctx
))
50 (lang (funcall lang ctx
))
51 (letter-value (funcall letter-value ctx
))
52 (grouping-separator (when grouping-separator
53 (funcall grouping-separator ctx
)))
54 (grouping-size (when grouping-size
56 (funcall grouping-size ctx
)))))
61 (compute-number-list (or level
"single")
62 (xpath::context-node ctx
)
71 (defun compile-pattern (str env
)
75 ,@(mapcar #'naive-pattern-expression
(parse-pattern str
))))
78 (defun pattern-thunk-matches-p (pattern-thunk node
)
80 (xpath:all-nodes
(funcall pattern-thunk
(xpath:make-context node
)))))
82 (defun ancestors-using-count-and-from (node count from
)
85 (funcall (xpath::axis-function
:ancestor-or-self
) node
))))
86 (remove-if-not (lambda (ancestor)
87 (pattern-thunk-matches-p count ancestor
))
91 when
(pattern-thunk-matches-p from a
)
97 (defun node-position-among-siblings (node count
)
99 (count-if (lambda (sibling)
100 (pattern-thunk-matches-p count sibling
))
102 (funcall (xpath::axis-function
:preceding-sibling
) node
)))))
104 (defun compute-number-list (level node count from
)
107 (let ((uri (xpath-protocol:namespace-uri node
))
108 (lname (xpath-protocol:local-name node
)))
110 (let ((node (xpath:context-node ctx
)))
111 (xpath-sys:make-node-set
112 (if (and (xpath-protocol:node-type-p node
:element
)
113 (equal (xpath-protocol:namespace-uri node
) uri
)
114 (equal (xpath-protocol:local-name node
) lname
))
118 ((equal level
"single")
119 (let ((ancestor (car (ancestors-using-count-and-from node count from
))))
121 (list (node-position-among-siblings ancestor count
))
123 ((equal level
"multiple")
124 (mapcar (lambda (ancestor)
125 (node-position-among-siblings ancestor count
))
127 (ancestors-using-count-and-from node count from
))))
129 (destructuring-bind (root)
130 (xpath::force
(funcall (xpath::axis-function
:root
) node
))
131 (let ((nodes (xpath::force
133 (xpath::subpipe-before
135 (funcall (xpath::axis-function
:descendant-or-self
) root
))
139 for
(current . rest
) on nodes
140 when
(pattern-thunk-matches-p from current
)
146 count
(pattern-thunk-matches-p count n
))))))
148 (xslt-error "invalid number level: ~A" level
))))
150 (xpath::deflexer
(format-lexer :ignore-whitespace nil
)
151 ("([a-zA-Z0-9]+)" (x) (values :format x
))
152 ("([^a-zA-Z0-9]+)" (x) (values :text x
)))
154 (defun format-number-token (str n
)
156 ((or (equal str
"a") (equal str
"A"))
157 (let ((start (if (equal str
"a") 96 64)))
159 (code-char (1+ start
))
161 (with-output-to-string (r)
165 for
(rest digit
) = (multiple-value-list
168 (write-char (code-char (+ start digit
)) r
)))))))
170 (format nil
"~(~@R~)" n
))
172 (format nil
"~@R" n
))
174 (unless (cl-ppcre:all-matches
"^0*1$" str
)
175 ;; unsupported format
177 (format nil
"~v,'0D" (length str
) n
))))
179 (defun group-numbers (str separator size stream
)
182 for i from
(1- (length str
)) downto
0
184 (write-char c stream
)
185 (when (and (zerop (mod i size
)) (plusp i
))
186 (write-string separator stream
))))
188 ;;; fixme: unicode support
189 (defun format-number-list
190 (list format lang letter-value grouping-separator grouping-size
)
191 (declare (ignore lang letter-value
))
192 (multiple-value-bind (prefix pairs suffix
)
193 (parse-number-format format
)
194 (with-output-to-string (s)
195 (write-string prefix s
)
197 for
(separator . subformat
) in pairs
199 for formatted
= (format-number-token subformat n
)
202 (write-string separator s
))
203 (if (and grouping-separator
205 (group-numbers formatted
209 (write-string formatted s
)))
210 (write-string suffix s
))))
212 (defun parse-number-format (format)
213 (let ((lexer (format-lexer format
))
219 (multiple-value-bind (type str
) (funcall lexer
)
225 (setf current-text str
)
228 (push (cons (if conses
229 (or current-text
".")
233 (setf current-text nil
)))))
235 (setf suffix current-text
))
237 (setf conses
(list (cons nil
"1"))))
239 (setf conses
(nreverse conses
))
240 (setf (cdr tail
) tail
))
241 (values prefix conses suffix
)))