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