1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
12 ;;; * Redistributions in binary form must reproduce the above
13 ;;; copyright notice, this list of conditions and the following
14 ;;; disclaimer in the documentation and/or other materials
15 ;;; provided with the distribution.
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 (in-package :xuriella
)
31 (declaim (optimize (debug 3) (safety 3) (space 0) (speed 0)))
34 (defmacro define-instruction
(name (args-var env-var
) &body body
)
35 `(setf (get ',name
'xslt-instruction
)
36 (lambda (,args-var
,env-var
)
37 (declare (ignorable ,env-var
))
40 (define-instruction if
(args env
)
41 (destructuring-bind (test then
&optional else
) args
42 (let ((test-thunk (compile-xpath test env
))
43 (then-thunk (compile-instruction then env
))
44 (else-thunk (when else
(compile-instruction else env
))))
48 ((xpath:boolean-value
(funcall test-thunk ctx
))
49 (funcall then-thunk ctx
))
51 (funcall else-thunk ctx
))))))))
53 (define-instruction when
(args env
)
54 (destructuring-bind (test &rest body
) args
55 (compile-instruction `(if ,test
(progn ,@body
)) env
)))
57 (define-instruction unless
(args env
)
58 (destructuring-bind (test &rest body
) args
59 (compile-instruction `(if (:not
,test
) (progn ,@body
)) env
)))
61 (define-instruction cond
(args env
)
63 (destructuring-bind ((test &body body
) &rest clauses
) args
64 (compile-instruction (if (eq test t
)
65 `(scoped-progn ,@body
)
72 (define-instruction progn
(args env
)
74 (let ((first-thunk (compile-instruction (first args
) env
))
75 (rest-thunk (compile-instruction `(progn ,@(rest args
)) env
)))
77 (funcall first-thunk ctx
)
78 (funcall rest-thunk ctx
)))
81 (defun decode-qname/runtime
(qname namespaces attributep
)
83 (multiple-value-bind (prefix local-name
)
86 (if (or prefix
(not attributep
))
87 (cdr (assoc prefix namespaces
:test
'equal
))
90 (cxml:well-formedness-violation
()
91 (xslt-error "not a qname: ~A" qname
))))
93 (define-instruction scoped-progn
(args env
)
95 (let ((first-thunk (compile-instruction (first args
) env
))
96 (rest-thunk (compile-instruction `(progn ,@(rest args
)) env
)))
99 (funcall first-thunk ctx
)
100 (funcall rest-thunk ctx
))))
103 (define-instruction xsl
:element
(args env
)
104 (destructuring-bind ((name &key namespace use-attribute-sets
)
107 (declare (ignore use-attribute-sets
)) ;fixme
108 (multiple-value-bind (name-thunk constant-name-p
)
109 (compile-attribute-value-template name env
)
110 (let ((body-thunk (compile-instruction `(scoped-progn ,@body
) env
)))
112 (compile-element/constant-name name namespace env body-thunk
)
113 (compile-element/runtime name-thunk namespace body-thunk
))))))
115 (defun compile-element/constant-name
(qname namespace env body-thunk
)
116 ;; the simple case: compile-time decoding of the QName
117 (multiple-value-bind (local-name uri prefix
)
118 (decode-qname qname env nil
)
120 (setf uri namespace
))
122 (with-element (local-name uri
:suggested-prefix prefix
)
123 (funcall body-thunk ctx
)))))
125 (defun compile-element/runtime
(name-thunk namespace body-thunk
)
126 ;; run-time decoding of the QName, but using the same namespaces
127 ;; that would have been known at compilation time.
128 (let ((namespaces *namespaces
*))
130 (let ((qname (funcall name-thunk ctx
)))
131 (multiple-value-bind (local-name uri prefix
)
132 (decode-qname/runtime qname namespaces nil
)
134 (setf uri namespace
))
136 (with-element (local-name uri
:suggested-prefix prefix
)
137 (funcall body-thunk ctx
))))))))
139 (define-instruction xsl
:attribute
(args env
)
140 (destructuring-bind ((name &key namespace
) &body body
) args
141 (multiple-value-bind (name-thunk constant-name-p
)
142 (compile-attribute-value-template name env
)
143 (let ((value-thunk (compile-instruction `(scoped-progn ,@body
) env
)))
145 (compile-attribute/constant-name name namespace env value-thunk
)
146 (compile-attribute/runtime name-thunk namespace value-thunk
))))))
148 (defun compile-attribute/constant-name
(qname namespace env value-thunk
)
149 ;; the simple case: compile-time decoding of the QName
150 (multiple-value-bind (local-name uri prefix
)
151 (decode-qname qname env nil
)
153 (setf uri namespace
))
155 (write-attribute local-name
157 (with-text-output-sink (s)
159 (funcall value-thunk ctx
)))
160 :suggested-prefix prefix
))))
162 (defun compile-attribute/runtime
(name-thunk namespace value-thunk
)
163 ;; run-time decoding of the QName, but using the same namespaces
164 ;; that would have been known at compilation time.
165 (let ((namespaces *namespaces
*))
167 (let ((qname (funcall name-thunk ctx
)))
168 (multiple-value-bind (local-name uri prefix
)
169 (decode-qname/runtime qname namespaces nil
)
171 (setf uri namespace
))
173 (write-attribute local-name
175 (with-text-output-sink (s)
177 (funcall value-thunk ctx
)))
178 :suggested-prefix prefix
)))))))
180 (defun remove-excluded-namespaces
181 (namespaces &optional
(excluded-uris *excluded-namespaces
*))
182 (let ((koerbchen '())
185 for cons in namespaces
186 for
(prefix . uri
) = cons
189 ((find prefix kroepfchen
:test
#'equal
))
190 ((find uri excluded-uris
:test
#'equal
)
191 (push prefix kroepfchen
))
193 (push cons koerbchen
))))
196 (define-instruction xsl
:literal-element
(args env
)
198 ((local-name &optional
(uri "") suggested-prefix
) &body body
)
200 (let ((body-thunk (compile-instruction `(scoped-progn ,@body
) env
))
201 (namespaces (remove-excluded-namespaces *namespaces
*)))
203 (with-element (local-name uri
204 :suggested-prefix suggested-prefix
205 :extra-namespaces namespaces
)
206 (funcall body-thunk ctx
))))))
208 (define-instruction xsl
:literal-attribute
(args env
)
209 (destructuring-bind ((local-name &optional uri suggested-prefix
) value
) args
210 (let ((value-thunk (compile-attribute-value-template value env
)))
212 (declare (ignore ctx
))
213 (write-attribute local-name
215 (funcall value-thunk ctx
)
216 :suggested-prefix suggested-prefix
)))))
218 (define-instruction xsl
:text
(args env
)
219 (destructuring-bind (str) args
221 (declare (ignore ctx
))
224 (define-instruction xsl
:processing-instruction
(args env
)
225 (destructuring-bind (name &rest body
) args
226 (let ((name-thunk (compile-attribute-value-template name env
))
227 (value-thunk (compile-instruction `(scoped-progn ,@body
) env
)))
229 (write-processing-instruction
230 (funcall name-thunk ctx
)
231 (with-text-output-sink (s)
233 (funcall value-thunk ctx
))))))))
235 (define-instruction xsl
:comment
(args env
)
236 (destructuring-bind (str) args
238 (declare (ignore ctx
))
239 (write-comment str
))))
241 (define-instruction xsl
:value-of
(args env
)
242 (destructuring-bind (xpath) args
243 (let ((thunk (compile-xpath xpath env
)))
245 (write-text (xpath:string-value
(funcall thunk ctx
)))))))
247 (define-instruction xsl
:unescaped-value-of
(args env
)
248 (destructuring-bind (xpath) args
249 (let ((thunk (compile-xpath xpath env
)))
251 (write-unescaped (xpath:string-value
(funcall thunk ctx
)))))))
253 (define-instruction xsl
:copy-of
(args env
)
254 (destructuring-bind (xpath) args
255 (let ((thunk (compile-xpath xpath env
))
256 ;; FIXME: what was this for? --david
257 #+(or) (v (intern-variable "varName" "")))
259 (let ((result (funcall thunk ctx
)))
261 (xpath:node-set
;; FIXME: variables can contain node sets w/fragments inside. Maybe just fragments would do?
262 (xpath:map-node-set
#'copy-into-result result
))
263 (result-tree-fragment
264 (copy-into-result result
))
266 (write-text (xpath:string-value result
)))))))))
268 (defun copy-into-result (node)
270 ((result-tree-fragment-p node
)
271 (stp:do-children
(child (result-tree-fragment-node node
))
272 (copy-into-result child
)))
273 ((xpath-protocol:node-type-p node
:element
)
274 (with-element ((xpath-protocol:local-name node
)
275 (xpath-protocol:namespace-uri node
)
276 :suggested-prefix
(xpath-protocol:namespace-prefix node
)
277 ;; FIXME: is remove-excluded-namespaces correct here?
278 :extra-namespaces
(remove-excluded-namespaces
279 (namespaces-as-alist node
)))
280 (map-pipe-eagerly #'copy-into-result
281 (xpath-protocol:attribute-pipe node
))
282 (map-pipe-eagerly #'copy-into-result
283 (xpath-protocol:child-pipe node
))))
284 ((xpath-protocol:node-type-p node
:document
)
285 (map-pipe-eagerly #'copy-into-result
286 (xpath-protocol:child-pipe node
)))
288 (copy-leaf-node node
))))
290 (define-instruction xsl
:for-each
(args env
)
291 (destructuring-bind (select &optional decls
&rest body
) args
292 (when (and (consp decls
)
293 (not (eq (car decls
) 'declare
)))
296 (let ((select-thunk (compile-xpath select env
))
297 (body-thunk (compile-instruction `(scoped-progn ,@body
) env
))
299 ;; fixme: parse decls here
302 (let* ((nodes (xpath:all-nodes
(funcall sorter
(funcall select-thunk ctx
))))
309 (xpath:make-context node
(lambda () n
) i
))))))))
311 (define-instruction xsl
:with-namespaces
(args env
)
312 (destructuring-bind ((&rest forms
) &rest body
) args
313 (let ((*namespaces
* *namespaces
*))
315 (destructuring-bind (prefix uri
) form
316 (push (cons prefix uri
) *namespaces
*)))
317 (compile-instruction `(progn ,@body
) env
))))
319 (define-instruction xsl
:with-excluded-namespaces
(args env
)
320 (destructuring-bind ((&rest uris
) &rest body
) args
321 (let ((*excluded-namespaces
* (append uris
*excluded-namespaces
*)))
322 (compile-instruction `(progn ,@body
) env
))))
324 (defstruct (result-tree-fragment
325 (:constructor make-result-tree-fragment
(node)))
328 (defmethod xpath-protocol:node-p
((node result-tree-fragment
))
331 (defmethod xpath-protocol:string-value
((node result-tree-fragment
))
332 (xpath-protocol:string-value
(result-tree-fragment-node node
)))
334 (defun apply-to-result-tree-fragment (ctx thunk
)
336 (with-xml-output (stp:make-builder
)
337 (with-element ("fragment" "")
338 (funcall thunk ctx
)))))
339 (make-result-tree-fragment (stp:document-element document
))))
341 (define-instruction let
(args env
)
342 (destructuring-bind ((&rest forms
) &rest body
) args
343 (let* ((var-bindings (compile-var-bindings forms env
))
344 (thunk (compile-instruction `(progn ,@body
) env
)))
346 ;; FIXME: should (again) detect duplicate definitions at compile time
347 (loop for
(gensym var-thunk
) in var-bindings
348 do
(if (has-inner-binding-p gensym
)
349 (xslt-error "duplicate definition of ~A" gensym
) ;; FIXME (find name by gensym)
350 (setf (get-frame-value gensym
)
351 (funcall var-thunk ctx
))))
352 (funcall thunk ctx
)))))
354 (define-instruction let
* (args env
)
355 (destructuring-bind ((&rest forms
) &rest body
) args
357 (compile-instruction `(let (,(car forms
))
358 (let* (,@(cdr forms
))
361 (compile-instruction `(progn ,@body
) env
))))
363 (define-instruction xsl
:message
(args env
)
364 (compile-message #'warn args env
))
366 (define-instruction xsl
:terminate
(args env
)
367 (compile-message #'error args env
))
369 (defun namespaces-as-alist (element)
370 (let ((namespaces '()))
371 (do-pipe (ns (xpath-protocol:namespace-pipe element
))
372 (push (cons (xpath-protocol:local-name ns
)
373 (xpath-protocol:namespace-uri ns
))
377 (define-instruction xsl
:copy
(args env
)
378 (destructuring-bind ((&key use-attribute-sets
) &rest rest
)
380 (let ((body (compile-instruction `(scoped-progn ,@rest
) env
)))
382 (let ((node (xpath:context-node ctx
)))
384 ((xpath-protocol:node-type-p node
:element
)
386 ((xpath-protocol:local-name node
)
387 (xpath-protocol:namespace-uri node
)
388 :suggested-prefix
(xpath-protocol:namespace-prefix node
)
389 :extra-namespaces
(namespaces-as-alist node
))
391 ((xpath-protocol:node-type-p node
:document
)
394 (copy-leaf-node node
))))))))
396 (defun copy-leaf-node (node)
398 ((xpath-protocol:node-type-p node
:text
)
399 (write-text (xpath-protocol:string-value node
)))
400 ((xpath-protocol:node-type-p node
:comment
)
401 (write-comment (xpath-protocol:string-value node
)))
402 ((xpath-protocol:node-type-p node
:processing-instruction
)
403 (write-processing-instruction
404 (xpath-protocol:processing-instruction-target node
)
405 (xpath-protocol:string-value node
)))
406 ((xpath-protocol:node-type-p node
:attribute
)
408 (xpath-protocol:local-name node
)
409 (xpath-protocol:namespace-uri node
)
410 (xpath-protocol:string-value node
)
411 :suggested-prefix
(xpath-protocol:namespace-prefix node
)))
413 (error "don't know how to copy node ~A" node
))))
415 (defun compile-message (fn args env
)
416 (let ((thunk (compile-instruction `(scoped-progn ,@args
) env
)))
419 (with-xml-output (cxml:make-string-sink
)
420 (funcall thunk ctx
))))))
422 (define-instruction xsl
:apply-templates
(args env
)
423 (destructuring-bind ((&key select mode
) &rest param-binding-specs
) args
425 (compile-xpath (or select
"child::node()") env
))
427 (compile-var-bindings param-binding-specs env
)))
428 (multiple-value-bind (mode-local-name mode-uri
)
429 (and mode
(decode-qname mode env nil
))
431 (let ((*mode
* (if mode
432 (or (find-mode *stylesheet
*
437 (apply-templates/list
438 (xpath:all-nodes
(funcall select-thunk ctx
))
439 (loop for
(name value-thunk
) in param-bindings
440 collect
(list name
(funcall value-thunk ctx
))))))))))
442 (define-instruction xsl
:call-template
(args env
)
443 (destructuring-bind (name &rest param-binding-specs
) args
444 (let ((param-bindings
445 (compile-var-bindings param-binding-specs env
)))
446 (multiple-value-bind (local-name uri
)
447 (decode-qname name env nil
)
448 (setf name
(cons local-name uri
)))
450 (call-template ctx name
451 (loop for
(name value-thunk
) in param-bindings
452 collect
(list name
(funcall value-thunk ctx
))))))))
454 (defun compile-instruction (form env
)
455 (funcall (or (get (car form
) 'xslt-instruction
)
456 (error "undefined instruction: ~A" (car form
)))
460 (xpath::deflexer make-attribute-template-lexer
461 ("([^{]+)" (data) (values :data data
))
462 ("{([^}]+)}" (xpath) (values :xpath xpath
)))
464 (defun compile-attribute-value-template (template-string env
)
465 (let* ((lexer (make-attribute-template-lexer template-string
))
470 (multiple-value-bind (kind str
) (funcall lexer
)
476 (xpath:compile-xpath str env
))
480 (values (lambda (ctx)
481 (with-output-to-string (s)
483 (write-string (xpath:string-value
(funcall fn ctx
)) s
))))
487 ;;;; Indentation for slime
489 (defmacro define-indentation
(name (&rest args
))
490 (labels ((collect-variables (list)
496 (collect-variables sub
))
498 (if (eql (mismatch "&" (symbol-name sub
)) 1)
501 `(defmacro ,name
(,@args
)
502 (declare (ignorable ,@(collect-variables args
)))
503 (error "XSL indentation helper ~A used literally in lisp code"
506 (define-indentation xsl
:element
507 ((name &key namespace use-attribute-sets
) &body body
))
508 (define-indentation xsl
:literal-element
((name &optional uri
) &body body
))
509 (define-indentation xsl
:attribute
((name &key namespace
) &body body
))
510 (define-indentation xsl
:literal-attribute
((name &optional uri
) &body body
))
511 (define-indentation xsl
:text
(str))
512 (define-indentation xsl
:processing-instruction
(name &body body
))
513 (define-indentation xsl
:comment
(str))
514 (define-indentation xsl
:value-of
(xpath))
515 (define-indentation xsl
:unescaped-value-of
(xpath))
516 (define-indentation xsl
:for-each
(select &body decls-and-body
))
517 (define-indentation xsl
:message
(&body body
))
518 (define-indentation xsl
:terminate
(&body body
))
519 (define-indentation xsl
:apply-templates
((&key select mode
) &body decls-and-body
))
520 (define-indentation xsl
:call-template
(name &rest parameters
))
521 (define-indentation xsl
:copy-of
(xpath))
525 (defun test-instruction (form document
)
526 (let ((thunk (compile-instruction form
(make-instance 'lexical-environment
)))
527 (root (cxml:parse document
(stp:make-builder
))))
528 (with-xml-output (cxml:make-string-sink
)
529 (funcall thunk
(xpath:make-context root
)))))