Wed Nov 18 08:57:44 UTC 2009 pix@kepibu.org

* status commit; add cxml:dom support

--- old-Oh, Ducks!/oh-ducks.asd 2013-08-08 14:08:21.000000000 +0000

+++ new-Oh, Ducks!/oh-ducks.asd 2013-08-08 14:08:21.000000000 +0000

@@ -21,6 +21,7 @@

:components

((:file "interface")

(:file "lhtml" :depends-on ("interface"))

- (:file "pt" :depends-on ("interface"))))

+ (:file "pt" :depends-on ("interface"))

+ (:file "dom" :depends-on ("interface"))))

(:file "selectors")

(:file "unification-templates")))

--- old-Oh, Ducks!/traversal/dom.lisp 1970-01-01 00:00:00.000000000 +0000

+++ new-Oh, Ducks!/traversal/dom.lisp 2013-08-08 14:08:21.000000000 +0000

@@ -0,0 +1,25 @@

+(in-package #:oh-ducks)

+

+;;; general accessors

+

+(defmethod element-children ((element dom:node))

+ (coerce (dom:child-nodes element) 'list))

+(defmethod element-parent ((element dom:node))

+ (dom:parent-node element))

+(defmethod element-attribute (attribute (element dom:node)) nil)

+(defmethod element-attribute ((attribute symbol) (element dom:element))

+ (element-attribute (string-downcase (symbol-name attribute)) element))

+(defmethod element-attribute ((attribute string) (element dom:element))

+ (dom:get-attribute element attribute))

+(defmethod element-type ((element dom:node)) nil)

+(defmethod element-type ((element dom:element))

+ (dom:tag-name element))

+

+;;; special accessors in case something special needs to happen

+(defmethod element-id ((element dom:node))

+ nil)

+(defmethod element-id ((element dom:element))

+ (element-attribute "id" element))

+

+(defmethod element-classes (element)

+ (split-sequence:split-sequence #\Space (element-attribute "class" element) :remove-empty-subseqs t))

--- old-Oh, Ducks!/traversal/interface.lisp 2013-08-08 14:08:21.000000000 +0000

+++ new-Oh, Ducks!/traversal/interface.lisp 2013-08-08 14:08:21.000000000 +0000

@@ -9,24 +9,24 @@

(:documentation "Returns a sequence of element's element-children."))

(defgeneric element-parent (element)

(:documentation "Returns element's element-parent element."))

-(defgeneric element-attribute (element-attribute element)

- (:documentation "Returns the value of the element-attribute of element, or nil if no such element-attribute exists."))

+(defgeneric element-attribute (attribute element)

+ (:documentation "Returns the value of the attribute of element, or nil if no such attribute exists."))

(defgeneric element-type (element)

(:documentation "Returns the tag name (element-type) of element."))

;;; special accessors in case something special needs to happen

(defgeneric element-id (element)

- (:documentation "Equivalent in spirit to (element-attribute :element-id element).")

+ (:documentation "Equivalent in spirit to (element-attribute :id element).")

(:method (element) (element-attribute :id element)))

(defgeneric element-classes (element)

- (:documentation "Equivalent in spirit to (element-attribute :class element), except it returns a sequence of individual element-classes.")

+ (:documentation "Equivalent in spirit to (element-attribute :class element), except it returns a sequence of individual classes.")

(:method (element)

(split-sequence:split-sequence #\Space (element-attribute :class element) :remove-empty-subseqs t)))

(defgeneric element-type-equal (element type)

- (:documentation "Equivalent in spirit to (string-equal (element-type element) element-type), but not obligated to work under the assumption of string-designators.")

+ (:documentation "Equivalent in spirit to (string-equal (element-type element) type), but not obligated to work under the assumption of string-designators.")

(:method (element type) (string-equal type (element-type element))))

(defgeneric element-ancestors (element)

--- old-Oh, Ducks!/unification-templates.lisp 2013-08-08 14:08:21.000000000 +0000

+++ new-Oh, Ducks!/unification-templates.lisp 2013-08-08 14:08:21.000000000 +0000

@@ -9,28 +9,54 @@

;; parser is specified, requires an already-parsed document be passed

;; in.

+(defvar *default-parser* 'pt "Determines the default parser when none is specified.")

+

(defclass css-selector-template (unify::expression-template)

- (#+(or)

- (parser :reader parser) ;; subtype determines parser

- (handler :reader handler) ;; cxml/closure-html handler

+ ((parser :initarg :parser) ;; subtype generally determines parser

(specifiers :reader specifiers) ;; list of (specifier . variable) and (specifier . template)

))

(defclass xml-template (css-selector-template) ()) ;; parses using closure-xml

+(defclass dom-template (xml-template) ())

+

(defclass html-template (css-selector-template) ()) ;; parses using closure-html

(defclass lhtml-template (html-template) ())

(defclass pt-template (html-template) ())

-(defmethod make-template ((kind (eql 'lhtml)) (spec cons))

- (make-instance 'lhtml-template :spec spec))

+(defgeneric document-parser (template)

+ (:documentation "Returns a function which, given an unparsed document, parses that document into some sort of structure.")

+ (:method ((template css-selector-template))

+ (slot-value template 'parser))

+ (:method ((template dom-template))

+ (lambda (document) (cxml:parse document (cxml-dom:make-dom-builder))))

+ (:method ((template lhtml-template))

+ (lambda (document) (chtml:parse document (chtml:make-lhtml-builder))))

+ (:method ((template pt-template))

+ (lambda (document) (chtml:parse document (chtml:make-pt-builder)))))

+

+(defun %spec-includes-opts (spec)

+ (keywordp (first (second spec))))

(defmethod make-template ((kind (eql 'html)) (spec cons))

- (make-instance 'pt-template :spec spec))

+ (destructuring-bind (&key parser)

+ (if (%spec-includes-opts spec)

+ (second spec)

+ (list :parser *default-parser*))

+ (case parser

+ ;; short names

+ ((lhtml :lhtml) (make-instance 'lhtml-template :spec spec))

+ ((pt :pt) (make-instance 'pt-template :spec spec))

+ ((dom :dom) (make-instance 'dom-template :spec spec))

+ ;; user-specified

+ (t (make-instance 'css-selector-template :parser parser :spec spec)))))

(defmethod initialize-instance :after ((template css-selector-template) &key css-specifiers parent &allow-other-keys)

- (let ((specifiers-and-vars (or css-specifiers (rest (template-spec template)))))

+ (let* ((spec (template-spec template))

+ (specifiers-and-vars (or css-specifiers (if (%spec-includes-opts spec)

+ (cddr spec)

+ (rest spec)))))

(setf (slot-value template 'specifiers)

(parse-specifiers specifiers-and-vars template parent))))

@@ -61,6 +87,7 @@

(defmethod unify ((a css-selector-template) (b css-selector-template)

&optional (env (make-empty-environment))

&key &allow-other-keys)

+ (declare (ignore env))

(error 'unification-failure

:format-control "Do not know how to unify the two css-selector-templates ~S and ~S."

:format-arguments (list a b)))

@@ -77,12 +104,18 @@

(t (error "whoops: ~s, ~s" css-specifier template)))))

env)

-(defmethod unify ((template lhtml-template) (document string)

+(defmethod unify (document (template css-selector-template)

&optional (env (make-empty-environment))

&key &allow-other-keys)

- (unify template (chtml:parse document (chtml:make-lhtml-builder)) env))

+ (unify template document env))

-(defmethod unify ((template pt-template) (document string)

+(defmethod unify ((template css-selector-template) (document string)

&optional (env (make-empty-environment))

&key &allow-other-keys)

- (unify template (chtml:parse document (chtml:make-pt-builder)) env))

+ (unify template (funcall (document-parser template) document) env))

+

+(defmethod unify ((template css-selector-template) (document pathname)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (unify template (funcall (document-parser template) document) env))

+