A first stab at parsing wayland.xml

gistfile1.lisp

(defpackage parse
  (:use :common-lisp)
  (:export :parse-protocol
           :bad-form
           :bad-header
           :bad-type
           :form
           :name))
(in-package :parse)


;;; Parser error handling

(defgeneric report-parse-error (condition stream)
  (:method-combination progn :most-specific-last))

(define-condition bad-form ()
  ((form :reader  form
         :initarg :form))
  (:report report-parse-error))

(defmethod report-parse-error progn ((condition bad-form) stream)
  (format stream "Could not parse ~a~%" (form condition)))


;;; Header parsing

(define-condition bad-header (bad-form)
  ())

(defmethod report-parse-error progn ((condition bad-header) stream)
  (format stream "Does not match any known header format~%"))

(defgeneric parse-header (header)
  (:documentation "Parses an element header")
  (:method (header)
    (error 'bad-header :form header)))

(defmethod parse-header ((header symbol))
  (values header nil))

(defmethod parse-header ((header list))
  (destructuring-bind (element . attribute-plist)
      header
    (values element attribute-plist)))


;;; Protocol object types

(defclass protocol-element ()
  ())

(defgeneric decorate-object (object attribute-plist body)
  (:documentation "Creates an object from an element of the XML tree")
  (:method ((object protocol-element) attribute-plist body)
    (declare (ignore attribute-plist body))
    object))

(defclass named-protocol-element (protocol-element)
  ((name :accessor name)))

(defclass versioned-protocol-element (protocol-element)
  ((version :accessor version)))

(defclass protocol (named-protocol-element)
  ((copyright :accessor copyright)
   (interfaces :accessor interfaces)))

(defclass copyright (protocol-element)
  ((text :accessor text)))

(defclass interface (named-protocol-element versioned-protocol-element)
  ())


;;; Object creation

(define-condition bad-type (bad-form)
  ())

(defmethod report-parse-error progn ((condition bad-type) stream)
  (format stream "Does not match any implemented element type~%"))

(defvar *element-type-alist*
  '((:|protocol| . protocol)
    (:|copyright| . copyright)
    (:|interface| . interface)))

(defun create-object (element-type attribute-plist body)
  (let ((class-name (cdr (assoc element-type *element-type-alist*))))
    (if class-name
        (let ((object (make-instance class-name)))
          (decorate-object object attribute-plist body))
        (error 'bad-type :form element-type))))


;;; Toplevel parsing

(defgeneric parse-protocol (form)
  (:documentation "Parses the output of S-XML.")
  (:method (form) form))

(defmethod parse-protocol ((form cons))
  (destructuring-bind (header . body)
      form
    (multiple-value-bind (element-type attribute-plist)
        (parse-header header)
      (create-object element-type attribute-plist body))))


;;; Object decoration

(defun typep-p (type)
  (lambda (object)
    (typep object type)))

(defmacro define-mixin-decorator (mixin accessor attribute)
  `(defmethod decorate-object :around ((object ,mixin) attribute-plist body)
     (let ((,accessor (getf attribute-plist ,attribute)))
       (setf (,accessor object) ,accessor)
       (remf attribute-plist ,attribute)
       (call-next-method object attribute-plist body))))

(define-mixin-decorator named-protocol-element name :|name|)
(define-mixin-decorator versioned-protocol-element version :|version|)

(defmethod decorate-object ((object protocol) attribute-plist body)
  (let* ((body-elements (mapcar #'parse-protocol body))
         (copyright     (find-if (typep-p 'copyright) body-elements))
         (interfaces    (remove-if-not (typep-p 'interface) body-elements)))
    (setf (copyright object) copyright)
    (setf (interfaces object) interfaces))
  object)

(defmethod decorate-object ((object copyright) attribute-plist body)
  (setf (text object) (first body))
  object)


;;; Pretty-printing