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 (or bindings excluded-uris)
  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                    (if (namep child "variable")
  68                        (maybe-wrap-namespaces
  69                         child
  70                         (only-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                        (append (maybe-wrap-namespaces
  78                                 child
  79                                 (list (parse-instruction child)))
  80                                (recurse (1+ i))))))))
  81       (let ((result (recurse start)))
  82         (if param-names
  83             `((xsl:with-duplicates-check (,@param-names)
  84                 ,@result))
  85             result)))))
  86
  87 (defun parse-param (node)
  88   ;; FIXME: empty body?
  89   (only-with-attributes (name select) node
  90     (unless name
  91       (xslt-error "name not specified for parameter"))
  92     (when (and select (stp:list-children node))
  93       (xslt-error "param with select and body"))
  94     (list name
  95           (or select
  96               `(progn ,@(parse-body node))))))
  97
  98 (defun parse-instruction (node)
  99   (typecase node
 100     (stp:element
 101      (let ((expr
 102             (cond
 103               ((equal (stp:namespace-uri node) *xsl*)
 104                (let ((sym (find-symbol (stp:local-name node) :xuriella)))
 105                  (cond
 106                    (sym
 107                     (parse-instruction/xsl-element sym node))
 108                    (*forwards-compatible-p*
 109                     (parse-fallback-children node))
 110                    (t
 111                     (xslt-error "undefined instruction: ~A"
 112                                 (stp:local-name node))))))
 113               ((find (stp:namespace-uri node)
 114                      *extension-namespaces*
 115                      :test #'equal)
 116                (parse-fallback-children node))
 117               (t
 118                (parse-instruction/literal-element node))))
 119            (parent (stp:parent node)))
 120        (if (and (equal (stp:base-uri node) (stp:base-uri parent))
 121                 (equal (stp:namespace-uri parent) *xsl*)
 122                 (find-symbol (stp:local-name parent) :xuriella))
 123            expr
 124            `(xsl:with-base-uri ,(stp:base-uri node)
 125               ,expr))))
 126     (stp:text
 127      `(xsl:text ,(stp:data node)))))
 128
 129 (defun parse-instruction/literal-element (node)
 130   (let ((le
 131          `(xsl:literal-element
 132               (,(stp:local-name node)
 133                 ,(stp:namespace-uri node)
 134                 ,(stp:namespace-prefix node))
 135             (xsl:use-attribute-sets
 136              ,(stp:attribute-value node "use-attribute-sets" *xsl*))
 137             ,@(loop
 138                  for a in (stp:list-attributes node)
 139                  for xslp = (equal (stp:namespace-uri a) *xsl*)
 140                  when xslp
 141                  do (unless (find (stp:local-name a)
 142                                   '("version"
 143                                     "extension-element-prefixes"
 144                                     "exclude-result-prefixes"
 145                                     "use-attribute-sets")
 146                                   :test #'equal)
 147                       (xslt-error
 148                        "unknown attribute on literal result element: ~A"
 149                        (stp:local-name a)))
 150                  else
 151                  collect `(xsl:literal-attribute
 152                               (,(stp:local-name a)
 153                                 ,(stp:namespace-uri a)
 154                                 ,(stp:namespace-prefix a))
 155                             ,(stp:value a)))
 156             ,@(parse-body node)))
 157         (version (stp:attribute-value node "version" *xsl*))
 158         (extensions '()))
 159     (stp:with-attributes ((eep "extension-element-prefixes" *xsl*))
 160         node
 161       (dolist (prefix (words (or eep "")))
 162         (when (equal prefix "#default")
 163           (setf prefix nil))
 164         (push (or (stp:find-namespace prefix node)
 165                   (xslt-error "namespace not found: ~A" prefix))
 166               extensions)))
 167     (when extensions
 168       (setf le
 169             `(xsl:with-extension-namespaces ,extensions
 170                (xsl:with-excluded-namespaces ,extensions
 171                  ,le))))
 172     (when version
 173       (setf le
 174             `(xsl:with-version ,version
 175                ,le)))
 176     le))
 177
 178 (defun parse-fallback-children (node)
 179   (let ((fallbacks
 180          (loop
 181             for fallback in (stp:filter-children (of-name "fallback") node)
 182             append (parse-body fallback))))
 183     (if fallbacks
 184         `(progn ,@fallbacks)
 185         `(xsl:terminate
 186            (xsl:text
 187             "no fallback children in unknown element using forwards compatible processing")))))
 188
 189 (defmacro define-instruction-parser (name (node-var) &body body)
 190   `(progn
 191      (setf (gethash ,(symbol-name name) *available-instructions*) t)
 192      (defmethod parse-instruction/xsl-element
 193          ((.name. (eql ',name)) ,node-var)
 194        (declare (ignore .name.))
 195        ,@body)))
 196
 197 (define-instruction-parser |fallback| (node)
 198   (only-with-attributes () node
 199     '(progn)))
 200
 201 (define-instruction-parser |apply-templates| (node)
 202   (only-with-attributes (select mode) node
 203     (multiple-value-bind (decls rest)
 204         (loop
 205            for i from 0
 206            for cons on (stp:filter-children
 207                         (lambda (node)
 208                           (or (typep node 'stp:element)
 209                               (xslt-error "non-element in apply-templates")))
 210                         node)
 211            for (child . nil) = cons
 212            while (namep child "sort")
 213            collect (parse-sort child) into decls
 214            finally (return (values decls cons)))
 215       `(xsl:apply-templates
 216            (:select ,select :mode ,mode)
 217          (declare ,@decls)
 218          ,@(mapcar (lambda (clause)
 219                      (unless (namep clause "with-param")
 220                        (xslt-error "undefined instruction: ~A"
 221                                    (stp:local-name clause)))
 222                      (parse-param clause))
 223                    rest)))))
 224
 225 (define-instruction-parser |apply-imports| (node)
 226   `(xsl:apply-imports))
 227
 228 (define-instruction-parser |call-template| (node)
 229   (only-with-attributes (name) node
 230       `(xsl:call-template
 231         ,name ,@(stp:map-children 'list
 232                                   (lambda (clause)
 233                                     (if (namep clause "with-param")
 234                                         (parse-param clause)
 235                                         (xslt-error "undefined instruction: ~A"
 236                                                     (stp:local-name clause))))
 237                                   node))))
 238
 239 (define-instruction-parser |if| (node)
 240   (only-with-attributes (test) node
 241     `(when ,test
 242        ,@(parse-body node))))
 243
 244 (define-instruction-parser |choose| (node)
 245   (only-with-attributes () node
 246     `(cond
 247        ,@(stp:map-children 'list
 248                            (lambda (clause)
 249                              (cond
 250                                ((namep clause "when")
 251                                 (only-with-attributes (test) clause
 252                                   `(,test
 253                                     ,@(parse-body clause))))
 254                                ((namep clause "otherwise")
 255                                 `(t ,@(parse-body clause)))
 256                                (t
 257                                 (xslt-error "invalid <choose> clause: ~A"
 258                                             (stp:local-name clause)))))
 259                            node))))
 260
 261 (define-instruction-parser |element| (node)
 262   (only-with-attributes (name namespace use-attribute-sets) node
 263     `(xsl:element (,name :namespace ,namespace)
 264        (xsl:use-attribute-sets ,use-attribute-sets)
 265        ,@(parse-body node))))
 266
 267 (define-instruction-parser |attribute| (node)
 268   (only-with-attributes (name namespace) node
 269     `(xsl:attribute (,name :namespace ,namespace)
 270        ,@(parse-body node))))
 271
 272 (define-instruction-parser |text| (node)
 273   (only-with-attributes (select disable-output-escaping) node
 274     (if (equal disable-output-escaping "yes")
 275         `(xsl:unescaped-text ,(stp:string-value node))
 276         `(xsl:text ,(stp:string-value node)))))
 277
 278 (define-instruction-parser |comment| (node)
 279   (only-with-attributes () node
 280     `(xsl:comment ,@(parse-body node))))
 281
 282 (define-instruction-parser |processing-instruction| (node)
 283   (only-with-attributes (name) node
 284     `(xsl:processing-instruction ,name
 285        ,@(parse-body node))))
 286
 287 (define-instruction-parser |value-of| (node)
 288   (only-with-attributes (select disable-output-escaping) node
 289     (if (equal disable-output-escaping "yes")
 290         `(xsl:unescaped-value-of ,select)
 291         `(xsl:value-of ,select))))
 292
 293 (define-instruction-parser |copy-of| (node)
 294   (only-with-attributes (select) node
 295     `(xsl:copy-of ,select)))
 296
 297 (define-instruction-parser |copy| (node)
 298   (only-with-attributes (use-attribute-sets) node
 299     `(xsl:copy
 300       (xsl:use-attribute-sets ,use-attribute-sets)
 301       ,@(parse-body node))))
 302
 303 (define-instruction-parser |variable| (node)
 304   (xslt-error "unhandled xsl:variable"))
 305
 306 (define-instruction-parser |for-each| (node)
 307   (only-with-attributes (select) node
 308     (multiple-value-bind (decls body-position)
 309         (loop
 310            for i from 0
 311            for child in (stp:list-children node)
 312            while (namep child "sort")
 313            collect (parse-sort child) into decls
 314            finally (return (values decls i)))
 315       `(xsl:for-each ,select
 316          (declare ,@decls)
 317          ,@(parse-body node body-position)))))
 318
 319 (defun parse-sort (node)
 320   (only-with-attributes (select lang data-type order case-order) node
 321     `(sort :select ,select
 322            :lang ,lang
 323            :data-type ,data-type
 324            :order ,order
 325            :case-order ,case-order)))
 326
 327 (define-instruction-parser |message| (node)
 328   (only-with-attributes (terminate) node
 329     (if (equal terminate "yes")
 330         `(xsl:terminate ,@(parse-body node))
 331         `(xsl:message ,@(parse-body node)))))
 332
 333 (define-instruction-parser |number| (node)
 334   (only-with-attributes (level count from value format lang letter-value
 335                                    grouping-separator grouping-size)
 336       node
 337     `(xsl:number :level ,level
 338                  :count ,count
 339                  :from ,from
 340                  :value ,value
 341                  :format ,format
 342                  :lang ,lang
 343                  :letter-value ,letter-value
 344                  :grouping-separator ,grouping-separator
 345                  :grouping-size ,grouping-size)))
 346
 347 (define-instruction-parser |document| (node)
 348   (only-with-attributes
 349    (href method indent doctype-public doctype-system) node
 350     `(xsl:document (,href :method ,method
 351                           :indent ,indent
 352                           :doctype-public ,doctype-public
 353                           :doctype-system ,doctype-system)
 354        ,@(parse-body node))))