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 ;;; API
  92
  93 (defvar *binder-definitions*
  94   (make-hash-table))
  95
  96 (defclass binder ()
  97   ((source
  98     :initarg :source
  99     :accessor source)
 100    (closure
 101     :initarg :closure
 102     :accessor closure)))
 103
 104 (defmacro defbinder (name &body source)
 105   `(eval-when (:compile-toplevel :load-toplevel :execute)
 106      (setf (gethash ',name *binder-definitions*)
 107            (make-instance 'binder
 108                           :closure (make-binder ',@source)
 109                           :source ',@source))))
 110
 111 (defun find-binder (name &optional (errorp t))
 112   (let ((binder (gethash name *binder-definitions*)))
 113     (or binder
 114         (and errorp
 115              (error "No binder named ~S" name)))))
 116
 117 (defun xml-bind (binder-name source)
 118   (funcall (closure (find-binder binder-name)) source))
 119
 120 (defun try-to-xml-bind (binder-name source)
 121   "Like XML-BIND, but catches any XML-BINDING-ERRORs; if any errors
 122   are caught, NIL is the primary value and the error object is the
 123   secondary value."
 124   (handler-case
 125       (xml-bind binder-name source)
 126     (xml-binding-error (c)
 127       (values nil c))))
 128
 129 ;;; Creating the matchers/binders
 130
 131 (defvar *current-element-name*)
 132
 133 (defun create-element-start-matcher (element-name kk)
 134   "Return a function that expects to see the start of ELEMENT-NAME
 135 next in SOURCE."
 136   (lambda (source bindings k)
 137     (skip-characters source)
 138     (multiple-value-bind (type uri lname qname)
 139         (klacks:peek source)
 140       (declare (ignore uri qname))
 141       (when (not (eql type :start-element))
 142         (error 'xml-binding-error
 143                :expected (list :start-element element-name)
 144                :actual (list :event type)))
 145       (when (string/= element-name lname)
 146         (error 'xml-binding-error
 147                :expected (list :start-element element-name)
 148                :actual (list type lname)))
 149       (klacks:consume source)
 150       (funcall kk source bindings k))))
 151
 152 (defun create-element-end-matcher (element-name kk)
 153   "Return a function that expects to see the end of ELEMENT-NAME next in
 154 SOURCE."
 155   (lambda (source bindings k)
 156     (skip-characters source)
 157     (multiple-value-bind (type uri lname qname)
 158         (klacks:peek source)
 159       (declare (ignore uri qname))
 160       (when (not (eql type :end-element))
 161         (error 'xml-binding-error
 162                :expected (list :end-element element-name)
 163                :actual (list :event type lname)))
 164       (when (string/= element-name lname)
 165         (error 'xml-binding-error
 166                :expected (list :end-element element-name)
 167                :actual (list type lname)))
 168       (klacks:consume source)
 169       (funcall kk source bindings k))))
 170
 171 (defun create-bindings-extender (key kk)
 172   "Return a function that extends BINDINGS with KEY and a value of
 173 whatever character data is pending in SOURCE."
 174   (lambda (source bindings k)
 175     (funcall kk source
 176              (acons key (collect-characters source) bindings)
 177              k)))
 178
 179 (defun create-skipper (element-name kk)
 180   "Return a function that skips input in SOURCE until it sees a
 181 closing tag for ELEMENT-NAME. Nested occurrences of elements with the
 182 same ELEMENT-NAME are also skipped."
 183   (let ((depth 0))
 184     (lambda (source bindings k)
 185       (loop
 186        (multiple-value-bind (type uri lname)
 187            (klacks:consume source)
 188          (declare (ignore uri))
 189          (cond ((and (eql type :end-element)
 190                      (string= lname element-name))
 191                 (if (zerop depth)
 192                     (return (funcall kk source bindings k))
 193                     (decf depth)))
 194                ((and (eql type :start-element)
 195                      (string= lname element-name))
 196                 (incf depth))))))))
 197
 198 (defun create-bindings-returner ()
 199   "Return a function that does nothing but return its BINDINGS,
 200 effectively ending matching."
 201   (lambda (source bindings k)
 202     (declare (ignore source k))
 203     (nreverse bindings)))
 204
 205 (defmacro catching-xml-errors (&body body)
 206   `(handler-case
 207        (progn ,@body)
 208      (xml-binding-error (c)
 209        (values nil c))))
 210
 211 (defun create-sequence-binder (key forms kk)
 212   "Return a function that creates a list of sub-bindings based on a
 213 sub-matcher, with KEY as the key."
 214   (let ((binder (create-binder forms (create-bindings-returner))))
 215     (lambda (source bindings k)
 216       (let ((sub-bindings '()))
 217         (loop
 218           (skip-characters source)
 219           (multiple-value-bind (sub-binding failure)
 220               (catching-xml-errors
 221                 (funcall binder source nil k))
 222             (if failure
 223                 (return (funcall kk
 224                                  source
 225                                  (acons key
 226                                         (nreverse sub-bindings)
 227                                         bindings)
 228                                  k))
 229                 (push sub-binding sub-bindings))))))))
 230
 231 (defun create-alist-binder (key kk)
 232   "Return a function that returns the rest of SOURCE as an alist of
 233 element-name/element-content data."
 234   (lambda (source bindings k)
 235     (funcall kk source
 236              (acons key (collect-rest-alist source) bindings)
 237              k)))
 238
 239 (defun create-optional-binder (subforms kk)
 240   (let ((binder (create-binder subforms kk)))
 241     (lambda (source bindings k)
 242       (skip-characters source)
 243       (multiple-value-bind (optional-bindings failure)
 244           (catching-xml-errors (funcall binder source bindings k))
 245         (if failure
 246             (funcall kk source bindings k)
 247             optional-bindings)))))
 248
 249 (defun create-alternate-binder (subforms kk)
 250   (let ((binders (mapcar (lambda (form) (create-binder form kk)) subforms)))
 251     (lambda (source bindings k)
 252       ;; FIXME: This xml-binding-error needs :expected and :action
 253       ;; ooptions. Can get actual with peeking and expected by getting
 254       ;; the cl:cars of subforms...maybe.
 255       (dolist (binder binders (error 'xml-binding-error))
 256         (multiple-value-bind (alt-bindings failure)
 257             (catching-xml-errors (funcall binder source bindings k))
 258           (unless failure
 259             (return alt-bindings)))))))
 260
 261 (defun create-sub-binder-binder (binder-name kk)
 262   (lambda (source bindings k)
 263     (let ((binder (find-binder binder-name)))
 264       (let ((sub-bindings (funcall (closure binder) source)))
 265         (funcall k source (append sub-bindings bindings) kk)))))
 266
 267 (defun create-special-processor (operator form k)
 268   "Handle special pattern processing forms like BIND, SKIP-REST, SEQUENCE,
 269 etc."
 270   (ecase operator
 271     (include (create-sub-binder-binder (second form) k))
 272     (alternate (create-alternate-binder (rest form) k))
 273     (bind (create-bindings-extender (second form) k))
 274     (optional (create-optional-binder (second form) k))
 275     (skip-rest (create-skipper *current-element-name* k))
 276     (sequence
 277      (destructuring-bind (key subforms)
 278          (rest form)
 279        (create-sequence-binder key subforms k)))
 280     (elements-alist
 281      (create-alist-binder (second form) k))))
 282
 283 (defun create-binder (form &optional (k (create-bindings-returner)))
 284   "Process FORM as an XML binder pattern and return a closure to
 285 process an XML source."
 286   (let ((operator (first form)))
 287     (etypecase operator
 288       (string
 289        (let ((*current-element-name* operator))
 290          (create-element-start-matcher *current-element-name*
 291                                        (create-binder (rest form) k))))
 292       (null
 293        (create-element-end-matcher *current-element-name*
 294                                    k))
 295       (cons
 296        (create-binder operator (create-binder (rest form) k)))
 297       (symbol
 298        (create-special-processor operator form k)))))
 299
 300 (defun xml-source (source)
 301   (typecase source
 302     (cxml::cxml-source source)
 303     (t (cxml:make-source source))))
 304
 305 (defun make-binder (form)
 306   (let ((binder (create-binder form (create-bindings-returner))))
 307     (lambda (source)
 308       (let ((source (xml-source source)))
 309         (skip-document-start source)
 310         (funcall binder
 311                  source
 312                  nil
 313                  (create-bindings-returner))))))
 314
 315
 316
 317 (defun xml-document-element (source)
 318   (nth-value 2 (klacks:find-event (xml-source source) :start-element)))
 319
 320 (defun bvalue (key bindings)
 321   (cdr (assoc key bindings)))
 322
 323 (defun bfun (key)
 324   (lambda (binding)
 325     (bvalue key binding)))
 326
 327 (defmacro alist-bind (bindings alist &body body)
 328   (let ((binds (gensym)))
 329     (flet ((one-binding (var)
 330              (let ((keyword (intern (symbol-name var) :keyword)))
 331                `(when (eql (caar ,binds) ,keyword)
 332                   (setf ,var (cdr (pop ,binds)))))))
 333     `(let ,bindings
 334        (let ((,binds ,alist))
 335          ,@(mapcar #'one-binding bindings)
 336          ,@body)))))
 337
 338
 339 ;;; Protocol
 340
 341 (defgeneric merge-bindings (object bindings)
 342   (:documentation "Update OBJECT with the data from BINDINGS."))
 343
 344