Check included attribute sets at compile time like saxon
[xuriella.git] / parser.lisp
blob23e09956a0a52174c543eb1d5d4671e87c155b98
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 (if (namep child "variable")
68 (maybe-wrap-namespaces
69 child
70 (only-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 (append (maybe-wrap-namespaces
78 child
79 (list (parse-instruction child)))
80 (recurse (1+ i))))))))
81 (let ((result (recurse start)))
82 (if param-names
83 `((xsl:with-duplicates-check (,@param-names)
84 ,@result))
85 result)))))
87 (defun parse-param (node)
88 ;; FIXME: empty body?
89 (only-with-attributes (name select) node
90 (unless name
91 (xslt-error "name not specified for parameter"))
92 (when (and select (stp:list-children node))
93 (xslt-error "param with select and body"))
94 (list name
95 (or select
96 `(progn ,@(parse-body node))))))
98 (defun parse-instruction (node)
99 (typecase node
100 (stp:element
101 (let ((expr
102 (cond
103 ((equal (stp:namespace-uri node) *xsl*)
104 (let ((sym (find-symbol (stp:local-name node) :xuriella)))
105 (cond
106 (sym
107 (parse-instruction/xsl-element sym node))
108 (*forwards-compatible-p*
109 (parse-fallback-children node))
111 (xslt-error "undefined instruction: ~A"
112 (stp:local-name node))))))
113 ((find (stp:namespace-uri node)
114 *extension-namespaces*
115 :test #'equal)
116 (parse-fallback-children node))
118 (parse-instruction/literal-element node))))
119 (parent (stp:parent node)))
120 (if (and (equal (stp:base-uri node) (stp:base-uri parent))
121 (equal (stp:namespace-uri parent) *xsl*)
122 (find-symbol (stp:local-name parent) :xuriella))
123 expr
124 `(xsl:with-base-uri ,(stp:base-uri node)
125 ,expr))))
126 (stp:text
127 `(xsl:text ,(stp:data node)))))
129 (defun parse-instruction/literal-element (node)
130 (let ((le
131 `(xsl:literal-element
132 (,(stp:local-name node)
133 ,(stp:namespace-uri node)
134 ,(stp:namespace-prefix node))
135 (xsl:use-attribute-sets
136 ,(stp:attribute-value node "use-attribute-sets" *xsl*))
137 ,@(loop
138 for a in (stp:list-attributes node)
139 for xslp = (equal (stp:namespace-uri a) *xsl*)
140 when xslp
141 do (unless (find (stp:local-name a)
142 '("version"
143 "extension-element-prefixes"
144 "exclude-result-prefixes"
145 "use-attribute-sets")
146 :test #'equal)
147 (xslt-error
148 "unknown attribute on literal result element: ~A"
149 (stp:local-name a)))
150 else
151 collect `(xsl:literal-attribute
152 (,(stp:local-name a)
153 ,(stp:namespace-uri a)
154 ,(stp:namespace-prefix a))
155 ,(stp:value a)))
156 ,@(parse-body node)))
157 (version (stp:attribute-value node "version" *xsl*))
158 (extensions '()))
159 (stp:with-attributes ((eep "extension-element-prefixes" *xsl*))
160 node
161 (dolist (prefix (words (or eep "")))
162 (when (equal prefix "#default")
163 (setf prefix nil))
164 (push (or (stp:find-namespace prefix node)
165 (xslt-error "namespace not found: ~A" prefix))
166 extensions)))
167 (when extensions
168 (setf le
169 `(xsl:with-extension-namespaces ,extensions
170 (xsl:with-excluded-namespaces ,extensions
171 ,le))))
172 (when version
173 (setf le
174 `(xsl:with-version ,version
175 ,le)))
176 le))
178 (defun parse-fallback-children (node)
179 (let ((fallbacks
180 (loop
181 for fallback in (stp:filter-children (of-name "fallback") node)
182 append (parse-body fallback))))
183 (if fallbacks
184 `(progn ,@fallbacks)
185 `(xsl:terminate
186 (xsl:text
187 "no fallback children in unknown element using forwards compatible processing")))))
189 (defmacro define-instruction-parser (name (node-var) &body body)
190 `(progn
191 (setf (gethash ,(symbol-name name) *available-instructions*) t)
192 (defmethod parse-instruction/xsl-element
193 ((.name. (eql ',name)) ,node-var)
194 (declare (ignore .name.))
195 ,@body)))
197 (define-instruction-parser |fallback| (node)
198 (only-with-attributes () node
199 '(progn)))
201 (define-instruction-parser |apply-templates| (node)
202 (only-with-attributes (select mode) node
203 (multiple-value-bind (decls rest)
204 (loop
205 for i from 0
206 for cons on (stp:filter-children
207 (lambda (node)
208 (or (typep node 'stp:element)
209 (xslt-error "non-element in apply-templates")))
210 node)
211 for (child . nil) = cons
212 while (namep child "sort")
213 collect (parse-sort child) into decls
214 finally (return (values decls cons)))
215 `(xsl:apply-templates
216 (:select ,select :mode ,mode)
217 (declare ,@decls)
218 ,@(mapcar (lambda (clause)
219 (unless (namep clause "with-param")
220 (xslt-error "undefined instruction: ~A"
221 (stp:local-name clause)))
222 (parse-param clause))
223 rest)))))
225 (define-instruction-parser |apply-imports| (node)
226 (only-with-attributes () node)
227 (assert-no-body node)
228 `(xsl:apply-imports))
230 (define-instruction-parser |call-template| (node)
231 (only-with-attributes (name) node
232 `(xsl:call-template
233 ,name ,@(stp:map-children 'list
234 (lambda (clause)
235 (if (namep clause "with-param")
236 (parse-param clause)
237 (xslt-error "undefined instruction: ~A"
238 (stp:local-name clause))))
239 node))))
241 (define-instruction-parser |if| (node)
242 (only-with-attributes (test) node
243 `(when ,test
244 ,@(parse-body node))))
246 (define-instruction-parser |choose| (node)
247 (only-with-attributes () node
248 `(cond
249 ,@(stp:map-children 'list
250 (lambda (clause)
251 (cond
252 ((namep clause "when")
253 (only-with-attributes (test) clause
254 `(,test
255 ,@(parse-body clause))))
256 ((namep clause "otherwise")
257 `(t ,@(parse-body clause)))
259 (xslt-error "invalid <choose> clause: ~A"
260 (stp:local-name clause)))))
261 node))))
263 (define-instruction-parser |element| (node)
264 (only-with-attributes (name namespace use-attribute-sets) node
265 `(xsl:element (,name :namespace ,namespace)
266 (xsl:use-attribute-sets ,use-attribute-sets)
267 ,@(parse-body node))))
269 (define-instruction-parser |attribute| (node)
270 (only-with-attributes (name namespace) node
271 `(xsl:attribute (,name :namespace ,namespace)
272 ,@(parse-body node))))
274 (define-instruction-parser |text| (node)
275 (only-with-attributes (select disable-output-escaping) node
276 (if (equal disable-output-escaping "yes")
277 `(xsl:unescaped-text ,(stp:string-value node))
278 `(xsl:text ,(stp:string-value node)))))
280 (define-instruction-parser |comment| (node)
281 (only-with-attributes () node
282 `(xsl:comment ,@(parse-body node))))
284 (define-instruction-parser |processing-instruction| (node)
285 (only-with-attributes (name) node
286 `(xsl:processing-instruction ,name
287 ,@(parse-body node))))
289 (defun assert-no-body (node)
290 (when (stp:list-children node)
291 (xslt-error "no child nodes expected in ~A" (stp:local-name node))))
293 (define-instruction-parser |value-of| (node)
294 (only-with-attributes (select disable-output-escaping) node
295 (assert-no-body node)
296 (if (equal disable-output-escaping "yes")
297 `(xsl:unescaped-value-of ,select)
298 `(xsl:value-of ,select))))
300 (define-instruction-parser |copy-of| (node)
301 (only-with-attributes (select) node
302 (assert-no-body node)
303 `(xsl:copy-of ,select)))
305 (define-instruction-parser |copy| (node)
306 (only-with-attributes (use-attribute-sets) node
307 `(xsl:copy
308 (xsl:use-attribute-sets ,use-attribute-sets)
309 ,@(parse-body node))))
311 (define-instruction-parser |variable| (node)
312 (xslt-error "unhandled xsl:variable"))
314 (define-instruction-parser |for-each| (node)
315 (only-with-attributes (select) node
316 (multiple-value-bind (decls body-position)
317 (loop
318 for i from 0
319 for child in (stp:list-children node)
320 while (namep child "sort")
321 collect (parse-sort child) into decls
322 finally (return (values decls i)))
323 `(xsl:for-each ,select
324 (declare ,@decls)
325 ,@(parse-body node body-position)))))
327 (defun parse-sort (node)
328 (only-with-attributes (select lang data-type order case-order) node
329 (assert-no-body node)
330 `(sort :select ,select
331 :lang ,lang
332 :data-type ,data-type
333 :order ,order
334 :case-order ,case-order)))
336 (define-instruction-parser |message| (node)
337 (only-with-attributes (terminate) node
338 (if (equal terminate "yes")
339 `(xsl:terminate ,@(parse-body node))
340 `(xsl:message ,@(parse-body node)))))
342 (define-instruction-parser |number| (node)
343 (only-with-attributes (level count from value format lang letter-value
344 grouping-separator grouping-size)
345 node
346 (assert-no-body node)
347 `(xsl:number :level ,level
348 :count ,count
349 :from ,from
350 :value ,value
351 :format ,format
352 :lang ,lang
353 :letter-value ,letter-value
354 :grouping-separator ,grouping-separator
355 :grouping-size ,grouping-size)))
357 (define-instruction-parser |document| (node)
358 (only-with-attributes
359 (href method indent doctype-public doctype-system) node
360 `(xsl:document (,href :method ,method
361 :indent ,indent
362 :doctype-public ,doctype-public
363 :doctype-system ,doctype-system)
364 ,@(parse-body node))))