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 (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 (defmacro catching-xml-errors (&body body)
 168   `(handler-case
 169        (progn ,@body)
 170      (xml-binding-error (c)
 171        (values nil c))))
 172
 173 (defun create-sequence-binder (key forms kk)
 174   "Return a function that creates a list of sub-bindings based on a
 175 sub-matcher, with KEY as the key."
 176   (let ((binder (create-binder forms (create-bindings-returner))))
 177     (lambda (source bindings k)
 178       (let ((sub-bindings '()))
 179         (loop
 180           (skip-characters source)
 181           (multiple-value-bind (sub-binding failure)
 182               (catching-xml-errors
 183                 (funcall binder source nil k))
 184             (if failure
 185                 (return (funcall kk
 186                                  source
 187                                  (acons key
 188                                         (nreverse sub-bindings)
 189                                         bindings)
 190                                  k))
 191                 (push sub-binding sub-bindings))))))))
 192
 193 (defun create-alist-binder (key kk)
 194   "Return a function that returns the rest of SOURCE as an alist of
 195 element-name/element-content data."
 196   (lambda (source bindings k)
 197     (funcall kk source
 198              (acons key (collect-rest-alist source) bindings)
 199              k)))
 200
 201 (defun create-optional-binder (subforms kk)
 202   (let ((binder (create-binder subforms kk)))
 203     (lambda (source bindings k)
 204       (skip-characters source)
 205       (multiple-value-bind (optional-bindings failure)
 206           (catching-xml-errors (funcall binder source bindings k))
 207         (if failure
 208             (funcall kk source bindings k)
 209             optional-bindings)))))
 210
 211 (defun create-alternate-binder (subforms kk)
 212   (let ((binders (mapcar (lambda (form) (create-binder form kk)) subforms)))
 213     (lambda (source bindings k)
 214       ;; FIXME: This xml-binding-error needs :expected and :action
 215       ;; ooptions. Can get actual with peeking and expected by getting
 216       ;; the cl:cars of subforms...maybe.
 217       (dolist (binder binders (error 'xml-binding-error))
 218         (multiple-value-bind (alt-bindings failure)
 219             (catching-xml-errors (funcall binder source bindings k))
 220           (unless failure
 221             (return alt-bindings)))))))
 222
 223 (defun create-special-processor (operator form k)
 224   "Handle special pattern processing forms like BIND, SKIP-REST, SEQUENCE,
 225 etc."
 226   (ecase operator
 227     (alternate (create-alternate-binder (rest form) k))
 228     (bind (create-bindings-extender (second form) k))
 229     (optional (create-optional-binder (second form) k))
 230     (skip-rest (create-skipper *current-element-name* k))
 231     (sequence
 232      (destructuring-bind (key subforms)
 233          (rest form)
 234        (create-sequence-binder key subforms k)))
 235     (elements-alist
 236      (create-alist-binder (second form) k))))
 237
 238 (defun create-binder (form &optional (k (create-bindings-returner)))
 239   "Process FORM as an XML binder pattern and return a closure to
 240 process an XML source."
 241   (let ((operator (first form)))
 242     (etypecase operator
 243       (string
 244        (let ((*current-element-name* operator))
 245          (create-element-start-matcher *current-element-name*
 246                                        (create-binder (rest form) k))))
 247       (null
 248        (create-element-end-matcher *current-element-name*
 249                                    k))
 250       (cons
 251        (create-binder operator (create-binder (rest form) k)))
 252       (symbol
 253        (create-special-processor operator form k)))))
 254
 255 (defun xml-source (source)
 256   (typecase source
 257     (cxml::cxml-source source)
 258     (t (cxml:make-source source))))
 259
 260 (defun make-binder (form)
 261   (let ((binder (create-binder form (create-bindings-returner))))
 262     (lambda (source)
 263       (let ((source (xml-source source)))
 264         (skip-document-start source)
 265         (funcall binder
 266                  source
 267                  nil
 268                  (create-bindings-returner))))))
 269
 270 (defun xml-bind (binder source)
 271   (funcall binder source))
 272
 273 (defun try-to-xml-bind (binder source)
 274   "Like XML-BIND, but catches any XML-BINDING-ERRORs; if any errors
 275   are caught, NIL is the primary value and the error object is the
 276   secondary value."
 277   (handler-case
 278       (xml-bind binder source)
 279     (xml-binding-error (c)
 280       (values nil c))))
 281
 282 (defun xml-document-element (source)
 283   (nth-value 2 (klacks:find-event (xml-source source) :start-element)))
 284
 285 (defun bvalue (key bindings)
 286   (cdr (assoc key bindings)))
 287
 288 (defun bfun (key)
 289   (lambda (binding)
 290     (bvalue key binding)))
 291
 292 (defmacro alist-bind (bindings alist &body body)
 293   (let ((binds (gensym)))
 294     (flet ((one-binding (var)
 295              (let ((keyword (intern (symbol-name var) :keyword)))
 296                `(when (eql (caar ,binds) ,keyword)
 297                   (setf ,var (cdr (pop ,binds)))))))
 298     `(let ,bindings
 299        (let ((,binds ,alist))
 300          ,@(mapcar #'one-binding bindings)
 301          ,@body)))))
 302
 303
 304 ;;; Protocol
 305
 306 (defgeneric merge-bindings (object bindings)
 307   (:documentation "Update OBJECT with the data from BINDINGS."))
 308