Fixed variable import
[xuriella.git] / parser.lisp
blob327a94ccd6e0d6abf79cee637aa7df712c0f1c10
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 (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 (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 (only-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 (let ((sym (find-symbol (stp:local-name node) :xuriella)))
103 (cond
104 (sym
105 (parse-instruction/xsl-element sym node))
106 (*forwards-compatible-p*
107 (parse-fallback-children node))
109 (xslt-error "undefined instruction: ~A"
110 (stp:local-name node))))))
111 ((find (stp:namespace-uri node)
112 *extension-namespaces*
113 :test #'equal)
114 (parse-fallback-children node))
116 (parse-instruction/literal-element node))))
117 (parent (stp:parent node)))
118 (if (and (equal (stp:base-uri node) (stp:base-uri parent))
119 (equal (stp:namespace-uri parent) *xsl*)
120 (find-symbol (stp:local-name parent) :xuriella))
121 expr
122 `(xsl:with-base-uri ,(stp:base-uri node)
123 ,expr))))
124 (stp:text
125 `(xsl:text ,(stp:data node)))))
127 (defun parse-instruction/literal-element (node)
128 (let ((le
129 `(xsl:literal-element
130 (,(stp:local-name node)
131 ,(stp:namespace-uri node)
132 ,(stp:namespace-prefix node))
133 (xsl:use-attribute-sets
134 ,(stp:attribute-value node "use-attribute-sets" *xsl*))
135 ,@(loop
136 for a in (stp:list-attributes node)
137 for xslp = (equal (stp:namespace-uri a) *xsl*)
138 when xslp
139 do (unless (find (stp:local-name a)
140 '("version"
141 "extension-element-prefixes"
142 "exclude-result-prefixes"
143 "use-attribute-sets")
144 :test #'equal)
145 (xslt-error
146 "unknown attribute on literal result element: ~A"
147 (stp:local-name a)))
148 else
149 collect `(xsl:literal-attribute
150 (,(stp:local-name a)
151 ,(stp:namespace-uri a)
152 ,(stp:namespace-prefix a))
153 ,(stp:value a)))
154 ,@(parse-body node)))
155 (version (stp:attribute-value node "version" *xsl*))
156 (extensions '()))
157 (stp:with-attributes ((eep "extension-element-prefixes" *xsl*))
158 node
159 (dolist (prefix (words (or eep "")))
160 (when (equal prefix "#default")
161 (setf prefix nil))
162 (push (or (stp:find-namespace prefix node)
163 (xslt-error "namespace not found: ~A" prefix))
164 extensions)))
165 (when extensions
166 (setf le
167 `(xsl:with-extension-namespaces ,extensions
168 (xsl:with-excluded-namespaces ,extensions
169 ,le))))
170 (when version
171 (setf le
172 `(xsl:with-version ,version
173 ,le)))
174 le))
176 (defun parse-fallback-children (node)
177 (let ((fallbacks
178 (loop
179 for fallback in (stp:filter-children (of-name "fallback") node)
180 append (parse-body fallback))))
181 (if fallbacks
182 `(progn ,@fallbacks)
183 `(xsl:terminate
184 (xsl:text
185 "no fallback children in unknown element using forwards compatible processing")))))
187 (defmacro define-instruction-parser (name (node-var) &body body)
188 `(progn
189 (setf (gethash ,(symbol-name name) *available-instructions*) t)
190 (defmethod parse-instruction/xsl-element
191 ((.name. (eql ',name)) ,node-var)
192 (declare (ignore .name.))
193 ,@body)))
195 (define-instruction-parser |fallback| (node)
196 (only-with-attributes () node
197 '(progn)))
199 (define-instruction-parser |apply-templates| (node)
200 (only-with-attributes (select mode) node
201 (multiple-value-bind (decls rest)
202 (loop
203 for i from 0
204 for cons on (stp:filter-children
205 (lambda (node)
206 (or (typep node 'stp:element)
207 (xslt-error "non-element in apply-templates")))
208 node)
209 for (child . nil) = cons
210 while (namep child "sort")
211 collect (parse-sort child) into decls
212 finally (return (values decls cons)))
213 `(xsl:apply-templates
214 (:select ,select :mode ,mode)
215 (declare ,@decls)
216 ,@(mapcar (lambda (clause)
217 (unless (namep clause "with-param")
218 (xslt-error "undefined instruction: ~A"
219 (stp:local-name clause)))
220 (parse-param clause))
221 rest)))))
223 (define-instruction-parser |apply-imports| (node)
224 `(xsl:apply-imports))
226 (define-instruction-parser |call-template| (node)
227 (only-with-attributes (name) node
228 `(xsl:call-template
229 ,name ,@(stp:map-children 'list
230 (lambda (clause)
231 (if (namep clause "with-param")
232 (parse-param clause)
233 (xslt-error "undefined instruction: ~A"
234 (stp:local-name clause))))
235 node))))
237 (define-instruction-parser |if| (node)
238 (only-with-attributes (test) node
239 `(when ,test
240 ,@(parse-body node))))
242 (define-instruction-parser |choose| (node)
243 (only-with-attributes () node
244 `(cond
245 ,@(stp:map-children 'list
246 (lambda (clause)
247 (cond
248 ((namep clause "when")
249 (only-with-attributes (test) clause
250 `(,test
251 ,@(parse-body clause))))
252 ((namep clause "otherwise")
253 `(t ,@(parse-body clause)))
255 (xslt-error "invalid <choose> clause: ~A"
256 (stp:local-name clause)))))
257 node))))
259 (define-instruction-parser |element| (node)
260 (only-with-attributes (name namespace use-attribute-sets) node
261 `(xsl:element (,name :namespace ,namespace)
262 (xsl:use-attribute-sets ,use-attribute-sets)
263 ,@(parse-body node))))
265 (define-instruction-parser |attribute| (node)
266 (only-with-attributes (name namespace) node
267 `(xsl:attribute (,name :namespace ,namespace)
268 ,@(parse-body node))))
270 (define-instruction-parser |text| (node)
271 (only-with-attributes (select disable-output-escaping) node
272 (if (equal disable-output-escaping "yes")
273 `(xsl:unescaped-text ,(stp:string-value node))
274 `(xsl:text ,(stp:string-value node)))))
276 (define-instruction-parser |comment| (node)
277 (only-with-attributes () node
278 `(xsl:comment ,@(parse-body node))))
280 (define-instruction-parser |processing-instruction| (node)
281 (only-with-attributes (name) node
282 `(xsl:processing-instruction ,name
283 ,@(parse-body node))))
285 (define-instruction-parser |value-of| (node)
286 (only-with-attributes (select disable-output-escaping) node
287 (if (equal disable-output-escaping "yes")
288 `(xsl:unescaped-value-of ,select)
289 `(xsl:value-of ,select))))
291 (define-instruction-parser |copy-of| (node)
292 (only-with-attributes (select) node
293 `(xsl:copy-of ,select)))
295 (define-instruction-parser |copy| (node)
296 (only-with-attributes (use-attribute-sets) node
297 `(xsl:copy
298 (xsl:use-attribute-sets ,use-attribute-sets)
299 ,@(parse-body node))))
301 (define-instruction-parser |variable| (node)
302 (xslt-error "unhandled xsl:variable"))
304 (define-instruction-parser |for-each| (node)
305 (only-with-attributes (select) node
306 (multiple-value-bind (decls body-position)
307 (loop
308 for i from 0
309 for child in (stp:list-children node)
310 while (namep child "sort")
311 collect (parse-sort child) into decls
312 finally (return (values decls i)))
313 `(xsl:for-each ,select
314 (declare ,@decls)
315 ,@(parse-body node body-position)))))
317 (defun parse-sort (node)
318 (only-with-attributes (select lang data-type order case-order) node
319 `(sort :select ,select
320 :lang ,lang
321 :data-type ,data-type
322 :order ,order
323 :case-order ,case-order)))
325 (define-instruction-parser |message| (node)
326 (only-with-attributes (terminate) node
327 (if (equal terminate "yes")
328 `(xsl:terminate ,@(parse-body node))
329 `(xsl:message ,@(parse-body node)))))
331 (define-instruction-parser |number| (node)
332 (only-with-attributes (level count from value format lang letter-value
333 grouping-separator grouping-size)
334 node
335 `(xsl:number :level ,level
336 :count ,count
337 :from ,from
338 :value ,value
339 :format ,format
340 :lang ,lang
341 :letter-value ,letter-value
342 :grouping-separator ,grouping-separator
343 :grouping-size ,grouping-size)))
345 (define-instruction-parser |document| (node)
346 (only-with-attributes
347 (href method indent doctype-public doctype-system) node
348 `(xsl:document (,href :method ,method
349 :indent ,indent
350 :doctype-public ,doctype-public
351 :doctype-system ,doctype-system)
352 ,@(parse-body node))))