Fix "for each hash-key in ... using" ordering
[xuriella.git] / extensions.lisp
bloba7fec8bbfe03291a4090360ae84ee59552e9c982
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,2008 Ivan Shvedunov. All rights reserved.
4 ;;; Copyright (c) 2007,2008 David Lichteblau. 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)
33 ;;;; XSLT extensions
35 (defvar *extension-groups* (make-hash-table :test #'equal))
37 (defstruct extension-group
38 uri
39 documentation
40 (elements (make-hash-table :test #'equal)))
42 (defstruct extension-element
43 local-name
44 (parser (lambda (&rest ignore)
45 (declare (ignore ignore))
46 (xslt-error "extension parser not defined"))))
48 (defun %define-extension-group (name uri documentation)
49 (check-type uri string)
50 (let* ((current-ext (get name 'extension-group))
51 (new-ext
52 (cond (current-ext
53 (setf (gethash (extension-group-uri current-ext)
54 *extension-groups*)
55 (remove current-ext
56 (gethash (extension-group-uri current-ext)
57 *extension-groups*))
58 (extension-group-uri current-ext) uri
59 (extension-group-documentation current-ext) documentation)
60 current-ext)
62 (setf (get name 'extension-group)
63 (make-extension-group :uri uri
64 :documentation documentation))))))
65 (push new-ext (gethash uri *extension-groups*))))
67 (defmacro define-extension-group (name uri &optional documentation)
68 "@arg[name]{The name of the XSLT extension group (a symbol)}
69 @arg[uri]{Namespace URI for the extension elements (a string)}
70 @arg[documentation]{Documentation string for the XPath extension}
71 @short{Defines an XSLT extension group with specified
72 short @code{name} and namespace @code{uri}.}
74 An XSLT extension group is a collection of XSLT element that are defined
75 using @fun{define-extension-parser}."
76 (check-type name symbol)
77 `(%define-extension-group ',name ,uri ,documentation))
79 (defun find-extension-element (local-name uri)
80 (loop for ext in (gethash uri *extension-groups*)
81 for match = (gethash local-name (extension-group-elements ext))
82 when match
83 do (return match)))
85 (defun ensure-extension-element (ext name)
86 (check-type name string)
87 (setf (gethash name
88 (extension-group-elements
89 (or (get ext 'extension-group)
90 (error "no such extension: ~s" ext))))
91 (make-extension-element :local-name name)))
93 (defmacro define-extension-parser (ext name (node-var) &body body)
94 "@arg[ext]{The name of an XSLT extension group (a symbol)}
95 @arg[name]{Local name of the extension element (a string)}
96 @arg[node-var]{Variable name for the node to be parsed, a symbol.}
97 @arg[body]{Lisp forms, an implicit progn}
98 @short{Defines a parser an extension element.}
100 The parser function defined by this macro will be invoked when
101 an XSLT extension element is encountered that has the namespace URI
102 of the specified extension group and the local-name of this parser.
104 @code{body} should return an XSLT instruction in sexp syntax.
106 As a (very hypothetical) example, if the return value is computed using
108 @begin{pre}
109 `(xsl:text ,(princ-to-string node-var))
110 @end{pre}
112 the stylesheet will emit a text node at run time, with the string
113 representation of the instruction node as a value.
115 Alternatively, a form can be returned that refers to user-specific
116 compiler extensions:
118 @begin{pre}
119 `(your-package::frob
120 ,(stp:attribute-value node-var \"frob-arg\"))
121 @end{pre}
123 Use @fun{define-extension-compiler} to implement an extension like
124 @code{frob}."
125 `(setf (extension-element-parser
126 (ensure-extension-element ',ext ',name))
127 (lambda (,node-var)
128 ,@body)))
130 (eval-when (:compile-toplevel :load-toplevel :execute)
131 (defun parse-extension-lambda-list (lambda-list)
132 ;; find &environment
133 (loop
134 for (form . rest) on lambda-list
135 when (eq form '&environment)
137 (destructuring-bind (env-var &rest rest-rest) rest
138 (check-type env-var (and symbol (not null)))
139 (when (find '&environment rest-rest)
140 (error "duplicate &environment in extension lambda list"))
141 (return
142 (values env-var (append normal-forms rest-rest))))
143 collect form into normal-forms
144 finally
145 (return (values 'ignore normal-forms)))))
147 (defmacro define-extension-compiler (symbol (&rest lambda-list) &body body)
148 "@arg[symbol]{The name of the extension, a symbol}
149 @arg[lambda-list]{A destructuring lambda list, optionaly augmented using
150 &environment}
151 @arg[body]{Lisp forms, an implicit progn}
153 Defines @code{symbol} as a name to be used in Xuriella's sexp
154 representation for XSLT.
156 It used when XSLT in sexp syntax includes a list of the form:
158 @begin{pre}(symbol ...arguments...)@end{pre}
160 The list @code{arguments} is then destructured using the specified lambda
161 list, and @code{body} is invoked during compilation time as an implicit
162 progn.
164 @code{body} should return a function of one argument, which will be called
165 at run time with a context object as an argument.
167 @see{compile-instruction}"
168 (when (find (symbol-package symbol)
169 ;; reserved for built-in instructions:
170 (list (find-package :common-lisp)
171 (find-package :xslt)
172 (find-package :xuriella)))
173 (error "cannot define XSLT extensions in the ~A package"
174 (symbol-package symbol)))
175 (multiple-value-bind (env argument-lambda-list)
176 (parse-extension-lambda-list lambda-list)
177 (let ((args (gensym)))
178 `(setf (get ',symbol 'extension-compiler)
179 (lambda (,ARGS ,env)
180 (declare (ignorable ,env))
181 (destructuring-bind (,@argument-lambda-list) ,ARGS
182 ,@body))))))
186 ;;;; our <document> extension
188 (define-extension-group :xuriella "http://common-lisp.net/project/xuriella"
189 "XSLT extensions provided by Xuriella.")
191 (define-extension-parser :xuriella "document" (node)
192 (only-with-attributes
193 (href method indent doctype-public doctype-system) node
194 `(xuriella-extensions:document
195 (,href :method ,method
196 :indent ,indent
197 :doctype-public ,doctype-public
198 :doctype-system ,doctype-system)
199 ,@(parse-body node))))
201 (define-extension-compiler xuriella-extensions:document
202 ((href &key method indent doctype-public doctype-system)
203 &body body
204 &environment env)
205 (let ((thunk (compile-instruction `(progn ,@body) env))
206 (href-thunk (compile-avt href env)))
207 (lambda (ctx)
208 (let ((pathname
209 (uri-to-pathname
210 (puri:merge-uris (funcall href-thunk ctx)
211 (xpath-protocol:base-uri
212 (xpath:context-node ctx))))))
213 (ensure-directories-exist pathname) ;really?
214 (invoke-with-output-sink
215 (lambda ()
216 (funcall thunk ctx))
217 (make-output-specification
218 :method (cond
219 ((or (null method) (equalp method "XML")) :xml)
220 ((equalp method "HTML") :html)
221 ((equalp method "TEXT") :text)
223 (xslt-error "invalid output method: ~A" method)))
224 :indent indent
225 :doctype-public doctype-public
226 :doctype-system doctype-system)
227 pathname)))))