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 &optional include-redeclared)
  33   (let ((parent (stp:parent element)))
  34     (maphash (lambda (prefix uri)
  35                (unless (and (not include-redeclared)
  36                             (typep parent 'stp:element)
  37                             (equal (stp:find-namespace prefix parent) uri))
  38                  (funcall fn prefix uri)))
  39              (cxml-stp-impl::collect-local-namespaces element))))
  40
  41 (defun maybe-wrap-namespaces (child exprs)
  42   (if (typep child 'stp:element)
  43       (let ((bindings '())
  44             (excluded-uris '()))
  45         (map-namespace-declarations (lambda (prefix uri)
  46                                       (push (list prefix uri) bindings))
  47                                     child)
  48         (stp:with-attributes ((erp "exclude-result-prefixes" *xsl*))
  49             child
  50           (dolist (prefix (words (or erp "")))
  51             (when (equal prefix "#default")
  52               (setf prefix nil))
  53             (push (or (stp:find-namespace prefix child)
  54                       (xslt-error "namespace not found: ~A" prefix))
  55                   excluded-uris)))
  56         (if (or bindings excluded-uris)
  57             `((xsl:with-namespaces ,bindings
  58                 (xsl:with-excluded-namespaces ,excluded-uris
  59                   ,@exprs)))
  60             exprs))
  61       exprs))
  62
  63 (defun parse-body (node &optional (start 0) (param-names '()))
  64   "@arg[node]{A node representing part of a stylesheet.}
  65    @arg[start]{An optional integer, defaulting to 0.}
  66    @arg[param-names]{Undocumented.}
  67    @return{An list of XSLT instructions in sexp syntax}
  68
  69    @short{Parses the children of an XSLT instruction.}
  70
  71    This function is for use in XSLT extensions.  When defining an
  72    extension using @fun{define-extension-parser}, it can be used
  73    to parse the children of the extension node using regular XSLT syntax
  74    recursively.
  75
  76    Specify @code{start} to skip the first @code{start} child nodes."
  77   (let ((n (stp:count-children-if #'identity node)))
  78     (labels ((recurse (i)
  79                (when (< i n)
  80                  (let ((child (stp:nth-child i node)))
  81                    (if (namep child "variable")
  82                        (maybe-wrap-namespaces
  83                         child
  84                         (only-with-attributes (name select) child
  85                           (when (and select (stp:list-children child))
  86                             (xslt-error "variable with select and body"))
  87                           `((let ((,name ,(or select
  88                                               `(progn ,@(parse-body child)))))
  89                               (xsl:with-duplicates-check (,name)
  90                                 ,@(recurse (1+ i)))))))
  91                        (append (maybe-wrap-namespaces
  92                                 child
  93                                 (list (parse-instruction child)))
  94                                (recurse (1+ i))))))))
  95       (let ((result (recurse start)))
  96         (if param-names
  97             `((xsl:with-duplicates-check (,@param-names)
  98                 ,@result))
  99             result)))))
 100
 101 (defun parse-param (node)
 102   ;; FIXME: empty body?
 103   (only-with-attributes (name select) node
 104     (unless name
 105       (xslt-error "name not specified for parameter"))
 106     (when (and select (stp:list-children node))
 107       (xslt-error "param with select and body"))
 108     (list name
 109           (or select
 110               `(progn ,@(parse-body node))))))
 111
 112 (defun parse-instruction (node)
 113   (typecase node
 114     (stp:element
 115      (let ((expr
 116             (cond
 117               ((equal (stp:namespace-uri node) *xsl*)
 118                (let ((sym (find-symbol (stp:local-name node) :xuriella)))
 119                  (cond
 120                    (sym
 121                     (parse-instruction/xsl-element sym node))
 122                    (*forwards-compatible-p*
 123                     (parse-fallback-children node))
 124                    (t
 125                     (xslt-error "undefined instruction: ~A"
 126                                 (stp:local-name node))))))
 127               ((find (stp:namespace-uri node)
 128                      *extension-namespaces*
 129                      :test #'equal)
 130                (let ((extension (find-extension-element
 131                                  (stp:local-name node)
 132                                  (stp:namespace-uri node))))
 133                  (if extension
 134                      (funcall (extension-element-parser extension) node)
 135                      (parse-fallback-children node))))
 136               (t
 137                (parse-instruction/literal-element node))))
 138            (parent (stp:parent node)))
 139        (if (and (equal (stp:base-uri node) (stp:base-uri parent))
 140                 (equal (stp:namespace-uri parent) *xsl*)
 141                 (find-symbol (stp:local-name parent) :xuriella))
 142            expr
 143            `(xsl:with-base-uri ,(stp:base-uri node)
 144               ,expr))))
 145     (stp:text
 146      `(xsl:text ,(stp:data node)))))
 147
 148 (defun parse-instruction/literal-element (node)
 149   (let ((extensions '()))
 150     (stp:with-attributes ((eep "extension-element-prefixes" *xsl*))
 151         node
 152       (dolist (prefix (words (or eep "")))
 153         (when (equal prefix "#default")
 154           (setf prefix nil))
 155         (push (or (stp:find-namespace prefix node)
 156                   (xslt-error "namespace not found: ~A" prefix))
 157               extensions)))
 158     (if (find (stp:namespace-uri node) extensions :test #'equal)
 159         ;; oops, this isn't a literal result element after all
 160         (parse-fallback-children node)
 161         (let ((le
 162                `(xsl:literal-element
 163                     (,(stp:local-name node)
 164                       ,(stp:namespace-uri node)
 165                       ,(stp:namespace-prefix node))
 166                   (xsl:use-attribute-sets
 167                    ,(stp:attribute-value node "use-attribute-sets" *xsl*))
 168                   ,@(loop
 169                        for a in (stp:list-attributes node)
 170                        for xslp = (equal (stp:namespace-uri a) *xsl*)
 171                        when xslp
 172                        do (unless (find (stp:local-name a)
 173                                         '("version"
 174                                           "extension-element-prefixes"
 175                                           "exclude-result-prefixes"
 176                                           "use-attribute-sets")
 177                                         :test #'equal)
 178                             (xslt-error
 179                              "unknown attribute on literal result element: ~A"
 180                              (stp:local-name a)))
 181                        else
 182                        collect `(xsl:literal-attribute
 183                                     (,(stp:local-name a)
 184                                       ,(stp:namespace-uri a)
 185                                       ,(stp:namespace-prefix a))
 186                                   ,(stp:value a)))
 187                   ,@ (let ((*extension-namespaces*
 188                             (append extensions *extension-namespaces*)))
 189                        (parse-body node))))
 190               (version (stp:attribute-value node "version" *xsl*)))
 191           (when extensions
 192             (setf le
 193                   `(xsl:with-extension-namespaces ,extensions
 194                      (xsl:with-excluded-namespaces ,extensions
 195                        ,le))))
 196           (when version
 197             (setf le
 198                   `(xsl:with-version ,version
 199                      ,le)))
 200           le))))
 201
 202 (defun parse-fallback-children (node)
 203   (let ((fallbacks
 204          (loop
 205             for fallback in (stp:filter-children (of-name "fallback") node)
 206             do (only-with-attributes () fallback)
 207             append (parse-body fallback))))
 208     (if fallbacks
 209         `(progn ,@fallbacks)
 210         `(xsl:terminate
 211            (xsl:text
 212             ,(format nil "no fallback children in unknown element ~A/~A using forwards compatible processing"
 213                      (stp:local-name node)
 214                      (stp:namespace-uri node)))))))
 215
 216 (defmacro define-instruction-parser (name (node-var) &body body)
 217   `(progn
 218      (setf (gethash ,(symbol-name name) *builtin-instructions*) t)
 219      (defmethod parse-instruction/xsl-element
 220          ((.name. (eql ',name)) ,node-var)
 221        (declare (ignore .name.))
 222        ,@body)))
 223
 224 (define-instruction-parser |fallback| (node)
 225   (only-with-attributes () node
 226     '(progn)))
 227
 228 (define-instruction-parser |apply-templates| (node)
 229   (only-with-attributes (select mode) node
 230     (multiple-value-bind (decls rest)
 231         (loop
 232            for i from 0
 233            for cons on (stp:filter-children
 234                         (lambda (node)
 235                           (or (typep node 'stp:element)
 236                               (xslt-error "non-element in apply-templates")))
 237                         node)
 238            for (child . nil) = cons
 239            while (namep child "sort")
 240            collect (parse-sort child) into decls
 241            finally (return (values decls cons)))
 242       `(xsl:apply-templates
 243            (:select ,select :mode ,mode)
 244          (declare ,@decls)
 245          ,@(mapcar (lambda (clause)
 246                      (unless (namep clause "with-param")
 247                        (xslt-error "undefined instruction: ~A"
 248                                    (stp:local-name clause)))
 249                      (parse-param clause))
 250                    rest)))))
 251
 252 (define-instruction-parser |apply-imports| (node)
 253   (only-with-attributes () node)
 254   (assert-no-body node)
 255   `(xsl:apply-imports))
 256
 257 (define-instruction-parser |call-template| (node)
 258   (only-with-attributes (name) node
 259       `(xsl:call-template
 260         ,name ,@(stp:map-children 'list
 261                                   (lambda (clause)
 262                                     (if (namep clause "with-param")
 263                                         (parse-param clause)
 264                                         (xslt-error "undefined instruction: ~A"
 265                                                     (stp:local-name clause))))
 266                                   node))))
 267
 268 (define-instruction-parser |if| (node)
 269   (only-with-attributes (test) node
 270     `(when ,test
 271        ,@(parse-body node))))
 272
 273 (define-instruction-parser |choose| (node)
 274   (let ((whenp nil))
 275     (prog1
 276         (only-with-attributes () node
 277           `(cond
 278              ,@(stp:map-children 'list
 279                                  (lambda (clause)
 280                                    (cond
 281                                      ((namep clause "when")
 282                                       (setf whenp t)
 283                                       (only-with-attributes (test) clause
 284                                         `(,test
 285                                           ,@(parse-body clause))))
 286                                      ((namep clause "otherwise")
 287                                       `(t ,@(parse-body clause)))
 288                                      (t
 289                                       (xslt-error "invalid <choose> clause: ~A"
 290                                                   (stp:local-name clause)))))
 291                                  node)))
 292       (unless whenp
 293         (xslt-error "<choose> without <when>")))))
 294
 295 (define-instruction-parser |element| (node)
 296   (only-with-attributes (name namespace use-attribute-sets) node
 297     `(xsl:element (,name :namespace ,namespace)
 298        (xsl:use-attribute-sets ,use-attribute-sets)
 299        ,@(parse-body node))))
 300
 301 (define-instruction-parser |attribute| (node)
 302   (only-with-attributes (name namespace) node
 303     `(xsl:attribute (,name :namespace ,namespace)
 304        ,@(parse-body node))))
 305
 306 (defun boolean-or-error (str)
 307   (cond
 308     ((equal str "yes")
 309      t)
 310     ((or (null str) (equal str "no"))
 311      nil)
 312     (t
 313      (xslt-error "not a boolean: ~A" str))))
 314
 315 (define-instruction-parser |text| (node)
 316   (only-with-attributes (select disable-output-escaping) node
 317     (when (xpath:evaluate "boolean(*)" node)
 318       (xslt-error "non-text found in xsl:text"))
 319     (if (boolean-or-error disable-output-escaping)
 320         `(xsl:unescaped-text ,(stp:string-value node))
 321         `(xsl:text ,(stp:string-value node)))))
 322
 323 (define-instruction-parser |comment| (node)
 324   (only-with-attributes () node
 325     `(xsl:comment ,@(parse-body node))))
 326
 327 (define-instruction-parser |processing-instruction| (node)
 328   (only-with-attributes (name) node
 329     `(xsl:processing-instruction ,name
 330        ,@(parse-body node))))
 331
 332 (defun assert-no-body (node)
 333   (when (stp:list-children node)
 334     (xslt-error "no child nodes expected in ~A" (stp:local-name node))))
 335
 336 (define-instruction-parser |value-of| (node)
 337   (only-with-attributes (select disable-output-escaping) node
 338     (assert-no-body node)
 339     (if (boolean-or-error disable-output-escaping)
 340         `(xsl:unescaped-value-of ,select)
 341         `(xsl:value-of ,select))))
 342
 343 (define-instruction-parser |copy-of| (node)
 344   (only-with-attributes (select) node
 345     (assert-no-body node)
 346     `(xsl:copy-of ,select)))
 347
 348 (define-instruction-parser |copy| (node)
 349   (only-with-attributes (use-attribute-sets) node
 350     `(xsl:copy
 351       (xsl:use-attribute-sets ,use-attribute-sets)
 352       ,@(parse-body node))))
 353
 354 (define-instruction-parser |variable| (node)
 355   (xslt-error "unhandled xsl:variable"))
 356
 357 (define-instruction-parser |for-each| (node)
 358   (only-with-attributes (select) node
 359     (multiple-value-bind (decls body-position)
 360         (loop
 361            for i from 0
 362            for child in (stp:list-children node)
 363            while (namep child "sort")
 364            collect (parse-sort child) into decls
 365            finally (return (values decls i)))
 366       `(xsl:for-each ,select
 367          (declare ,@decls)
 368          ,@(parse-body node body-position)))))
 369
 370 (defun parse-sort (node)
 371   (only-with-attributes (select lang data-type order case-order) node
 372     (assert-no-body node)
 373     `(sort :select ,select
 374            :lang ,lang
 375            :data-type ,data-type
 376            :order ,order
 377            :case-order ,case-order)))
 378
 379 (define-instruction-parser |message| (node)
 380   (only-with-attributes (terminate) node
 381     (if (boolean-or-error terminate)
 382         `(xsl:terminate ,@(parse-body node))
 383         `(xsl:message ,@(parse-body node)))))
 384
 385 (define-instruction-parser |number| (node)
 386   (only-with-attributes (level count from value format lang letter-value
 387                                    grouping-separator grouping-size)
 388       node
 389     (assert-no-body node)
 390     `(xsl:number :level ,level
 391                  :count ,count
 392                  :from ,from
 393                  :value ,value
 394                  :format ,format
 395                  :lang ,lang
 396                  :letter-value ,letter-value
 397                  :grouping-separator ,grouping-separator
 398                  :grouping-size ,grouping-size)))