Implemented xsl:extension-element-prefixes
[xuriella.git] / parser.lisp
blob6d0635c0422e5f71d84a1cea84e9e14fedfe3dd4
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 (defun map-namespace-declarations (fn element)
33 (let ((parent (stp:parent element)))
34 (maphash (lambda (prefix uri)
35 (unless (and (typep parent 'stp:element)
36 (equal (stp:find-namespace prefix parent) uri))
37 (funcall fn prefix uri)))
38 (cxml-stp-impl::collect-local-namespaces element))))
40 (defun maybe-wrap-namespaces (child exprs)
41 (if (typep child 'stp:element)
42 (let ((bindings '())
43 (excluded-uris '()))
44 (map-namespace-declarations (lambda (prefix uri)
45 (push (list prefix uri) bindings))
46 child)
47 (stp:with-attributes ((erp "exclude-result-prefixes" *xsl*))
48 child
49 (dolist (prefix (words (or erp "")))
50 (when (equal prefix "#default")
51 (setf prefix nil))
52 (push (or (stp:find-namespace prefix child)
53 (xslt-error "namespace not found: ~A" prefix))
54 excluded-uris)))
55 (if (or bindings excluded-uris)
56 `((xsl:with-namespaces ,bindings
57 (xsl:with-excluded-namespaces ,excluded-uris
58 ,@exprs)))
59 exprs))
60 exprs))
62 (defun parse-body (node &optional (start 0) (param-names '()))
63 (let ((n (stp:count-children-if #'identity node)))
64 (labels ((recurse (i)
65 (when (< i n)
66 (let ((child (stp:nth-child i node)))
67 (maybe-wrap-namespaces
68 child
69 (if (namep child "variable")
70 (stp:with-attributes (name select) child
71 (when (and select (stp:list-children child))
72 (xslt-error "variable with select and body"))
73 `((let ((,name ,(or select
74 `(progn ,@(parse-body child)))))
75 (xsl:with-duplicates-check (,name)
76 ,@(recurse (1+ i))))))
77 (cons (parse-instruction child)
78 (recurse (1+ i)))))))))
79 (let ((result (recurse start)))
80 (if param-names
81 `((xsl:with-duplicates-check (,@param-names)
82 ,@result))
83 result)))))
85 (defun parse-param (node)
86 ;; FIXME: empty body?
87 (stp:with-attributes (name select) node
88 (unless name
89 (xslt-error "name not specified for parameter"))
90 (when (and select (stp:list-children node))
91 (xslt-error "param with select and body"))
92 (list name
93 (or select
94 `(progn ,@(parse-body node))))))
96 (defun parse-instruction (node)
97 (typecase node
98 (stp:element
99 (let ((expr
100 (cond
101 ((equal (stp:namespace-uri node) *xsl*)
102 (parse-instruction/xsl-element
103 (or (find-symbol (stp:local-name node) :xuriella)
104 (xslt-error "undefined instruction: ~A"
105 (stp:local-name node)))
106 node))
107 ((find (stp:namespace-uri node)
108 *extension-namespaces*
109 :test #'equal)
110 (parse-fallback-children node))
112 (parse-instruction/literal-element node))))
113 (parent (stp:parent node)))
114 (if (and (equal (stp:base-uri node) (stp:base-uri parent))
115 (equal (stp:namespace-uri parent) *xsl*)
116 (find-symbol (stp:local-name parent) :xuriella))
117 expr
118 `(xsl:with-base-uri ,(stp:base-uri node)
119 ,expr))))
120 (stp:text
121 `(xsl:text ,(stp:data node)))))
123 (defun parse-instruction/literal-element (node)
124 (let ((le
125 `(xsl:literal-element
126 (,(stp:local-name node)
127 ,(stp:namespace-uri node)
128 ,(stp:namespace-prefix node))
129 (xsl:use-attribute-sets
130 ,(stp:attribute-value node "use-attribute-sets" *xsl*))
131 ,@(loop for a in (stp:list-attributes node)
132 unless (equal (stp:namespace-uri a) *xsl*)
133 collect `(xsl:literal-attribute
134 (,(stp:local-name a)
135 ,(stp:namespace-uri a)
136 ,(stp:namespace-prefix a))
137 ,(stp:value a)))
138 ,@(parse-body node)))
139 (extensions '()))
140 (stp:with-attributes ((eep "extension-element-prefixes" *xsl*))
141 node
142 (dolist (prefix (words (or eep "")))
143 (when (equal prefix "#default")
144 (setf prefix nil))
145 (push (or (stp:find-namespace prefix node)
146 (xslt-error "namespace not found: ~A" prefix))
147 extensions)))
148 (if extensions
149 `(xsl:with-extension-namespaces ,extensions
150 (xsl:with-excluded-namespaces ,extensions
151 ,le))
152 le)))
154 (defun parse-fallback-children (node)
155 `(progn
156 ,@(loop
157 for fallback in (stp:filter-children (of-name "fallback") node)
158 append (parse-body fallback))))
160 (defmacro define-instruction-parser (name (node-var) &body body)
161 `(progn
162 (setf (gethash ,(symbol-name name) *available-instructions*) t)
163 (defmethod parse-instruction/xsl-element
164 ((.name. (eql ',name)) ,node-var)
165 (declare (ignore .name.))
166 ,@body)))
168 (define-instruction-parser |fallback| (node)
169 '(progn))
171 (define-instruction-parser |apply-templates| (node)
172 (stp:with-attributes (select mode) node
173 (multiple-value-bind (decls rest)
174 (loop
175 for i from 0
176 for cons on (stp:list-children node)
177 for (child . nil) = cons
178 while (namep child "sort")
179 collect (parse-sort child) into decls
180 finally (return (values decls cons)))
181 `(xsl:apply-templates
182 (:select ,select :mode ,mode)
183 (declare ,@decls)
184 ,@(mapcar (lambda (clause)
185 (unless (namep clause "with-param")
186 (xslt-error "undefined instruction: ~A"
187 (stp:local-name clause)))
188 (parse-param clause))
189 rest)))))
191 (define-instruction-parser |apply-imports| (node)
192 `(xsl:apply-imports))
194 (define-instruction-parser |call-template| (node)
195 (stp:with-attributes (name) node
196 `(xsl:call-template
197 ,name ,@(stp:map-children 'list
198 (lambda (clause)
199 (if (namep clause "with-param")
200 (parse-param clause)
201 (xslt-error "undefined instruction: ~A"
202 (stp:local-name clause))))
203 node))))
205 (define-instruction-parser |if| (node)
206 (stp:with-attributes (test) node
207 `(when ,test
208 ,@(parse-body node))))
210 (define-instruction-parser |choose| (node)
211 `(cond
212 ,@(stp:map-children 'list
213 (lambda (clause)
214 (cond
215 ((namep clause "when")
216 (stp:with-attributes (test) clause
217 `(,test
218 ,@(parse-body clause))))
219 ((namep clause "otherwise")
220 `(t ,@(parse-body clause)))
222 (xslt-error "invalid <choose> clause: ~A"
223 (stp:local-name clause)))))
224 node)))
226 (define-instruction-parser |element| (node)
227 (stp:with-attributes (name namespace use-attribute-sets) node
228 `(xsl:element (,name :namespace ,namespace)
229 (xsl:use-attribute-sets ,use-attribute-sets)
230 ,@(parse-body node))))
232 (define-instruction-parser |attribute| (node)
233 (stp:with-attributes (name namespace) node
234 `(xsl:attribute (,name :namespace ,namespace)
235 ,@(parse-body node))))
237 (define-instruction-parser |text| (node)
238 `(xsl:text ,(stp:string-value node)))
240 (define-instruction-parser |comment| (node)
241 `(xsl:comment ,@(parse-body node)))
243 (define-instruction-parser |processing-instruction| (node)
244 (stp:with-attributes (name) node
245 `(xsl:processing-instruction ,name
246 ,@(parse-body node))))
248 (define-instruction-parser |value-of| (node)
249 (stp:with-attributes (select disable-output-escaping) node
250 (if disable-output-escaping
251 `(xsl:unescaped-value-of ,select)
252 `(xsl:value-of ,select))))
254 (define-instruction-parser |copy-of| (node)
255 (stp:with-attributes (select) node
256 `(xsl:copy-of ,select)))
258 (define-instruction-parser |copy| (node)
259 (stp:with-attributes (use-attribute-sets) node
260 `(xsl:copy
261 (xsl:use-attribute-sets ,use-attribute-sets)
262 ,@(parse-body node))))
264 (define-instruction-parser |variable| (node)
265 (xslt-error "unhandled xsl:variable"))
267 (define-instruction-parser |for-each| (node)
268 (stp:with-attributes (select) node
269 (multiple-value-bind (decls body-position)
270 (loop
271 for i from 0
272 for child in (stp:list-children node)
273 while (namep child "sort")
274 collect (parse-sort child) into decls
275 finally (return (values decls i)))
276 `(xsl:for-each ,select
277 (declare ,@decls)
278 ,@(parse-body node body-position)))))
280 (defun parse-sort (node)
281 (stp:with-attributes (select lang data-type order case-order) node
282 `(sort :select ,select
283 :lang ,lang
284 :data-type ,data-type
285 :order ,order
286 :case-order ,case-order)))
288 (define-instruction-parser |message| (node)
289 `(xsl:message ,@(parse-body node)))
291 (define-instruction-parser |terminate| (node)
292 `(xsl:terminate ,@(parse-body node)))
294 (define-instruction-parser |number| (node)
295 (stp:with-attributes (level count from value format lang letter-value
296 grouping-separator grouping-size)
297 node
298 `(xsl:number :level ,level
299 :count ,count
300 :from ,from
301 :value ,value
302 :format ,format
303 :lang ,lang
304 :letter-value ,letter-value
305 :grouping-separator ,grouping-separator
306 :grouping-size ,grouping-size)))
308 (define-instruction-parser |document| (node)
309 (stp:with-attributes (href method indent doctype-public doctype-system) node
310 `(xsl:document (,href :method ,method
311 :indent ,indent
312 :doctype-public ,doctype-public
313 :doctype-system ,doctype-system)
314 ,@(parse-body node))))