xml-binding.lisp

   1 ;;;;
   2 ;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
   3 ;;;;
   4 ;;;; Redistribution and use in source and binary forms, with or without
   5 ;;;; modification, are permitted provided that the following conditions
   6 ;;;; are met:
   7 ;;;;
   8 ;;;;   * Redistributions of source code must retain the above copyright
   9 ;;;;     notice, this list of conditions and the following disclaimer.
  10 ;;;;
  11 ;;;;   * Redistributions in binary form must reproduce the above
  12 ;;;;     copyright notice, this list of conditions and the following
  13 ;;;;     disclaimer in the documentation and/or other materials
  14 ;;;;     provided with the distribution.
  15 ;;;;
  16 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  17 ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18 ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  19 ;;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  20 ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  21 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  22 ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  23 ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  25 ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  26 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27 ;;;;
  28 ;;;; xml-binding.lisp
  29
  30 (in-package #:zs3)
  31
  32 ;;; utility
  33
  34 (defun skip-document-start (source)
  35   (let ((type (klacks:peek source)))
  36     (when (eql :start-document type)
  37       (klacks:consume source))
  38     (values)))
  39
  40 (defun skip-characters (source)
  41   (loop
  42    (if (member (klacks:peek source) '(:characters :comment))
  43        (klacks:consume source)
  44        (return))))
  45
  46 (defun collect-characters (source)
  47   (with-output-to-string (stream)
  48     (loop
  49      (multiple-value-bind (type data)
  50          (klacks:peek source)
  51        (cond ((eql type :characters)
  52               (write-string data stream)
  53               (klacks:consume source))
  54              (t
  55               (return)))))))
  56
  57 (defun collect-rest-alist (source)
  58   "Collect the rest of SOURCE, up to an un-nested closing tag, as an
  59 alist of element names and their character contents."
  60   (let ((result '()))
  61     (loop
  62      (multiple-value-bind (type uri lname)
  63          (klacks:peek source)
  64        (declare (ignore uri))
  65        (ecase type
  66          (:characters (klacks:consume source))
  67          (:end-element
  68           (return (nreverse result)))
  69          (:start-element
  70           (klacks:consume source)
  71           (push (cons lname (collect-characters source)) result)
  72           (klacks:find-event source :end-element)
  73           (klacks:consume source)))))))
  74
  75 ;;; Match failure conditions
  76
  77 (define-condition xml-binding-error ()
  78   ((expected
  79     :initarg :expected
  80     :accessor expected)
  81    (actual
  82     :initarg :actual
  83     :accessor actual))
  84   (:report
  85    (lambda (condition stream)
  86      (format stream "Unexpected XML structure: expected ~S, got ~S instead"
  87              (expected condition)
  88              (actual condition)))))
  89
  90
  91 ;;; Creating the matchers/binders
  92
  93 (defvar *current-element-name*)
  94
  95 (defun create-element-start-matcher (element-name kk)
  96   "Return a function that expects to see the start of ELEMENT-NAME
  97 next in SOURCE."
  98   (lambda (source bindings k)
  99     (skip-characters source)
 100     (multiple-value-bind (type uri lname qname)
 101         (klacks:peek source)
 102       (declare (ignore uri qname))
 103       (when (not (eql type :start-element))
 104         (error 'xml-binding-error
 105                :expected (list :start-element element-name)
 106                :actual (list :event type)))
 107       (when (string/= element-name lname)
 108         (error 'xml-binding-error
 109                :expected (list :start-element element-name)
 110                :actual (list type lname)))
 111       (klacks:consume source)
 112       (funcall kk source bindings k))))
 113
 114 (defun create-element-end-matcher (element-name kk)
 115   "Return a function that expects to see the end of ELEMENT-NAME next in
 116 SOURCE."
 117   (lambda (source bindings k)
 118     (skip-characters source)
 119     (multiple-value-bind (type uri lname qname)
 120         (klacks:peek source)
 121       (declare (ignore uri qname))
 122       (when (not (eql type :end-element))
 123         (error 'xml-binding-error
 124                :expected (list :end-element element-name)
 125                :actual (list :event type lname)))
 126       (when (string/= element-name lname)
 127         (error 'xml-binding-error
 128                :expected (list :end-element element-name)
 129                :actual (list type lname)))
 130       (klacks:consume source)
 131       (funcall kk source bindings k))))
 132
 133 (defun create-bindings-extender (key kk)
 134   "Return a function that extends BINDINGS with KEY and a value of
 135 whatever character data is pending in SOURCE."
 136   (lambda (source bindings k)
 137     (funcall kk source
 138              (acons key (collect-characters source) bindings)
 139              k)))
 140
 141 (defun create-skipper (element-name kk)
 142   "Return a function that skips input in SOURCE until it sees a
 143 closing tag for ELEMENT-NAME. Nested occurrences of elements with the
 144 same ELEMENT-NAME are also skipped."
 145   (let ((depth 0))
 146     (lambda (source bindings k)
 147       (loop
 148        (multiple-value-bind (type uri lname)
 149            (klacks:consume source)
 150          (declare (ignore uri))
 151          (cond ((and (eql type :end-element)
 152                      (string= lname element-name))
 153                 (if (zerop depth)
 154                     (return (funcall kk source bindings k))
 155                     (decf depth)))
 156                ((and (eql type :start-element)
 157                      (string= lname element-name))
 158                 (incf depth))))))))
 159
 160 (defun create-bindings-returner ()
 161   "Return a function that does nothing but return its BINDINGS,
 162 effectively ending matching."
 163   (lambda (source bindings k)
 164     (declare (ignore source k))
 165     (nreverse bindings)))
 166
 167 (defun create-sequence-binder (key forms kk)
 168   "Return a function that creates a list of sub-bindings based on a
 169 sub-matcher, with KEY as the key."
 170   (let ((binder (create-binder forms (create-bindings-returner)))
 171         (element-name (first forms)))
 172     (lambda (source bindings k)
 173       (let ((sub-bindings '()))
 174         (loop
 175          (skip-characters source)
 176          (multiple-value-bind (type uri lname)
 177              (klacks:peek source)
 178            (declare (ignore uri))
 179            (unless (and (eql type :start-element)
 180                         (string= lname element-name))
 181              (return (funcall kk source (acons key
 182                                                (nreverse sub-bindings)
 183                                                bindings)
 184                               k))))
 185          (push (funcall binder source nil k) sub-bindings))))))
 186
 187 (defun create-alist-binder (key kk)
 188   "Return a function that returns the rest of SOURCE as an alist of
 189 element-name/element-content data."
 190   (lambda (source bindings k)
 191     (funcall kk source
 192              (acons key (collect-rest-alist source) bindings)
 193              k)))
 194
 195 (defun create-optional-binder (subforms kk)
 196   (let ((binder (create-binder subforms kk))
 197         (element-name (first subforms)))
 198     (lambda (source bindings k)
 199       (skip-characters source)
 200       (multiple-value-bind (type uri lname)
 201           (klacks:peek source)
 202         (declare (ignore uri))
 203         (cond ((and (eql type :start-element)
 204                     (string= element-name lname))
 205                (funcall binder
 206                         source
 207                         bindings
 208                         k))
 209               (t (funcall kk source bindings k)))))))
 210
 211
 212 (defun create-special-processor (operator form k)
 213   "Handle special pattern processing forms like BIND, SKIP-REST, SEQUENCE,
 214 etc."
 215   (ecase operator
 216     (bind (create-bindings-extender (second form) k))
 217     (optional (create-optional-binder (second form) k))
 218     (skip-rest (create-skipper *current-element-name* k))
 219     (sequence
 220      (destructuring-bind (key subforms)
 221          (rest form)
 222        (create-sequence-binder key subforms k)))
 223     (elements-alist
 224      (create-alist-binder (second form) k))))
 225
 226 (defun create-binder (form &optional (k (create-bindings-returner)))
 227   "Process FORM as an XML binder pattern and return a closure to
 228 process an XML source."
 229   (let ((operator (first form)))
 230     (etypecase operator
 231       (string
 232        (let ((*current-element-name* operator))
 233          (create-element-start-matcher *current-element-name*
 234                                        (create-binder (rest form) k))))
 235       (null
 236        (create-element-end-matcher *current-element-name*
 237                                    k))
 238       (cons
 239        (create-binder operator (create-binder (rest form) k)))
 240       (symbol
 241        (create-special-processor operator form k)))))
 242
 243 (defun xml-source (source)
 244   (typecase source
 245     (cxml::cxml-source source)
 246     (t (cxml:make-source source))))
 247
 248 (defun make-binder (form)
 249   (let ((binder (create-binder form (create-bindings-returner))))
 250     (lambda (source)
 251       (let ((source (xml-source source)))
 252         (skip-document-start source)
 253         (funcall binder
 254                  source
 255                  nil
 256                  (create-bindings-returner))))))
 257
 258 (defun xml-bind (binder source)
 259   (funcall binder source))
 260
 261 (defun xml-document-element (source)
 262   (nth-value 2 (klacks:find-event (xml-source source) :start-element)))
 263
 264 (defun bvalue (key bindings)
 265   (cdr (assoc key bindings)))
 266
 267 (defun bfun (key)
 268   (lambda (binding)
 269     (bvalue key binding)))
 270
 271 (defmacro alist-bind (bindings alist &body body)
 272   (let ((binds (gensym)))
 273     (flet ((one-binding (var)
 274              (let ((keyword (intern (symbol-name var) :keyword)))
 275                `(when (eql (caar ,binds) ,keyword)
 276                   (setf ,var (cdr (pop ,binds)))))))
 277     `(let ,bindings
 278        (let ((,binds ,alist))
 279          ,@(mapcar #'one-binding bindings)
 280          ,@body)))))
 281
 282
 283 ;;; Protocol
 284
 285 (defgeneric merge-bindings (object bindings)
 286   (:documentation "Update OBJECT with the data from BINDINGS."))
 287