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
55 (funcall grouping-size ctx
))))
60 (compute-number-list (or level
"single")
61 (xpath::context-node ctx
)
70 (defun compile-pattern (str env
)
74 ,@(mapcar #'naive-pattern-expression
(parse-pattern str
))))
77 (defun pattern-thunk-matches-p (pattern-thunk node
)
79 (xpath:all-nodes
(funcall pattern-thunk
(xpath:make-context node
)))))
81 (defun ancestors-using-count-and-from (node count from
)
84 (funcall (xpath::axis-function
:ancestor-or-self
) node
))))
85 (remove-if-not (lambda (ancestor)
86 (pattern-thunk-matches-p count ancestor
))
90 when
(pattern-thunk-matches-p from a
)
96 (defun node-position-among-siblings (node count
)
98 (count-if (lambda (sibling)
99 (pattern-thunk-matches-p count sibling
))
101 (funcall (xpath::axis-function
:preceding-sibling
) node
)))))
103 (defun compute-number-list (level node count from
)
106 (let ((uri (xpath-protocol:namespace-uri node
))
107 (lname (xpath-protocol:local-name node
)))
109 (let ((node (xpath:context-node ctx
)))
110 (xpath-sys:make-node-set
111 (if (and (xpath-protocol:node-type-p node
:element
)
112 (equal (xpath-protocol:namespace-uri node
) uri
)
113 (equal (xpath-protocol:local-name node
) lname
))
117 ((equal level
"single")
118 (let ((ancestor (car (ancestors-using-count-and-from node count from
))))
120 (list (node-position-among-siblings ancestor count
))
122 ((equal level
"multiple")
123 (mapcar (lambda (ancestor)
124 (node-position-among-siblings ancestor count
))
126 (ancestors-using-count-and-from node count from
))))
128 (destructuring-bind (root)
129 (xpath::force
(funcall (xpath::axis-function
:root
) node
))
130 (let ((nodes (xpath::force
132 (xpath::subpipe-before
134 (funcall (xpath::axis-function
:descendant-or-self
) root
))
138 for
(current . rest
) on nodes
139 when
(pattern-thunk-matches-p from current
)
145 count
(pattern-thunk-matches-p count n
))))))
147 (xslt-error "invalid number level: ~A" level
))))
149 (xpath::deflexer format-lexer
150 ("([a-zA-Z0-9]+)" (x) (values :format x
))
151 ("([^a-zA-Z0-9]+)" (x) (values :text x
)))
153 (defun format-number-token (str n
)
155 ((or (equal str
"a") (equal str
"A"))
156 (let ((start (if (equal str
"a") 96 64)))
158 (code-char (1+ start
))
160 (with-output-to-string (r)
164 for
(rest digit
) = (multiple-value-list
167 (write-char (code-char (+ start digit
)) r
)))))))
169 (format nil
"~(~@R~)" n
))
171 (format nil
"~@R" n
))
173 (unless (cl-ppcre:all-matches
"^0*1$" str
)
174 ;; unsupported format
176 (format nil
"~v,'0D" (length str
) n
))))
178 (defun group-numbers (str separator size
)
181 for i from
(1- (length str
)) downto
0
184 (when (and (zerop (mod i size
)) (plusp i
))
185 (write-string separator
))))
187 ;;; fixme: unicode support
188 (defun format-number-list
189 (list format lang letter-value grouping-separator grouping-size
)
190 (declare (ignore lang letter-value
))
191 (with-output-to-string (*standard-output
*)
192 (let ((lexer (format-lexer format
))
196 (multiple-value-bind (type str
) (funcall lexer
)
205 (setf seen-text-p t
))
209 (setf seen-text-p nil
)
210 (setf last-token str
)
211 (let* ((n (pop list
))
212 (formatted (format-number-token str n
)))
213 (write-string (if (and grouping-separator
215 (group-numbers formatted