parser.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; 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 (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))))
  39
  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 bindings
  56             `((xsl:with-namespaces ,bindings
  57                 (xsl:with-excluded-namespaces ,excluded-uris
  58                   ,@exprs)))
  59             exprs))
  60       exprs))
  61
  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                         (stp: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)))))
  84
  85 (defun parse-param (node)
  86   ;; FIXME: empty body?
  87   (stp: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))))))
  95
  96 (defun parse-instruction (node)
  97   (typecase node
  98     (stp:element
  99      (let ((expr
 100             (if (equal (stp:namespace-uri node) *xsl*)
 101                 (parse-instruction/xsl-element
 102                  (or (find-symbol (stp:local-name node) :xuriella)
 103                      (xslt-error "undefined instruction: ~A"
 104                                  (stp:local-name node)))
 105                  node)
 106                 (parse-instruction/literal-element node))))
 107        (if (equal (stp:base-uri node) (stp:base-uri (stp:parent node)))
 108            expr
 109            (print`(xsl:with-base-uri ,(stp:base-uri node)
 110               ,expr)))))
 111     (stp:text
 112      `(xsl:text ,(stp:data node)))))
 113
 114 (defun parse-instruction/literal-element (node)
 115   `(xsl:literal-element
 116        (,(stp:local-name node)
 117          ,(stp:namespace-uri node)
 118          ,(stp:namespace-prefix node))
 119      (xsl:use-attribute-sets
 120       ,(stp:attribute-value node "use-attribute-sets" *xsl*))
 121      ,@(loop for a in (stp:list-attributes node)
 122             unless (and (namep a "use-attribute-sets"))
 123             collect `(xsl:literal-attribute
 124                          (,(stp:local-name a)
 125                            ,(stp:namespace-uri a)
 126                            ,(stp:namespace-prefix a))
 127                        ,(stp:value a)))
 128      ,@(parse-body node)))
 129
 130 (defmacro define-instruction-parser (name (node-var) &body body)
 131   `(defmethod parse-instruction/xsl-element
 132        ((.name. (eql ',name)) ,node-var)
 133      (declare (ignore .name.))
 134      ,@body))
 135
 136 (define-instruction-parser |apply-templates| (node)
 137   (stp:with-attributes (select mode) node
 138     (multiple-value-bind (decls rest)
 139         (loop
 140            for i from 0
 141            for cons on (stp:list-children node)
 142            for (child . nil) = cons
 143            while (namep child "sort")
 144            collect (parse-sort child) into decls
 145            finally (return (values decls cons)))
 146       `(xsl:apply-templates
 147            (:select ,select :mode ,mode)
 148          (declare ,@decls)
 149          ,@(mapcar (lambda (clause)
 150                      (unless (namep clause "with-param")
 151                        (xslt-error "undefined instruction: ~A"
 152                                    (stp:local-name clause)))
 153                      (parse-param clause))
 154                    rest)))))
 155
 156 (define-instruction-parser |apply-imports| (node)
 157   `(xsl:apply-imports))
 158
 159 (define-instruction-parser |call-template| (node)
 160   (stp:with-attributes (name) node
 161       `(xsl:call-template
 162         ,name ,@(stp:map-children 'list
 163                                   (lambda (clause)
 164                                     (if (namep clause "with-param")
 165                                         (parse-param clause)
 166                                         (xslt-error "undefined instruction: ~A"
 167                                                     (stp:local-name clause))))
 168                                   node))))
 169
 170 (define-instruction-parser |if| (node)
 171   (stp:with-attributes (test) node
 172     `(when ,test
 173        ,@(parse-body node))))
 174
 175 (define-instruction-parser |choose| (node)
 176   `(cond
 177      ,@(stp:map-children 'list
 178                          (lambda (clause)
 179                            (cond
 180                              ((namep clause "when")
 181                               (stp:with-attributes (test) clause
 182                                 `(,test
 183                                   ,@(parse-body clause))))
 184                              ((namep clause "otherwise")
 185                               `(t ,@(parse-body clause)))
 186                              (t
 187                               (xslt-error "invalid <choose> clause: ~A"
 188                                           (stp:local-name clause)))))
 189                          node)))
 190
 191 (define-instruction-parser |element| (node)
 192   (stp:with-attributes (name namespace use-attribute-sets) node
 193     `(xsl:element (,name :namespace ,namespace)
 194        (xsl:use-attribute-sets ,use-attribute-sets)
 195        ,@(parse-body node))))
 196
 197 (define-instruction-parser |attribute| (node)
 198   (stp:with-attributes (name namespace) node
 199     `(xsl:attribute (,name :namespace ,namespace)
 200        ,@(parse-body node))))
 201
 202 (define-instruction-parser |text| (node)
 203   `(xsl:text ,(stp:string-value node)))
 204
 205 (define-instruction-parser |comment| (node)
 206   `(xsl:comment ,@(parse-body node)))
 207
 208 (define-instruction-parser |processing-instruction| (node)
 209   (stp:with-attributes (name) node
 210     `(xsl:processing-instruction ,name
 211        ,@(parse-body node))))
 212
 213 (define-instruction-parser |value-of| (node)
 214   (stp:with-attributes (select disable-output-escaping) node
 215     (if disable-output-escaping
 216         `(xsl:unescaped-value-of ,select)
 217         `(xsl:value-of ,select))))
 218
 219 (define-instruction-parser |copy-of| (node)
 220   (stp:with-attributes (select) node
 221     `(xsl:copy-of ,select)))
 222
 223 (define-instruction-parser |copy| (node)
 224   (stp:with-attributes (use-attribute-sets) node
 225     `(xsl:copy
 226       (xsl:use-attribute-sets ,use-attribute-sets)
 227       ,@(parse-body node))))
 228
 229 (define-instruction-parser |variable| (node)
 230   (xslt-error "unhandled xsl:variable"))
 231
 232 (define-instruction-parser |for-each| (node)
 233   (stp:with-attributes (select) node
 234     (multiple-value-bind (decls body-position)
 235         (loop
 236            for i from 0
 237            for child in (stp:list-children node)
 238            while (namep child "sort")
 239            collect (parse-sort child) into decls
 240            finally (return (values decls i)))
 241       `(xsl:for-each ,select
 242          (declare ,@decls)
 243          ,@(parse-body node body-position)))))
 244
 245 (defun parse-sort (node)
 246   (stp:with-attributes (select lang data-type order case-order) node
 247     `(sort :select ,select
 248            :lang ,lang
 249            :data-type ,data-type
 250            :order ,order
 251            :case-order ,case-order)))
 252
 253 (define-instruction-parser |message| (node)
 254   `(xsl:message ,@(parse-body node)))
 255
 256 (define-instruction-parser |terminate| (node)
 257   `(xsl:terminate ,@(parse-body node)))
 258
 259 (define-instruction-parser |number| (node)
 260   (stp:with-attributes (level count from value format lang letter-value
 261                               grouping-separator grouping-size)
 262       node
 263     `(xsl:number :level ,level
 264                  :count ,count
 265                  :from ,from
 266                  :value ,value
 267                  :format ,format
 268                  :lang ,lang
 269                  :letter-value ,letter-value
 270                  :grouping-separator ,grouping-separator
 271                  :grouping-size ,grouping-size)))
 272
 273 (define-instruction-parser |document| (node)
 274   (stp:with-attributes (href method indent doctype-public doctype-system) node
 275     `(xsl:document (,href :method ,method
 276                           :indent ,indent
 277                           :doctype-public ,doctype-public
 278                           :doctype-system ,doctype-system)
 279        ,@(parse-body node))))