Updated version to 1.3.3.
[zs3.git] / xml-binding.lisp
blob37c9093b5cfe230238d9bc1783723c7373924759
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
30 (in-package #:zs3)
32 ;;; utility
34 (defun skip-document-start (source)
35 (let ((type (klacks:peek source)))
36 (when (eql :start-document type)
37 (klacks:consume source))
38 (values)))
40 (defun skip-characters (source)
41 (loop
42 (if (member (klacks:peek source) '(:characters :comment))
43 (klacks:consume source)
44 (return))))
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))
55 (return)))))))
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)))))))
75 ;;; Match failure conditions
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)))))
91 ;;; API
93 (defvar *binder-definitions*
94 (make-hash-table))
96 (defclass binder ()
97 ((source
98 :initarg :source
99 :accessor source)
100 (closure
101 :initarg :closure
102 :accessor closure)))
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))))
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)))))
117 (defun xml-bind (binder-name source)
118 (funcall (closure (find-binder binder-name)) source))
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))))
129 ;;; Creating the matchers/binders
131 (defvar *current-element-name*)
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))))
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))))
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)))
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))))))))
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)))
205 (defmacro catching-xml-errors (&body body)
206 `(handler-case
207 (progn ,@body)
208 (xml-binding-error (c)
209 (values nil c))))
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)
229 (push sub-binding sub-bindings))))))))
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)))
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)))))
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)))))))
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)))))
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))))
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*
295 (cons
296 (create-binder operator (create-binder (rest form) k)))
297 (symbol
298 (create-special-processor operator form k)))))
300 (defun xml-source (source)
301 (typecase source
302 (cxml::cxml-source source)
303 (t (cxml:make-source source))))
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
313 (create-bindings-returner))))))
317 (defun xml-document-element (source)
318 (nth-value 2 (klacks:find-event (xml-source source) :start-element)))
320 (defun bvalue (key bindings)
321 (cdr (assoc key bindings)))
323 (defun bfun (key)
324 (lambda (binding)
325 (bvalue key binding)))
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)))))
339 ;;; Protocol
341 (defgeneric merge-bindings (object bindings)
342 (:documentation "Update OBJECT with the data from BINDINGS."))