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
)
75 (check-type (car x
) (eql :path
))
76 `(:path
(:ancestor-or-self
:node
)
78 (parse-pattern str
))))
81 (defun pattern-thunk-matches-p (pattern-thunk node
)
83 (xpath:all-nodes
(funcall pattern-thunk
(xpath:make-context node
)))))
85 (defun ancestors-using-count-and-from (node count from
)
88 (funcall (xpath::axis-function
:ancestor-or-self
) node
))))
89 (remove-if-not (lambda (ancestor)
90 (pattern-thunk-matches-p count ancestor
))
94 when
(pattern-thunk-matches-p from a
)
100 (defun node-position-among-siblings (node count
)
102 (count-if (lambda (sibling)
103 (pattern-thunk-matches-p count sibling
))
105 (funcall (xpath::axis-function
:preceding-sibling
) node
)))))
107 (defun compute-number-list (level node count from
)
110 (let ((uri (xpath-protocol:namespace-uri node
))
111 (lname (xpath-protocol:local-name node
)))
113 (let ((node (xpath:context-node ctx
)))
114 (xpath-sys:make-node-set
115 (if (and (xpath-protocol:node-type-p node
:element
)
116 (equal (xpath-protocol:namespace-uri node
) uri
)
117 (equal (xpath-protocol:local-name node
) lname
))
121 ((equal level
"single")
122 (let ((ancestor (car (ancestors-using-count-and-from node count from
))))
124 (list (node-position-among-siblings ancestor count
))
126 ((equal level
"multiple")
127 (mapcar (lambda (ancestor)
128 (node-position-among-siblings ancestor count
))
130 (ancestors-using-count-and-from node count from
))))
132 (destructuring-bind (root)
133 (xpath::force
(funcall (xpath::axis-function
:root
) node
))
134 (let ((nodes (xpath::force
136 (xpath::subpipe-before
138 (funcall (xpath::axis-function
:descendant-or-self
) root
))
142 for
(current . rest
) on nodes
143 when
(pattern-thunk-matches-p from current
)
149 count
(pattern-thunk-matches-p count n
))))))
151 (xslt-error "invalid number level: ~A" level
))))
153 (xpath::deflexer format-lexer
154 ("([a-zA-Z0-9]+)" (x) (values :format x
))
155 ("([^a-zA-Z0-9]+)" (x) (values :text x
)))
157 (defun format-number-token (str n
)
159 ((or (equal str
"a") (equal str
"A"))
160 (let ((start (if (equal str
"a") 96 64)))
162 (code-char (1+ start
))
164 (with-output-to-string (r)
168 for
(rest digit
) = (multiple-value-list
171 (write-char (code-char (+ start digit
)) r
)))))))
173 (format nil
"~(~@R~)" n
))
175 (format nil
"~@R" n
))
177 (unless (cl-ppcre:all-matches
"^0*1$" str
)
178 ;; unsupported format
180 (format nil
"~v,'0D" (length str
) n
))))
182 (defun group-numbers (str separator size
)
185 for i from
(1- (length str
)) downto
0
188 (when (and (zerop (mod i size
)) (plusp i
))
189 (write-string separator
))))
191 ;;; fixme: unicode support
192 (defun format-number-list
193 (list format lang letter-value grouping-separator grouping-size
)
194 (declare (ignore lang letter-value
))
195 (with-output-to-string (*standard-output
*)
196 (let ((lexer (format-lexer format
))
200 (multiple-value-bind (type str
) (funcall lexer
)
209 (setf seen-text-p t
))
213 (setf seen-text-p nil
)
214 (setf last-token str
)
215 (let* ((n (pop list
))
216 (formatted (format-number-token str n
)))
217 (write-string (if (and grouping-separator
219 (group-numbers formatted