Observe doctype in xuriella:document
[xuriella.git] / parser.lisp
blob0ea4bcd8134f1a1bcb0b04d2771ea2f91e984b4f
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 &optional include-redeclared)
33 (let ((parent (stp:parent element)))
34 (maphash (lambda (prefix uri)
35 (unless (and (not include-redeclared)
36 (typep parent 'stp:element)
37 (equal (stp:find-namespace prefix parent) uri))
38 (funcall fn prefix uri)))
39 (cxml-stp-impl::collect-local-namespaces element))))
41 (defun maybe-wrap-namespaces (child exprs)
42 (if (typep child 'stp:element)
43 (let ((bindings '())
44 (excluded-uris '()))
45 (map-namespace-declarations (lambda (prefix uri)
46 (push (list prefix uri) bindings))
47 child)
48 (stp:with-attributes ((erp "exclude-result-prefixes" *xsl*))
49 child
50 (dolist (prefix (words (or erp "")))
51 (when (equal prefix "#default")
52 (setf prefix nil))
53 (push (or (stp:find-namespace prefix child)
54 (xslt-error "namespace not found: ~A" prefix))
55 excluded-uris)))
56 (if (or bindings excluded-uris)
57 `((xsl:with-namespaces ,bindings
58 (xsl:with-excluded-namespaces ,excluded-uris
59 ,@exprs)))
60 exprs))
61 exprs))
63 (defun parse-body (node &optional (start 0) (param-names '()))
64 (let ((n (stp:count-children-if #'identity node)))
65 (labels ((recurse (i)
66 (when (< i n)
67 (let ((child (stp:nth-child i node)))
68 (if (namep child "variable")
69 (maybe-wrap-namespaces
70 child
71 (only-with-attributes (name select) child
72 (when (and select (stp:list-children child))
73 (xslt-error "variable with select and body"))
74 `((let ((,name ,(or select
75 `(progn ,@(parse-body child)))))
76 (xsl:with-duplicates-check (,name)
77 ,@(recurse (1+ i)))))))
78 (append (maybe-wrap-namespaces
79 child
80 (list (parse-instruction child)))
81 (recurse (1+ i))))))))
82 (let ((result (recurse start)))
83 (if param-names
84 `((xsl:with-duplicates-check (,@param-names)
85 ,@result))
86 result)))))
88 (defun parse-param (node)
89 ;; FIXME: empty body?
90 (only-with-attributes (name select) node
91 (unless name
92 (xslt-error "name not specified for parameter"))
93 (when (and select (stp:list-children node))
94 (xslt-error "param with select and body"))
95 (list name
96 (or select
97 `(progn ,@(parse-body node))))))
99 (defun parse-instruction (node)
100 (typecase node
101 (stp:element
102 (let ((expr
103 (cond
104 ((equal (stp:namespace-uri node) *xsl*)
105 (let ((sym (find-symbol (stp:local-name node) :xuriella)))
106 (cond
107 (sym
108 (parse-instruction/xsl-element sym node))
109 (*forwards-compatible-p*
110 (parse-fallback-children node))
112 (xslt-error "undefined instruction: ~A"
113 (stp:local-name node))))))
114 ((find (stp:namespace-uri node)
115 *extension-namespaces*
116 :test #'equal)
117 (let ((extension (find-extension-element
118 (stp:local-name node)
119 (stp:namespace-uri node))))
120 (if extension
121 (funcall (extension-element-parser extension) node)
122 (parse-fallback-children node))))
124 (parse-instruction/literal-element node))))
125 (parent (stp:parent node)))
126 (if (and (equal (stp:base-uri node) (stp:base-uri parent))
127 (equal (stp:namespace-uri parent) *xsl*)
128 (find-symbol (stp:local-name parent) :xuriella))
129 expr
130 `(xsl:with-base-uri ,(stp:base-uri node)
131 ,expr))))
132 (stp:text
133 `(xsl:text ,(stp:data node)))))
135 (defun parse-instruction/literal-element (node)
136 (let ((extensions '()))
137 (stp:with-attributes ((eep "extension-element-prefixes" *xsl*))
138 node
139 (dolist (prefix (words (or eep "")))
140 (when (equal prefix "#default")
141 (setf prefix nil))
142 (push (or (stp:find-namespace prefix node)
143 (xslt-error "namespace not found: ~A" prefix))
144 extensions)))
145 (if (find (stp:namespace-uri node) extensions :test #'equal)
146 ;; oops, this isn't a literal result element after all
147 (parse-fallback-children node)
148 (let ((le
149 `(xsl:literal-element
150 (,(stp:local-name node)
151 ,(stp:namespace-uri node)
152 ,(stp:namespace-prefix node))
153 (xsl:use-attribute-sets
154 ,(stp:attribute-value node "use-attribute-sets" *xsl*))
155 ,@(loop
156 for a in (stp:list-attributes node)
157 for xslp = (equal (stp:namespace-uri a) *xsl*)
158 when xslp
159 do (unless (find (stp:local-name a)
160 '("version"
161 "extension-element-prefixes"
162 "exclude-result-prefixes"
163 "use-attribute-sets")
164 :test #'equal)
165 (xslt-error
166 "unknown attribute on literal result element: ~A"
167 (stp:local-name a)))
168 else
169 collect `(xsl:literal-attribute
170 (,(stp:local-name a)
171 ,(stp:namespace-uri a)
172 ,(stp:namespace-prefix a))
173 ,(stp:value a)))
174 ,@ (let ((*extension-namespaces*
175 (append extensions *extension-namespaces*)))
176 (parse-body node))))
177 (version (stp:attribute-value node "version" *xsl*)))
178 (when extensions
179 (setf le
180 `(xsl:with-extension-namespaces ,extensions
181 (xsl:with-excluded-namespaces ,extensions
182 ,le))))
183 (when version
184 (setf le
185 `(xsl:with-version ,version
186 ,le)))
187 le))))
189 (defun parse-fallback-children (node)
190 (let ((fallbacks
191 (loop
192 for fallback in (stp:filter-children (of-name "fallback") node)
193 do (only-with-attributes () fallback)
194 append (parse-body fallback))))
195 (if fallbacks
196 `(progn ,@fallbacks)
197 `(xsl:terminate
198 (xsl:text
199 "no fallback children in unknown element using forwards compatible processing")))))
201 (defmacro define-instruction-parser (name (node-var) &body body)
202 `(progn
203 (setf (gethash ,(symbol-name name) *builtin-instructions*) t)
204 (defmethod parse-instruction/xsl-element
205 ((.name. (eql ',name)) ,node-var)
206 (declare (ignore .name.))
207 ,@body)))
209 (define-instruction-parser |fallback| (node)
210 (only-with-attributes () node
211 '(progn)))
213 (define-instruction-parser |apply-templates| (node)
214 (only-with-attributes (select mode) node
215 (multiple-value-bind (decls rest)
216 (loop
217 for i from 0
218 for cons on (stp:filter-children
219 (lambda (node)
220 (or (typep node 'stp:element)
221 (xslt-error "non-element in apply-templates")))
222 node)
223 for (child . nil) = cons
224 while (namep child "sort")
225 collect (parse-sort child) into decls
226 finally (return (values decls cons)))
227 `(xsl:apply-templates
228 (:select ,select :mode ,mode)
229 (declare ,@decls)
230 ,@(mapcar (lambda (clause)
231 (unless (namep clause "with-param")
232 (xslt-error "undefined instruction: ~A"
233 (stp:local-name clause)))
234 (parse-param clause))
235 rest)))))
237 (define-instruction-parser |apply-imports| (node)
238 (only-with-attributes () node)
239 (assert-no-body node)
240 `(xsl:apply-imports))
242 (define-instruction-parser |call-template| (node)
243 (only-with-attributes (name) node
244 `(xsl:call-template
245 ,name ,@(stp:map-children 'list
246 (lambda (clause)
247 (if (namep clause "with-param")
248 (parse-param clause)
249 (xslt-error "undefined instruction: ~A"
250 (stp:local-name clause))))
251 node))))
253 (define-instruction-parser |if| (node)
254 (only-with-attributes (test) node
255 `(when ,test
256 ,@(parse-body node))))
258 (define-instruction-parser |choose| (node)
259 (let ((whenp nil))
260 (prog1
261 (only-with-attributes () node
262 `(cond
263 ,@(stp:map-children 'list
264 (lambda (clause)
265 (cond
266 ((namep clause "when")
267 (setf whenp t)
268 (only-with-attributes (test) clause
269 `(,test
270 ,@(parse-body clause))))
271 ((namep clause "otherwise")
272 `(t ,@(parse-body clause)))
274 (xslt-error "invalid <choose> clause: ~A"
275 (stp:local-name clause)))))
276 node)))
277 (unless whenp
278 (xslt-error "<choose> without <when>")))))
280 (define-instruction-parser |element| (node)
281 (only-with-attributes (name namespace use-attribute-sets) node
282 `(xsl:element (,name :namespace ,namespace)
283 (xsl:use-attribute-sets ,use-attribute-sets)
284 ,@(parse-body node))))
286 (define-instruction-parser |attribute| (node)
287 (only-with-attributes (name namespace) node
288 `(xsl:attribute (,name :namespace ,namespace)
289 ,@(parse-body node))))
291 (defun boolean-or-error (str)
292 (cond
293 ((equal str "yes")
295 ((or (null str) (equal str "no"))
296 nil)
298 (xslt-error "not a boolean: ~A" str))))
300 (define-instruction-parser |text| (node)
301 (only-with-attributes (select disable-output-escaping) node
302 (when (xpath:evaluate "boolean(*)" node)
303 (xslt-error "non-text found in xsl:text"))
304 (if (boolean-or-error disable-output-escaping)
305 `(xsl:unescaped-text ,(stp:string-value node))
306 `(xsl:text ,(stp:string-value node)))))
308 (define-instruction-parser |comment| (node)
309 (only-with-attributes () node
310 `(xsl:comment ,@(parse-body node))))
312 (define-instruction-parser |processing-instruction| (node)
313 (only-with-attributes (name) node
314 `(xsl:processing-instruction ,name
315 ,@(parse-body node))))
317 (defun assert-no-body (node)
318 (when (stp:list-children node)
319 (xslt-error "no child nodes expected in ~A" (stp:local-name node))))
321 (define-instruction-parser |value-of| (node)
322 (only-with-attributes (select disable-output-escaping) node
323 (assert-no-body node)
324 (if (boolean-or-error disable-output-escaping)
325 `(xsl:unescaped-value-of ,select)
326 `(xsl:value-of ,select))))
328 (define-instruction-parser |copy-of| (node)
329 (only-with-attributes (select) node
330 (assert-no-body node)
331 `(xsl:copy-of ,select)))
333 (define-instruction-parser |copy| (node)
334 (only-with-attributes (use-attribute-sets) node
335 `(xsl:copy
336 (xsl:use-attribute-sets ,use-attribute-sets)
337 ,@(parse-body node))))
339 (define-instruction-parser |variable| (node)
340 (xslt-error "unhandled xsl:variable"))
342 (define-instruction-parser |for-each| (node)
343 (only-with-attributes (select) node
344 (multiple-value-bind (decls body-position)
345 (loop
346 for i from 0
347 for child in (stp:list-children node)
348 while (namep child "sort")
349 collect (parse-sort child) into decls
350 finally (return (values decls i)))
351 `(xsl:for-each ,select
352 (declare ,@decls)
353 ,@(parse-body node body-position)))))
355 (defun parse-sort (node)
356 (only-with-attributes (select lang data-type order case-order) node
357 (assert-no-body node)
358 `(sort :select ,select
359 :lang ,lang
360 :data-type ,data-type
361 :order ,order
362 :case-order ,case-order)))
364 (define-instruction-parser |message| (node)
365 (only-with-attributes (terminate) node
366 (if (boolean-or-error terminate)
367 `(xsl:terminate ,@(parse-body node))
368 `(xsl:message ,@(parse-body node)))))
370 (define-instruction-parser |number| (node)
371 (only-with-attributes (level count from value format lang letter-value
372 grouping-separator grouping-size)
373 node
374 (assert-no-body node)
375 `(xsl:number :level ,level
376 :count ,count
377 :from ,from
378 :value ,value
379 :format ,format
380 :lang ,lang
381 :letter-value ,letter-value
382 :grouping-separator ,grouping-separator
383 :grouping-size ,grouping-size)))