extensions.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 Ivan Shvedunov. All rights reserved.
   4 ;;; Copyright (c) 2007,2008 David Lichteblau. All rights reserved.
   5
   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.
  29
  30 (in-package :xuriella)
  31
  32
  33 ;;;; XSLT extensions
  34
  35 (defvar *extension-groups* (make-hash-table :test #'equal))
  36
  37 (defstruct extension-group
  38   uri
  39   documentation
  40   (elements (make-hash-table :test #'equal)))
  41
  42 (defstruct extension-element
  43   local-name
  44   (parser (lambda (&rest ignore)
  45             (declare (ignore ignore))
  46             (xslt-error "extension parser not defined"))))
  47
  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)
  61                 (t
  62                  (setf (get name 'extension-group)
  63                        (make-extension-group :uri uri
  64                                              :documentation documentation))))))
  65     (push new-ext (gethash uri *extension-groups*))))
  66
  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}.}
  73
  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))
  78
  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)))
  84
  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)))
  92
  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.}
  99
 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.
 103
 104    @code{body} should return an XSLT instruction in sexp syntax.
 105
 106    As a (very hypothetical) example, if the return value is computed using
 107
 108    @begin{pre}
 109    `(xsl:text ,(princ-to-string node-var))
 110    @end{pre}
 111
 112    the stylesheet will emit a text node at run time, with the string
 113    representation of the instruction node as a value.
 114
 115    Alternatively, a form can be returned that refers to user-specific
 116    compiler extensions:
 117
 118    @begin{pre}
 119    `(your-package::frob
 120      ,(stp:attribute-value node-var \"frob-arg\"))
 121    @end{pre}
 122
 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)))
 129
 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)
 136        do
 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)))))
 146
 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}
 152
 153    Defines @code{symbol} as a name to be used in Xuriella's sexp
 154    representation for XSLT.
 155
 156    It used when XSLT in sexp syntax includes a list of the form:
 157
 158    @begin{pre}(symbol ...arguments...)@end{pre}
 159
 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.
 163
 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.
 166
 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))))))
 183
 184
 185
 186 ;;;; our <document> extension
 187
 188 (define-extension-group :xuriella "http://common-lisp.net/project/xuriella"
 189   "XSLT extensions provided by Xuriella.")
 190
 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))))
 200
 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)
 222                     (t
 223                      (xslt-error "invalid output method: ~A" method)))
 224           :indent indent
 225           :doctype-public doctype-public
 226           :doctype-system doctype-system)
 227          pathname)))))