space.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
  31 ;;; This file implements whitespace stripping.
  32 ;;;
  33 ;;; Although the spec presents a unified algorithm for whitespace stripping
  34 ;;; of stylesheets and source documents, we implement them separately.
  35 ;;;
  36 ;;; For stylesheets, the STP parse tree of the stylesheet is modified
  37 ;;; directly according the its xml:space declarations and xsl:text elements.
  38 ;;;
  39 ;;; For source documents, the strip-space and preserve-space declarations
  40 ;;; from the stylesheet are taken into account.  To avoid processing
  41 ;;; parts of the document that XPath would not otherwise have navigated
  42 ;;; to, we do whitespace stripping lazily using a proxy implementation
  43 ;;; of the XPath protocol.
  44
  45 (in-package :xuriella)
  46
  47 #+sbcl
  48 (declaim (optimize (debug 2)))
  49
  50
  51 ;;;; Helper functions
  52
  53 (eval-when (:compile-toplevel :load-toplevel :execute)
  54   (defparameter *whitespace*
  55     (format nil "~C~C~C~C"
  56             (code-char 9)
  57             (code-char 32)
  58             (code-char 13)
  59             (code-char 10))))
  60
  61 (defun normalize-whitespace (str)
  62   (cl-ppcre:regex-replace-all #.(format nil "[~A]+" *whitespace*)
  63                               (string-trim *whitespace* str)
  64                               " "))
  65
  66 (defun whitespacep (str)
  67   (cl-ppcre:all-matches #.(format nil "^[~A]+$" *whitespace*) str))
  68
  69 (defun words (str)
  70   (when str
  71     (cl-ppcre:split #.(format nil "[~A]+" *whitespace*)
  72                     (string-trim *whitespace* str))))
  73
  74
  75 ;;;; Strip whitespace in stylesheets
  76
  77 ;; Also strips comments and PIs.
  78 (defun strip-stylesheet (parent &optional preserve)
  79   (let ((i 0))
  80     (loop while (< i (length (cxml-stp-impl::%children parent))) do
  81          (let ((child (stp:nth-child i parent)))
  82            (etypecase child
  83              (stp:text
  84               (if (and (whitespacep (stp:data child))
  85                        (not preserve))
  86                   (stp:delete-nth-child i parent)
  87                   (incf i)))
  88              ((or stp:comment stp:processing-instruction)
  89               (stp:delete-nth-child i parent))
  90              (stp:element
  91                  (stp:with-attributes ((space "space" *xml*))
  92                      child
  93                    (let ((new-preserve
  94                           (cond
  95                             ((namep child "text") t)
  96                             ((not space) preserve)
  97                             ((equal space "preserve") t)
  98                             (t nil))))
  99                      (strip-stylesheet child new-preserve)))
 100                (incf i)))))))
 101
 102
 103 ;;;; Strip whitespace in source documents
 104
 105 (defun make-whitespace-stripper (node strip-thunk)
 106   (if strip-thunk
 107       (make-stripping-node nil node strip-thunk nil)
 108       node))
 109
 110 (defstruct (stripping-node (:constructor #:ignore))
 111   parent
 112   target
 113   children)
 114
 115 (defstruct (leaf-stripping-node
 116              (:constructor make-leaf-stripping-node (parent target))
 117              (:include stripping-node)))
 118
 119 (defstruct (parent-stripping-node
 120              (:constructor make-parent-stripping-node (parent target))
 121              (:include stripping-node)))
 122
 123 (defmethod print-object ((object stripping-node) stream)
 124   (print-unreadable-object (object stream :type t :identity nil)
 125     (let ((target (write-to-string (stripping-node-target object))))
 126       (if (and (alexandria:starts-with-subseq target "#<")
 127                (alexandria:ends-with #\> target))
 128           (write-sequence target stream :start 3 :end (1- (length target)))
 129           (write-sequence target stream)))))
 130
 131 (defun strip-under-qname-p (node strip-thunk)
 132   (let* ((strip-test
 133           (maximize #'strip-test-<
 134                     (xpattern:matching-values strip-thunk node))))
 135     (and strip-test
 136          (eq (strip-test-value strip-test) :strip))))
 137
 138 (defun strip-test-< (a b)
 139   (let ((i (strip-test-priority a))
 140         (j (strip-test-priority b)))
 141     (cond
 142       ((< i j) t)
 143       ((> i j) nil)
 144       (t
 145        (< (strip-test-position a)
 146           (strip-test-position b))))))
 147
 148 (defun xpath-protocol/attribute-value (node local-name uri)
 149   (do-pipe (a (xpath-protocol:attribute-pipe node))
 150     (when (and (equal (xpath-protocol:local-name a) local-name)
 151                (equal (xpath-protocol:namespace-uri a) uri))
 152       (return (xpath-protocol:node-text a)))))
 153
 154 (defun make-stripping-node (parent target strip-thunk force-preserve)
 155   (let ((result (make-parent-stripping-node parent target))
 156         (xml-space (xpath-protocol/attribute-value target "space" *xml*)))
 157     (when xml-space
 158       (setf force-preserve (equal xml-space "preserve")))
 159     (labels ((recurse (child-node)
 160                (if (xpath-protocol:node-type-p child-node :element)
 161                    (make-stripping-node result child-node strip-thunk force-preserve)
 162                    (make-leaf-stripping-node result child-node)))
 163              (maybe-recurse (child-node)
 164                (if (and (xpath-protocol:node-type-p child-node :text)
 165                         (whitespacep (xpath-protocol:node-text child-node)))
 166                    nil
 167                    (recurse child-node))))
 168       (let ((all-children (xpath-protocol:child-pipe target)))
 169         (setf (stripping-node-children result)
 170               (if (or force-preserve
 171                       (not (xpath-protocol:node-type-p target :element))
 172                       (not (strip-under-qname-p target strip-thunk)))
 173                   (xpath::map-pipe-filtering #'recurse all-children)
 174                   (xpath::map-pipe-filtering #'maybe-recurse all-children)))))
 175     result))
 176
 177 (macrolet ((defproxy (name &rest args)
 178              `(define-default-method ,name ((node stripping-node) ,@args)
 179                 (,name (stripping-node-target node) ,@args))))
 180   (defproxy xpath-protocol:local-name)
 181   (defproxy xpath-protocol:namespace-uri)
 182   (defproxy xpath-protocol:namespace-prefix)
 183   (defproxy xpath-protocol:qualified-name)
 184   (defproxy xpath-protocol:node-type-p type))
 185
 186 (define-default-method xpath-protocol:node-equal
 187     ((a stripping-node) (b stripping-node))
 188   (xpath-protocol:node-equal (stripping-node-target a)
 189                              (stripping-node-target b)))
 190
 191 (define-default-method xpath-protocol:hash-key ((node stripping-node))
 192   (xpath-protocol:hash-key (stripping-node-target node)))
 193
 194 (define-default-method xpath-protocol:attribute-pipe ((node stripping-node))
 195   (xpath::map-pipe (lambda (attribute)
 196                      (make-leaf-stripping-node node attribute))
 197                    (xpath-protocol:attribute-pipe
 198                     (stripping-node-target node))))
 199
 200 (define-default-method xpath-protocol:namespace-pipe ((node stripping-node))
 201   (xpath::map-pipe (lambda (namespace)
 202                      (make-leaf-stripping-node node namespace))
 203                    (xpath-protocol:namespace-pipe
 204                     (stripping-node-target node))))
 205
 206 (define-default-method xpath-protocol:node-p ((node stripping-node))
 207   t)
 208
 209 (define-default-method xpath-protocol:child-pipe ((node stripping-node))
 210   (stripping-node-children node))
 211
 212 (define-default-method xpath-protocol:parent-node ((node stripping-node))
 213   (stripping-node-parent node))
 214
 215 (define-default-method xpath-protocol:node-text ((node stripping-node))
 216   (with-output-to-string (s)
 217     (write-string-value node s)))
 218
 219 (defmethod write-string-value ((node parent-stripping-node) stream)
 220   (do-pipe (child (xpath-protocol:child-pipe node))
 221     (unless (or (xpath-protocol:node-type-p child :comment)
 222                 (xpath-protocol:node-type-p child :processing-instruction))
 223       (write-string-value child stream))))
 224
 225 (defmethod write-string-value ((node leaf-stripping-node) stream)
 226   (write-string-value (stripping-node-target node) stream))
 227
 228 (defmethod write-string-value (node stream)
 229   (write-string (xpath-protocol:node-text node) stream))
 230
 231 (define-default-method xpath-protocol:get-element-by-id
 232     ((node stripping-node) id)
 233   (let ((target
 234          (xpath-protocol:get-element-by-id (stripping-node-target node) id)))
 235     (when target
 236       (let ((stripping-root
 237              (loop
 238                 for parent = node then next
 239                 for next = (stripping-node-parent parent)
 240                 while next
 241                 finally (return parent)))
 242             (target-path nil))
 243         (loop
 244            for parent = target then next
 245            for next = (xpath-protocol:parent-node parent)
 246            while next
 247            do (push parent target-path))
 248         (labels ((find-child (stripping-parent target-child)
 249                    (xpath::find-in-pipe target-child
 250                                         (xpath-protocol:child-pipe
 251                                          stripping-parent)
 252                                         :key #'stripping-node-target))
 253                  (resolve-path (stripping-parent target-path)
 254                    (if target-path
 255                        (let ((step
 256                               (find-child stripping-parent (car target-path))))
 257                          (if step
 258                              (resolve-path step (cdr target-path))
 259                              nil))
 260                        stripping-parent)))
 261           (resolve-path stripping-root target-path))))))
 262
 263 (define-default-method xpath-protocol:unparsed-entity-uri
 264     ((node stripping-node) name)
 265   (xpath-protocol:unparsed-entity-uri (stripping-node-target node) name))
 266
 267
 268 ;;;; TEXT NORMALIZER, from cxml-rng
 269
 270 ;;; FIXME: cxml should do that
 271
 272 (defun make-text-normalizer (next)
 273   (make-instance 'text-normalizer :chained-handler next))
 274
 275 (defclass text-normalizer (cxml:sax-proxy)
 276   ((pending-text-node :initform (make-string-output-stream)
 277                       :accessor pending-text-node)))
 278
 279 (defmethod sax:characters ((handler text-normalizer) data)
 280   (write-string data (pending-text-node handler)))
 281
 282 (defun flush-pending (handler)
 283   (let ((str (get-output-stream-string (pending-text-node handler))))
 284     (unless (zerop (length str))
 285       (sax:characters (cxml:proxy-chained-handler handler) str))))
 286
 287 (defmethod sax:start-element :before
 288     ((handler text-normalizer) uri lname qname attributes)
 289   (declare (ignore uri lname qname attributes))
 290   (flush-pending handler))
 291
 292 (defmethod sax:end-element :before
 293     ((handler text-normalizer) uri lname qname)
 294   (declare (ignore uri lname qname))
 295   (flush-pending handler))