xslt.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 #+sbcl
  32 (declaim (optimize (debug 2)))
  33
  34
  35 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
  36
  37 (defparameter *namespaces*
  38   '((nil . "")
  39     ("xmlns" . #"http://www.w3.org/2000/xmlns/")
  40     ("xml" . #"http://www.w3.org/XML/1998/namespace")))
  41 (defparameter *variable-declarations* '())
  42
  43 (defclass xslt-environment () ())
  44
  45 (defun make-xslt-environment ()
  46   (make-instance 'xslt-environment))
  47
  48 (defun decode-qname (qname env attributep)
  49   (multiple-value-bind (prefix local-name)
  50       (cxml::split-qname qname)
  51     (values local-name
  52             (if (or prefix (not attributep))
  53                 (xpath:environment-find-namespace env prefix)
  54                 ""))))
  55
  56 (defmethod xpath:environment-find-namespace ((env xslt-environment) prefix)
  57   (cdr (assoc prefix *namespaces* :test 'equal)))
  58
  59 (defmethod xpath:environment-find-variable
  60     ((env xslt-environment) lname uri)
  61   (cdr (assoc (cons lname uri) *variable-declarations* :test 'equal)))
  62
  63
  64 ;;;; TEXT-OUTPUT-SINK
  65 ;;;;
  66 ;;;; A sink that serializes only text and will error out on any other
  67 ;;;; SAX event.
  68
  69 (defmacro with-text-output-sink ((var) &body body)
  70   `(invoke-with-text-output-sink (lambda (,var) ,@body)))
  71
  72 (defclass text-output-sink (sax:content-handler)
  73   ((target :initarg :target :accessor text-output-sink-target)))
  74
  75 (defmethod sax:characters ((sink text-output-sink) data)
  76   (write-string data (text-output-sink-target sink)))
  77
  78 (defun invoke-with-text-output-sink (fn)
  79   (with-output-to-string (s)
  80     (funcall fn (make-instance 'text-output-sink :target s))))
  81
  82
  83 ;;;; Names
  84
  85 (defvar *xsl* "http://www.w3.org/1999/XSL/Transform")
  86 (defvar *xml* "http://www.w3.org/XML/1998/namespace")
  87
  88 (defun of-name (local-name)
  89   (stp:of-name local-name *xsl*))
  90
  91 (defun namep (node local-name)
  92   (and (typep node '(or stp:element stp:attribute))
  93        (equal (stp:namespace-uri node) *xsl*)
  94        (equal (stp:local-name node) local-name)))
  95
  96
  97 ;;;; Whitespace
  98
  99 (eval-when (:compile-toplevel :load-toplevel :execute)
 100   (defparameter *whitespace*
 101     (format nil "~C~C~C~C"
 102             (code-char 9)
 103             (code-char 32)
 104             (code-char 13)
 105             (code-char 10))))
 106
 107 (defun normalize-whitespace (str)
 108   (cl-ppcre:regex-replace-all #.(format nil "[~A]+" *whitespace*)
 109                               (string-trim *whitespace* str)
 110                               " "))
 111
 112 (defun whitespacep (str)
 113   (cl-ppcre:all-matches #.(format nil "^[~A]+$" *whitespace*) str))
 114
 115 ;; For stylesheets, not source documents.  Also strips comments and PIs.
 116 (defun strip-stylesheet (parent &optional preserve)
 117   (let ((i 0))
 118     (loop while (< i (length (cxml-stp-impl::%children parent))) do
 119          (let ((child (stp:nth-child i parent)))
 120            (etypecase child
 121              (stp:text
 122               (if (and (whitespacep (stp:data child))
 123                        (not preserve))
 124                   (stp:delete-nth-child i parent)
 125                   (incf i)))
 126              ((or stp:comment stp:processing-instruction)
 127               (stp:delete-nth-child i parent))
 128              (stp:element
 129                  (stp:with-attributes ((space "space" *xml*))
 130                      child
 131                    (let ((new-preserve
 132                           (cond
 133                             ((namep child "text") t)
 134                             ((not space) preserve)
 135                             ((equal space "preserve") t)
 136                             (t nil))))
 137                      (strip-stylesheet child new-preserve)))
 138                (incf i)))))))
 139
 140
 141 ;;;; PARSE-STYLESHEET
 142
 143 (defstruct stylesheet
 144   (modes (make-hash-table :test 'equal))
 145   (html-output-p nil))
 146
 147 (defstruct mode
 148   (named-templates (make-hash-table :test 'equal))
 149   (other-templates nil))
 150
 151 (defun find-mode (mode stylesheet)
 152   (gethash mode (stylesheet-modes stylesheet)))
 153
 154 (defun ensure-mode (mode stylesheet)
 155   (or (find-mode mode stylesheet)
 156       (setf (gethash mode (stylesheet-modes stylesheet))
 157             (make-mode))))
 158
 159 (defun parse-stylesheet (d)
 160   ;; FIXME: I was originally planning on rewriting this using klacks
 161   ;; eventually, but now let's just build an STP document
 162   (let* ((d (cxml:parse d (cxml-stp:make-builder)))
 163          (<transform> (stp:document-element d))
 164          (stylesheet (make-stylesheet))
 165          (env (make-xslt-environment)))
 166     (strip-stylesheet <transform>)
 167     ;; FIXME: handle embedded stylesheets
 168     (unless (and (equal (stp:namespace-uri <transform>) *xsl*)
 169                  (or (equal (stp:local-name <transform>) "transform")
 170                      (equal (stp:local-name <transform>) "stylesheet")))
 171       (error "not a stylesheet"))
 172     (ensure-mode "" stylesheet)
 173     (dolist (<template> (stp:filter-children (of-name "template") <transform>))
 174       (dolist (template (compile-template <template> env))
 175         (let ((mode (ensure-mode (template-mode template) stylesheet))
 176               (name-test (template-qname-test template)))
 177           (if name-test
 178               (multiple-value-bind (local-name uri)
 179                   (decode-qname name-test env nil)
 180                 (push template
 181                       (gethash (cons local-name uri)
 182                                (mode-named-templates mode))))
 183               (push template (mode-other-templates mode))))))
 184     stylesheet))
 185
 186
 187 ;;;; APPLY-STYLESHEET
 188
 189 (defvar *mode*)
 190
 191 (deftype xml-designator () '(or runes:xstream runes:rod array stream pathname))
 192
 193 (defun apply-stylesheet (stylesheet source-document &optional output-spec)
 194   (when (typep stylesheet 'xml-designator)
 195     (setf stylesheet (parse-stylesheet stylesheet)))
 196   (when (typep source-document 'xml-designator)
 197     (setf source-document (cxml:parse source-document (stp:make-builder))))
 198   (invoke-with-output-sink
 199    (lambda ()
 200      (let ((*mode* (find-mode "" stylesheet)))
 201        (apply-templates (xpath:make-context source-document))))
 202    stylesheet
 203    output-spec))
 204
 205 (defun apply-templates/list (list)
 206   (let* ((n (length list))
 207          (s/d (lambda () n)))
 208     (loop
 209        for i from 1
 210        for child in list
 211        do
 212          (apply-templates (xpath:make-context child s/d i)))))
 213
 214 (defun apply-templates (ctx)
 215   (let ((template (find-template ctx)))
 216     (if template
 217         (funcall (template-body template) ctx)
 218         (let ((node (xpath:context-node ctx)))
 219           (cond
 220             ((or (xpath-protocol:node-type-p node :processing-instruction)
 221                  (xpath-protocol:node-type-p node :comment)))
 222             ((xpath-protocol:node-type-p node :text)
 223              (cxml:text (xpath-protocol:string-value node)))
 224             (t
 225              (apply-templates/list
 226               (xpath::force
 227                (xpath-protocol:child-pipe node)))))))))
 228
 229 (defun find-template (ctx)
 230   (let* ((node
 231           (xpath:context-node ctx))
 232          (key
 233           (when (xpath-protocol:node-type-p node :element)
 234             (cons (xpath-protocol:local-name node)
 235                   (xpath-protocol:namespace-uri node))))
 236          (templates
 237           (append (and key (gethash key (mode-named-templates *mode*)))
 238                   (mode-other-templates *mode*)))
 239          (matching-candidates
 240           (remove-if-not (lambda (template)
 241                            (template-matches-p template ctx))
 242                          templates)))
 243     (maximize #'template< matching-candidates)))
 244
 245 (defun template< (a b)
 246   (let ((i (template-import-precedence a))
 247         (j (template-import-precedence b))
 248         (p (template-priority a))
 249         (q (template-priority b)))
 250     (cond
 251       ((< i j) t)
 252       ((> i j) nil)
 253       (t
 254        (cond
 255          ((< p q) t)
 256          ((> p q) nil)
 257          (t
 258           (error "conflicting templates: ~A, ~A" a b)))))))
 259
 260 (defun maximize (< things)
 261   (when things
 262     (let ((max (car things)))
 263       (dolist (other (cdr things))
 264         (when (funcall < max other)
 265           (setf max other)))
 266       max)))
 267
 268 (defun template-matches-p (template ctx)
 269   (find (xpath:context-node ctx)
 270         (xpath:all-nodes (funcall (template-match-thunk template) ctx))))
 271
 272 (defun invoke-with-output-sink (fn stylesheet output)
 273   (etypecase output
 274     (pathname
 275      (with-open-file (s output
 276                         :direction :output
 277                         :element-type '(unsigned-byte 8)
 278                         :if-exists :rename-and-delete)
 279        (invoke-with-output-sink fn stylesheet s)))
 280     ((or stream null)
 281      (cxml:with-xml-output (make-output-sink stylesheet output)
 282        (funcall fn)))
 283     ((or hax:abstract-handler sax:abstract-handler)
 284      (cxml:with-xml-output output
 285        (funcall fn)))))
 286
 287 (defun make-output-sink (stylesheet stream)
 288   (if (stylesheet-html-output-p stylesheet)
 289       (if stream
 290           (let ((et (stream-element-type stream)))
 291             (cond
 292               ((or (null et) (subtypep et '(unsigned-byte 8)))
 293                (chtml:make-character-stream-sink stream))
 294               ((subtypep et 'character)
 295                (chtml:make-octet-stream-sink stream))))
 296           (chtml:make-string-sink))
 297       (if stream
 298           (let ((et (stream-element-type stream)))
 299             (cond
 300               ((or (null et) (subtypep et '(unsigned-byte 8)))
 301                (cxml:make-character-stream-sink stream))
 302               ((subtypep et 'character)
 303                (cxml:make-octet-stream-sink stream))))
 304           (cxml:make-string-sink))))
 305
 306 (defstruct template
 307   match-expression
 308   match-thunk
 309   name
 310   priority
 311   mode
 312   body)
 313
 314 (defun template-import-precedence (template)
 315   template
 316   ;; fixme
 317   0)
 318
 319 (defun template-qname-test (template)
 320   (let* ((form (template-match-expression template))
 321          (first-step (second form)))
 322     (when (and (null (cddr form))
 323                (eq :child (car first-step)))
 324       (second first-step))))
 325
 326 (defun expression-priority (form)
 327   (let ((first-step (second form)))
 328     (if (and (null (cddr form))
 329              (eq :child (car first-step))
 330              (null (cddr first-step)))
 331         (let ((name (second first-step)))
 332           (cond
 333             ((or (stringp name)
 334                  (eq (car name) :qname)
 335                  (eq (car name) :processing-instruction))
 336              0.0)
 337             ((eq (car name) :namespace)
 338              -0.25)
 339             (t
 340              -0.5)))
 341         0.5)))
 342
 343 (defun parse-pattern (str)
 344   ;; zzz check here for anything not allowed as an XSLT pattern
 345   ;; zzz can we hack id() and key() here?
 346   (let ((form (xpath:parse-xpath str)))
 347     (unless (consp form)
 348       (error "not a valid pattern: ~A" str))
 349     (mapcar (lambda (case)
 350               (unless (eq (car case) :path) ;zzz: filter statt path
 351                 (error "not a valid pattern: ~A" str))
 352               `(:path (:ancestor-or-self :node) ,@(cdr case)))
 353             (if (eq (car form) :union)
 354                 (cdr form)
 355                 (list form)))))
 356
 357 (defun compile-template (<template> env)
 358   (stp:with-attributes (match name priority mode) <template>
 359     (unless (or name match)
 360       (error "missing match in template"))
 361     (let ((body (parse-body <template>)))
 362       (mapcar (lambda (expression)
 363                 (let ((body-thunk
 364                        (compile-instruction `(progn ,@body) env))
 365                       (match-thunk
 366                        (xpath:compile-xpath `(xpath:xpath ,expression) env))
 367                       (p (if priority
 368                              (parse-number:parse-number priority)
 369                              (expression-priority expression))))
 370                   (make-template :match-expression expression
 371                                  :match-thunk match-thunk
 372                                  :name name
 373                                  :priority p
 374                                  :mode (or mode "")
 375                                  :body body-thunk)))
 376               (parse-pattern match)))))
 377
 378 #+(or)
 379 (xuriella::parse-stylesheet #p"/home/david/src/lisp/xuriella/test.xsl")