parser.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8 ;;;
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11 ;;;
  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.
  16 ;;;
  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.
  28
  29 (in-package :xuriella)
  30
  31 (defun map-namespace-declarations (fn element)
  32   (let ((parent (stp:parent element)))
  33     (maphash (lambda (prefix uri)
  34                (unless (and (typep parent 'stp:element)
  35                             (equal (stp:find-namespace prefix parent) uri))
  36                  (funcall fn prefix uri)))
  37              (cxml-stp-impl::collect-local-namespaces element))))
  38
  39 (defun maybe-wrap-namespaces (child exprs)
  40   (if (typep child 'stp:element)
  41       (let ((bindings '())
  42             (excluded-uris '()))
  43         (map-namespace-declarations (lambda (prefix uri)
  44                                       (push (list prefix uri) bindings))
  45                                     child)
  46         (stp:with-attributes ((erp "exclude-result-prefixes" *xsl*))
  47             child
  48           (dolist (prefix (words (or erp "")))
  49             (when (equal prefix "#default")
  50               (setf prefix nil))
  51             (push (or (stp:find-namespace prefix child)
  52                       (xslt-error "namespace not found: ~A" prefix))
  53                   excluded-uris)))
  54         (if bindings
  55             `((xsl:with-namespaces ,bindings
  56                 (xsl:with-excluded-namespaces ,excluded-uris
  57                   ,@exprs)))
  58             exprs))
  59       exprs))
  60
  61 (defun parse-body (node &optional (start 0) (param-names '()))
  62   (let ((n (stp:count-children-if #'identity node)))
  63     (labels ((recurse (i)
  64                (when (< i n)
  65                  (let ((child (stp:nth-child i node)))
  66                    (maybe-wrap-namespaces
  67                     child
  68                     (if (namep child "variable")
  69                         (stp:with-attributes (name select) child
  70                           (when (and select (stp:list-children child))
  71                             (xslt-error "variable with select and body"))
  72                           `((let ((,name ,(or select
  73                                               `(progn ,@(parse-body child)))))
  74                               (xsl:with-duplicates-check (,name)
  75                                 ,@(recurse (1+ i))))))
  76                         (cons (parse-instruction child)
  77                               (recurse (1+ i)))))))))
  78       (let ((result (recurse start)))
  79         (if param-names
  80             `((xsl:with-duplicates-check (,@param-names)
  81                 ,@result))
  82             result)))))
  83
  84 (defun parse-param (node)
  85   ;; FIXME: empty body?
  86   (stp:with-attributes (name select) node
  87     (unless name
  88       (xslt-error "name not specified for parameter"))
  89     (when (and select (stp:list-children node))
  90       (xslt-error "param with select and body"))
  91     (list name
  92           (or select
  93               `(progn ,@(parse-body node))))))
  94
  95 (defun parse-instruction (node)
  96   (typecase node
  97     (stp:element
  98      (if (equal (stp:namespace-uri node) *xsl*)
  99          (parse-instruction/xsl-element
 100           (or (find-symbol (stp:local-name node) :xuriella)
 101               (xslt-error "undefined instruction: ~A" (stp:local-name node)))
 102           node)
 103          (parse-instruction/literal-element node)))
 104     (stp:text
 105      `(xsl:text ,(stp:data node)))))
 106
 107 (defun parse-instruction/literal-element (node)
 108   `(xsl:literal-element
 109        (,(stp:local-name node)
 110          ,(stp:namespace-uri node)
 111          ,(stp:namespace-prefix node))
 112      ,@(stp:map-attributes 'list
 113                            (lambda (a)
 114                              `(xsl:literal-attribute
 115                                   (,(stp:local-name a)
 116                                     ,(stp:namespace-uri a)
 117                                     ,(stp:namespace-prefix a))
 118                                 ,(stp:value a)))
 119                            node)
 120      ,@(parse-body node)))
 121
 122 (defmacro define-instruction-parser (name (node-var) &body body)
 123   `(defmethod parse-instruction/xsl-element
 124        ((.name. (eql ',name)) ,node-var)
 125      (declare (ignore .name.))
 126      ,@body))
 127
 128 (define-instruction-parser |apply-templates| (node)
 129   (stp:with-attributes (select mode) node
 130     (multiple-value-bind (decls rest)
 131         (loop
 132            for i from 0
 133            for cons on (stp:list-children node)
 134            for (child . nil) = cons
 135            while (namep child "sort")
 136            collect (parse-sort child) into decls
 137            finally (return (values decls cons)))
 138       `(xsl:apply-templates
 139            (:select ,select :mode ,mode)
 140          (declare ,@decls)
 141          ,@(mapcar (lambda (clause)
 142                      (unless (namep clause "with-param")
 143                        (xslt-error "undefined instruction: ~A"
 144                                    (stp:local-name clause)))
 145                      (parse-param clause))
 146                    rest)))))
 147
 148 (define-instruction-parser |call-template| (node)
 149   (stp:with-attributes (name) node
 150       `(xsl:call-template
 151         ,name ,@(stp:map-children 'list
 152                                   (lambda (clause)
 153                                     (if (namep clause "with-param")
 154                                         (parse-param clause)
 155                                         (xslt-error "undefined instruction: ~A"
 156                                                     (stp:local-name clause))))
 157                                   node))))
 158
 159 (define-instruction-parser |if| (node)
 160   (stp:with-attributes (test) node
 161     `(when ,test
 162        ,@(parse-body node))))
 163
 164 (define-instruction-parser |choose| (node)
 165   `(cond
 166      ,@(stp:map-children 'list
 167                          (lambda (clause)
 168                            (cond
 169                              ((namep clause "when")
 170                               (stp:with-attributes (test) clause
 171                                 `(,test
 172                                   ,@(parse-body clause))))
 173                              ((namep clause "otherwise")
 174                               `(t ,@(parse-body clause)))
 175                              (t
 176                               (xslt-error "invalid <choose> clause: ~A"
 177                                           (stp:local-name clause)))))
 178                          node)))
 179
 180 (define-instruction-parser |element| (node)
 181   (stp:with-attributes (name namespace use-attribute-sets) node
 182     `(xsl:element (,name :namespace ,namespace
 183                          :use-attribute-sets ,use-attribute-sets)
 184        ,@(parse-body node))))
 185
 186 (define-instruction-parser |attribute| (node)
 187   (stp:with-attributes (name namespace) node
 188     `(xsl:attribute (,name :namespace ,namespace)
 189        ,@(parse-body node))))
 190
 191 (define-instruction-parser |text| (node)
 192   `(xsl:text ,(stp:string-value node)))
 193
 194 (define-instruction-parser |comment| (node)
 195   `(xsl:comment ,@(stp:string-value node)))
 196
 197 (define-instruction-parser |processing-instruction| (node)
 198   (stp:with-attributes (name) node
 199     `(xsl:processing-instruction ,name
 200        ,@(parse-body node))))
 201
 202 (define-instruction-parser |value-of| (node)
 203   (stp:with-attributes (select disable-output-escaping) node
 204     (if disable-output-escaping
 205         `(xsl:unescaped-value-of ,select)
 206         `(xsl:value-of ,select))))
 207
 208 (define-instruction-parser |copy-of| (node)
 209   (stp:with-attributes (select) node
 210     `(xsl:copy-of ,select)))
 211
 212 (define-instruction-parser |copy| (node)
 213   (stp:with-attributes (use-attribute-sets) node
 214     `(xsl:copy (:use-attribute-sets ,use-attribute-sets)
 215                ,@(parse-body node))))
 216
 217 (define-instruction-parser |variable| (node)
 218   (xslt-error "unhandled xsl:variable"))
 219
 220 (define-instruction-parser |for-each| (node)
 221   (stp:with-attributes (select) node
 222     (multiple-value-bind (decls body-position)
 223         (loop
 224            for i from 0
 225            for child in (stp:list-children node)
 226            while (namep child "sort")
 227            collect (parse-sort child) into decls
 228            finally (return (values decls i)))
 229       `(xsl:for-each ,select
 230          (declare ,@decls)
 231          ,@(parse-body node body-position)))))
 232
 233 (defun parse-sort (node)
 234   (stp:with-attributes (select lang data-type order case-order) node
 235     `(sort :select ,select
 236            :lang ,lang
 237            :data-type ,data-type
 238            :order ,order
 239            :case-order ,case-order)))
 240
 241 (define-instruction-parser |message| (node)
 242   `(xsl:message ,@(parse-body node)))
 243
 244 (define-instruction-parser |terminate| (node)
 245   `(xsl:terminate ,@(parse-body node)))