1 ;;; -*- show-trailing-whitespace: t; indent-tabs: 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
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
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.
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
)
33 (declaim (optimize (debug 2)))
38 (defmacro define-instruction
(name (args-var env-var
) &body body
)
39 `(setf (get ',name
'xslt-instruction
)
40 (lambda (,args-var
,env-var
)
41 (declare (ignorable ,env-var
))
44 (define-instruction if
(args env
)
45 (destructuring-bind (test then
&optional else
) args
46 (let ((test-thunk (compile-xpath test env
))
47 (then-thunk (compile-instruction then env
))
48 (else-thunk (when else
(compile-instruction else env
))))
51 ((xpath:boolean-value
(funcall test-thunk ctx
))
52 (funcall then-thunk ctx
))
54 (funcall else-thunk ctx
)))))))
56 (define-instruction when
(args env
)
57 (destructuring-bind (test &rest body
) args
58 (compile-instruction `(if ,test
(progn ,@body
)) env
)))
60 (define-instruction unless
(args env
)
61 (destructuring-bind (test &rest body
) args
62 (compile-instruction `(if (:not
,test
) (progn ,@body
)) env
)))
64 (define-instruction cond
(args env
)
66 (destructuring-bind ((test &body body
) &rest clauses
) args
67 (compile-instruction (if (eq test t
)
75 (define-instruction progn
(args env
)
77 (let ((first-thunk (compile-instruction (first args
) env
))
78 (rest-thunk (compile-instruction `(progn ,@(rest args
)) env
)))
80 (funcall first-thunk ctx
)
81 (funcall rest-thunk ctx
)))
84 (defun decode-qname/runtime
(qname namespaces attributep
)
86 (multiple-value-bind (prefix local-name
)
89 (if (or prefix
(not attributep
))
90 (cdr (assoc prefix namespaces
:test
'equal
))
93 (cxml:well-formedness-violation
()
94 (xslt-error "not a qname: ~A" qname
))))
96 (define-instruction xsl
:element
(args env
)
97 (destructuring-bind ((name &key namespace use-attribute-sets
)
100 (declare (ignore use-attribute-sets
)) ;fixme
101 (multiple-value-bind (name-thunk constant-name-p
)
102 (compile-avt name env
)
103 (multiple-value-bind (ns-thunk constant-ns-p
)
105 (compile-avt namespace env
)
107 (let ((body-thunk (compile-instruction `(progn ,@body
) env
)))
108 (if (and constant-name-p constant-ns-p
)
109 (compile-element/constant-name name namespace env body-thunk
)
110 (compile-element/runtime name-thunk ns-thunk body-thunk
)))))))
112 (defun compile-element/constant-name
(qname namespace env body-thunk
)
113 ;; the simple case: compile-time decoding of the QName
114 (multiple-value-bind (local-name uri prefix
)
115 (decode-qname qname env nil
)
117 (setf uri namespace
))
119 (with-element (local-name uri
:suggested-prefix prefix
)
120 (funcall body-thunk ctx
)))))
122 (defun compile-element/runtime
(name-thunk ns-thunk body-thunk
)
123 ;; run-time decoding of the QName, but using the same namespaces
124 ;; that would have been known at compilation time.
125 (let ((namespaces *namespaces
*))
127 (let ((qname (funcall name-thunk ctx
)))
128 (multiple-value-bind (local-name uri prefix
)
129 (decode-qname/runtime qname namespaces nil
)
131 (setf uri
(funcall ns-thunk ctx
)))
134 (with-element (local-name uri
:suggested-prefix prefix
)
135 (funcall body-thunk ctx
)))))))
137 (define-instruction xsl
:use-attribute-sets
(args env
)
138 (destructuring-bind (str) args
139 (let ((sets (mapcar (lambda (qname)
140 (multiple-value-list (decode-qname qname env nil
)))
143 (loop for
(local-name uri nil
) in sets do
144 (dolist (thunk (find-attribute-set local-name uri
))
145 (funcall thunk ctx
)))))))
147 (define-instruction xsl
:attribute
(args env
)
148 (destructuring-bind ((name &key namespace
) &body body
) args
149 (multiple-value-bind (name-thunk constant-name-p
)
150 (compile-avt name env
)
151 (multiple-value-bind (ns-thunk constant-ns-p
)
153 (compile-avt namespace env
)
155 (let ((value-thunk (compile-instruction `(progn ,@body
) env
)))
156 (if (and constant-name-p constant-ns-p
)
157 (compile-attribute/constant-name name namespace env value-thunk
)
158 (compile-attribute/runtime name-thunk ns-thunk value-thunk
)))))))
160 (defun compile-attribute/constant-name
(qname namespace env value-thunk
)
161 ;; the simple case: compile-time decoding of the QName
162 (multiple-value-bind (local-name uri prefix
)
163 (decode-qname qname env nil
)
165 (setf uri namespace
))
167 (write-attribute local-name
169 (with-text-output-sink (s)
171 (funcall value-thunk ctx
)))
172 :suggested-prefix prefix
))))
174 (defun compile-attribute/runtime
(name-thunk ns-thunk value-thunk
)
175 ;; run-time decoding of the QName, but using the same namespaces
176 ;; that would have been known at compilation time.
177 (let ((namespaces *namespaces
*))
179 (let ((qname (funcall name-thunk ctx
)))
180 (multiple-value-bind (local-name uri prefix
)
181 (decode-qname/runtime qname namespaces nil
)
183 (setf uri
(funcall ns-thunk ctx
)))
184 (write-attribute local-name
186 (with-text-output-sink (s)
188 (funcall value-thunk ctx
)))
189 :suggested-prefix prefix
))))))
191 (defun remove-excluded-namespaces
192 (namespaces &optional
(excluded-uris *excluded-namespaces
*))
193 (let ((koerbchen '())
196 for cons in namespaces
197 for
(prefix . uri
) = cons
200 ((find prefix kroepfchen
:test
#'equal
))
201 ((find uri excluded-uris
:test
#'equal
)
202 (push prefix kroepfchen
))
204 (push cons koerbchen
))))
207 (define-instruction xsl
:literal-element
(args env
)
209 ((local-name &optional
(uri "") suggested-prefix
) &body body
)
211 (let ((body-thunk (compile-instruction `(progn ,@body
) env
))
212 (namespaces (remove-excluded-namespaces *namespaces
*)))
214 (with-element (local-name uri
215 :suggested-prefix suggested-prefix
216 :extra-namespaces namespaces
)
217 (funcall body-thunk ctx
))))))
219 (define-instruction xsl
:literal-attribute
(args env
)
220 (destructuring-bind ((local-name &optional uri suggested-prefix
) value
) args
221 (let ((value-thunk (compile-avt value env
)))
223 (write-attribute local-name
225 (funcall value-thunk ctx
)
226 :suggested-prefix suggested-prefix
)))))
228 (define-instruction xsl
:text
(args env
)
229 (destructuring-bind (str) args
231 (declare (ignore ctx
))
234 (define-instruction xsl
:processing-instruction
(args env
)
235 (destructuring-bind (name &rest body
) args
236 (let ((name-thunk (compile-avt name env
))
237 (value-thunk (compile-instruction `(progn ,@body
) env
)))
239 (write-processing-instruction
240 (funcall name-thunk ctx
)
241 (with-text-output-sink (s)
243 (funcall value-thunk ctx
))))))))
245 (define-instruction xsl
:comment
(args env
)
246 (destructuring-bind (str) args
248 (declare (ignore ctx
))
249 (write-comment str
))))
251 (define-instruction xsl
:value-of
(args env
)
252 (destructuring-bind (xpath) args
253 (let ((thunk (compile-xpath xpath env
)))
256 (write-text (xpath:string-value
(funcall thunk ctx
))))
257 "value-of ~s = ~s" xpath
:result
))))
259 (define-instruction xsl
:unescaped-value-of
(args env
)
260 (destructuring-bind (xpath) args
261 (let ((thunk (compile-xpath xpath env
)))
263 (write-unescaped (xpath:string-value
(funcall thunk ctx
)))))))
265 (define-instruction xsl
:copy-of
(args env
)
266 (destructuring-bind (xpath) args
267 (let ((thunk (compile-xpath xpath env
))
268 ;; FIXME: what was this for? --david
269 #+(or) (v (intern-variable "varName" "")))
271 (let ((result (funcall thunk ctx
)))
273 (xpath:node-set
;; FIXME: variables can contain node sets w/fragments inside. Maybe just fragments would do?
274 (xpath:map-node-set
#'copy-into-result result
))
275 (result-tree-fragment
276 (copy-into-result result
))
278 (write-text (xpath:string-value result
)))))))))
280 (defun copy-into-result (node)
282 ((result-tree-fragment-p node
)
283 (stp:do-children
(child (result-tree-fragment-node node
))
284 (copy-into-result child
)))
285 ((xpath-protocol:node-type-p node
:element
)
286 (with-element ((xpath-protocol:local-name node
)
287 (xpath-protocol:namespace-uri node
)
288 :suggested-prefix
(xpath-protocol:namespace-prefix node
)
289 ;; FIXME: is remove-excluded-namespaces correct here?
290 :extra-namespaces
(remove-excluded-namespaces
291 (namespaces-as-alist node
)))
292 (map-pipe-eagerly #'copy-into-result
293 (xpath-protocol:attribute-pipe node
))
294 (map-pipe-eagerly #'copy-into-result
295 (xpath-protocol:child-pipe node
))))
296 ((xpath-protocol:node-type-p node
:document
)
297 (map-pipe-eagerly #'copy-into-result
298 (xpath-protocol:child-pipe node
)))
300 (copy-leaf-node node
))))
302 (defun make-sorter (spec env
)
303 (destructuring-bind (&key select lang data-type order case-order
)
305 ;; FIXME: implement case-order
306 (declare (ignore lang case-order
))
307 (let ((select-thunk (compile-xpath (or select
".") env
))
308 (numberp (equal data-type
"number"))
309 (f (if (equal order
"descending") -
1 1)))
311 (let ((i (xpath:string-value
312 (funcall select-thunk
(xpath:make-context a
))))
313 (j (xpath:string-value
314 (funcall select-thunk
(xpath:make-context b
)))))
317 (signum (- (xpath:number-value i
) (xpath:number-value j
)))
323 (defun compose-sorters (sorters)
325 (let ((this (car sorters
))
326 (next (compose-sorters (rest sorters
))))
328 (let ((d (funcall this a b
)))
334 (defun make-sort-predicate (decls env
)
337 (mapcar (lambda (x) (make-sorter x env
)) decls
))))
339 (minusp (funcall sorter a b
)))))
341 (define-instruction xsl
:for-each
(args env
)
342 (destructuring-bind (select &optional decls
&rest body
) args
343 (unless (and (consp decls
)
344 (eq (car decls
) 'declare
))
347 (let ((select-thunk (compile-xpath select env
))
348 (body-thunk (compile-instruction `(progn ,@body
) env
))
351 (make-sort-predicate (cdr decls
) env
))))
353 (let ((selected (funcall select-thunk ctx
)))
354 (unless (xpath:node-set-p selected
)
355 (xslt-error "for-each select expression should yield a node-set"))
356 (let ((nodes (xpath::force
357 (xpath::sorted-pipe-of selected
))))
359 (setf nodes
(sort (copy-list nodes
) sort-predicate
)))
361 with n
= (length nodes
)
366 (xpath:make-context node
(lambda () n
) i
)))))))))
368 (define-instruction xsl
:with-namespaces
(args env
)
369 (destructuring-bind ((&rest forms
) &rest body
) args
370 (let ((*namespaces
* *namespaces
*))
372 (destructuring-bind (prefix uri
) form
373 (push (cons prefix uri
) *namespaces
*)))
374 (compile-instruction `(progn ,@body
) env
))))
376 (define-instruction xsl
:with-excluded-namespaces
(args env
)
377 (destructuring-bind ((&rest uris
) &rest body
) args
378 (let ((*excluded-namespaces
* (append uris
*excluded-namespaces
*)))
379 (compile-instruction `(progn ,@body
) env
))))
381 ;; XSLT disallows multiple definitions of the same variable within a
382 ;; template. Local variables can shadow global variables though.
383 ;; Since our LET syntax makes it natural to shadow local variables the
384 ;; Lisp way, we check for duplicate variables only where instructed to
385 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
386 (defvar *template-variables
* nil
)
388 (define-instruction xsl
:with-duplicates-check
(args env
)
389 (let ((*template-variables
* *template-variables
*))
390 (destructuring-bind ((&rest qnames
) &rest body
) args
391 (dolist (qname qnames
)
392 (multiple-value-bind (local-name uri
)
393 (decode-qname qname env nil
)
394 (let ((key (cons local-name uri
)))
395 (when (find key
*template-variables
* :test
#'equal
)
396 (xslt-error "duplicate variable: ~A, ~A" local-name uri
))
397 (push key
*template-variables
*))))
398 (compile-instruction `(progn ,@body
) env
))))
400 (define-instruction xsl
:with-base-uri
(args env
)
401 (destructuring-bind (uri &rest body
) args
402 (let ((*instruction-base-uri
* uri
))
403 (compile-instruction `(progn ,@body
) env
))))
405 (defstruct (result-tree-fragment
406 (:constructor make-result-tree-fragment
(node)))
409 (define-default-method xpath-protocol
:node-p
410 ((node result-tree-fragment
))
413 (define-default-method xpath-protocol
:string-value
414 ((node result-tree-fragment
))
415 (xpath-protocol:string-value
(result-tree-fragment-node node
)))
417 (defun apply-to-result-tree-fragment (ctx thunk
)
419 (with-xml-output (stp:make-builder
)
420 (with-element ("fragment" "")
421 (funcall thunk ctx
)))))
422 (make-result-tree-fragment (stp:document-element document
))))
424 (define-instruction let
(args env
)
425 (destructuring-bind ((&rest forms
) &rest body
) args
426 (let* ((old-top (length *lexical-variable-declarations
*))
427 (vars-and-names (compile-var-bindings/nointern forms env
))
429 (loop for
((local-name . uri
) thunk
) in vars-and-names
431 (list (push-variable local-name
433 *lexical-variable-declarations
*)
435 (let ((thunk (compile-instruction `(progn ,@body
) env
)))
436 (fill *lexical-variable-declarations
* nil
:start old-top
)
438 (loop for
(index var-thunk
) in vars-and-positions
439 do
(setf (lexical-variable-value index
)
440 (funcall var-thunk ctx
)))
441 (funcall thunk ctx
))))))
443 (define-instruction let
* (args env
)
444 (destructuring-bind ((&rest forms
) &rest body
) args
446 (compile-instruction `(let (,(car forms
))
447 (let* (,@(cdr forms
))
450 (compile-instruction `(progn ,@body
) env
))))
452 (define-instruction xsl
:message
(args env
)
453 (compile-message #'warn args env
))
455 (define-instruction xsl
:terminate
(args env
)
456 (compile-message #'error args env
))
458 (defun namespaces-as-alist (element)
459 (let ((namespaces '()))
460 (do-pipe (ns (xpath-protocol:namespace-pipe element
))
461 (push (cons (xpath-protocol:local-name ns
)
462 (xpath-protocol:namespace-uri ns
))
466 (define-instruction xsl
:copy
(args env
)
467 (let ((body (compile-instruction `(progn ,@args
) env
)))
469 (let ((node (xpath:context-node ctx
)))
471 ((xpath-protocol:node-type-p node
:element
)
473 ((xpath-protocol:local-name node
)
474 (xpath-protocol:namespace-uri node
)
475 :suggested-prefix
(xpath-protocol:namespace-prefix node
)
476 :extra-namespaces
(namespaces-as-alist node
))
478 ((xpath-protocol:node-type-p node
:document
)
481 (copy-leaf-node node
)))))))
483 (defun copy-leaf-node (node)
485 ((xpath-protocol:node-type-p node
:text
)
486 (write-text (xpath-protocol:string-value node
)))
487 ((xpath-protocol:node-type-p node
:comment
)
488 (write-comment (xpath-protocol:string-value node
)))
489 ((xpath-protocol:node-type-p node
:processing-instruction
)
490 (write-processing-instruction
491 (xpath-protocol:processing-instruction-target node
)
492 (xpath-protocol:string-value node
)))
493 ((xpath-protocol:node-type-p node
:attribute
)
495 (xpath-protocol:local-name node
)
496 (xpath-protocol:namespace-uri node
)
497 (xpath-protocol:string-value node
)
498 :suggested-prefix
(xpath-protocol:namespace-prefix node
)))
500 (error "don't know how to copy node ~A" node
))))
502 (defun compile-message (fn args env
)
503 (let ((thunk (compile-instruction `(progn ,@args
) env
)))
506 (with-xml-output (cxml:make-string-sink
)
507 (funcall thunk ctx
))))))
509 (define-instruction xsl
:apply-templates
(args env
)
510 (destructuring-bind ((&key select mode
) &rest param-binding-specs
) args
512 (when (and (consp (car param-binding-specs
))
513 (eq (caar param-binding-specs
) 'declare
))
514 (cdr (pop param-binding-specs
))))
516 (compile-xpath (or select
"child::node()") env
))
518 (compile-var-bindings param-binding-specs env
))
521 (make-sort-predicate decls env
))))
522 (multiple-value-bind (mode-local-name mode-uri
)
523 (and mode
(decode-qname mode env nil
))
525 (let ((*mode
* (if mode
526 (or (find-mode *stylesheet
*
531 (apply-templates/list
533 (xpath::sorted-pipe-of
(funcall select-thunk ctx
)))
534 (loop for
(name nil value-thunk
) in param-bindings
535 collect
(list name
(funcall value-thunk ctx
)))
536 sort-predicate
)))))))
538 (define-instruction xsl
:apply-imports
(args env
)
539 (declare (ignore args env
))
541 (declare (ignore ctx
))
542 (funcall *apply-imports
*)))
544 (define-instruction xsl
:call-template
(args env
)
545 (destructuring-bind (name &rest param-binding-specs
) args
546 (let ((param-bindings
547 (compile-var-bindings param-binding-specs env
)))
548 (multiple-value-bind (local-name uri
)
549 (decode-qname name env nil
)
550 (setf name
(cons local-name uri
)))
552 (call-template ctx name
553 (loop for
(name nil value-thunk
) in param-bindings
554 collect
(list name
(funcall value-thunk ctx
))))))))
556 (defun compile-instruction (form env
)
558 (funcall (or (get (car form
) 'xslt-instruction
)
559 (error "undefined instruction: ~A" (car form
)))
562 "instruction ~s" (car form
)))
564 ;;: WTF: "A right curly brace inside a Literal in an expression is not
565 ;;; recognized as terminating the expression."
567 ;;; Da hilft nur tagbody.
568 (defun parse-attribute-value-template (template-string)
569 (with-input-from-string (input template-string
)
570 (let ((ordinary (make-string-output-stream))
571 (xpath (make-string-output-stream))
573 (c (read-char input nil
:eof
)))
575 (let ((o (get-output-stream-string ordinary
)))
576 (when (plusp (length o
))
577 (push (list :data o
) tokens
)))
578 (let ((x (get-output-stream-string xpath
)))
579 (when (plusp (length x
))
580 (push (list :xpath x
) tokens
))))
582 (write-char c ordinary
))
584 (write-char c xpath
)))
585 (macrolet ((goto (target)
587 (setf c
(read-char input nil
:eof
))
608 (goto in-single-quote
))
610 (xslt-error "unexpected end of avt")))
619 (goto in-single-quote
))
622 (goto in-double-quote
))
624 (goto seen-closing-
}))
626 (xslt-error "unexpected end of avt")))
636 (xslt-error "unexpected end of avt")))
638 (goto in-single-quote
)
646 (xslt-error "unexpected end of avt")))
648 (goto in-double-quote
)
669 (xslt-error "unexpected closing brace in avt")
675 (defun compile-avt (template-string env
)
681 (constantly (second x
)))
684 (compile-xpath (second x
) env
))))
685 (parse-attribute-value-template template-string
))))
686 (values (lambda (ctx)
687 (with-output-to-string (s)
689 (write-string (xpath:string-value
(funcall fn ctx
)) s
))))
693 ;;;; Indentation for slime
695 (defmacro define-indentation
(name (&rest args
))
696 (labels ((collect-variables (list)
702 (collect-variables sub
))
704 (if (eql (mismatch "&" (symbol-name sub
)) 1)
707 `(defmacro ,name
(,@args
)
708 (declare (ignorable ,@(collect-variables args
)))
709 (error "XSL indentation helper ~A used literally in lisp code"
712 (define-indentation xsl
:element
713 ((name &key namespace use-attribute-sets
) &body body
))
714 (define-indentation xsl
:literal-element
((name &optional uri
) &body body
))
715 (define-indentation xsl
:attribute
((name &key namespace
) &body body
))
716 (define-indentation xsl
:literal-attribute
((name &optional uri
) &body body
))
717 (define-indentation xsl
:text
(str))
718 (define-indentation xsl
:processing-instruction
(name &body body
))
719 (define-indentation xsl
:comment
(str))
720 (define-indentation xsl
:value-of
(xpath))
721 (define-indentation xsl
:unescaped-value-of
(xpath))
722 (define-indentation xsl
:for-each
(select &body decls-and-body
))
723 (define-indentation xsl
:message
(&body body
))
724 (define-indentation xsl
:terminate
(&body body
))
725 (define-indentation xsl
:apply-templates
((&key select mode
) &body decls-and-body
))
726 (define-indentation xsl
:call-template
(name &rest parameters
))
727 (define-indentation xsl
:copy-of
(xpath))
731 (defun test-instruction (form document
)
732 (let ((thunk (compile-instruction form
(make-instance 'lexical-environment
)))
733 (root (cxml:parse document
(stp:make-builder
))))
734 (with-xml-output (cxml:make-string-sink
)
735 (funcall thunk
(xpath:make-context root
)))))