Sun Jul 3 08:25:45 UTC 2011 pix@kepibu.org

* Add support for XMLS-style lists, conflicting with LHTML-style lists

+** Differentiating between LHTML lists and XMLS lists

+While it would, in theory, be possible to inspect lists and determine if they

+are LHTML or XMLS lists, this is not currently done. You can, however, choose

+which type you'd like to work with by pushing =:lists-are-xmls= or

+=:lists-are-lhtml= to =*features*= before loading "Oh, Ducks!".

+Unfortunately, this means you can only expect to use one list type in a single

+lisp image. Patches to either automagically detect the list type, or to provide

+layered functions are welcome.

- :components ((:file "lhtml")

+ :components (#-lists-are-xmls (:file "lhtml")

- :components ((:file "dom")))))

+ :components ((:file "dom")

+ #-lists-are-lhtml (:file "xmls")))))

+

+;; In case you're wondering, we check the inverse of the :lists-are-* keywords

+;; so, in the event you only load cxml (or chtml), and don't specify which

+;; format lists are expected to take, you get the appropriate list operation by

+;; default.

+;;; WARNING: This conflicts with lhtml.

+(in-package #:oh-ducks.traversal)

+

+(defvar *xmls-family-tree* nil)

+

+(defun in-hash (key hash)

+ (multiple-value-bind (val present-p) (gethash key hash)

+ (declare (ignore val))

+ present-p))

+

+(defun %mark-parents (parent children)

+ (dolist (item children)

+ (setf (gethash item *xmls-family-tree*) parent)

+ (%mark-parents item (element-children item))))

+

+;; WARNING: This won't produce sane results for nested (match)es, because we

+;; have no way to bind in a large enough scope.

+(defmethod unify:unify ((template oh-ducks::css-selector-template)

+ (element list)

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

+ &key)

+ (if (and *xmls-family-tree*

+ (in-hash element *xmls-family-tree*))

+ (call-next-method)

+ (let ((*xmls-family-tree* (make-hash-table :test 'eq)))

+ (%mark-parents nil (list element))

+ (%mark-parents element (element-children element))

+ (call-next-method))))

+

+(defmethod unify:unify ((document list) (template oh-ducks::css-selector-template)

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

+ &key)

+ (unify:unify template document env))

+

+;;; general accessors

+

+(defmethod element-children ((element list))

+ (remove-if-not (lambda (x) (and (listp x) (stringp (car x))))

+ (cddr element)))

+

+(defmethod element-parent ((element list))

+ (multiple-value-bind (parent present?)

+ (gethash element *xmls-family-tree*)

+ (if present?

+ parent

+ (error "unable to determine parent"))))

+

+#+(or)

+(defmethod element-attribute ((attribute symbol) (element list))

+ (cadr (assoc attribute (cadr element))))

+(defmethod element-attribute ((attribute string) (element list))

+ (cadr (assoc attribute (cadr element) :test #'string=)))

+

+(defmethod element-type ((element list))

+ (car element))

+

+(defmethod element-content ((element list))

+ (cddr element))

Sun Jul 3 07:55:18 UTC 2011 pix@kepibu.org

* Minimal support for attribute-starts-with selector

+(defclass attribute-starts-with-selector (attribute-selector) ())

+ (#T(regexp$ ("[" $name "^=" $name "]") (?attribute ?value))

+ (cons (make-instance 'attribute-starts-with-selector :arg attribute :value value)

+ (parse-selector &rest)))

+(defmethod subject-p ((selector attribute-starts-with-selector) element)

+ (when-let* ((val (element-attribute (selector-arg selector) element)))

+ (alexandria:starts-with-subseq (string-downcase (attribute-value selector)) (string-downcase val))))

+

Sun Jun 5 21:44:21 UTC 2011 pix@kepibu.org

* Update notes file

+Submitted. Was it ever accepted? Man, I don't remember.

+** Element structure templates

+For instance, sometimes it'd be nice to stuff the value of an attribute into a

+variable, like so:

+: (match #t(attr ("href" ?href) ("name" ?name)) "<a href='url' name='link'></a>"

+: (values href name)) =>

+: "url", "link"

+While it's certainly easy enough to do that using, say, XMLS-style lists, a

+general object-model-agnostic method would seem to be preferrable.

+** Layered functions so LHTML vs. XMLS support can be switched at runtime

Tue Apr 5 00:14:51 UTC 2011 pix@kepibu.org

* depend-on cl-unification-lib to work with stock cl-unification

- :depends-on (:cl-unification :cl-ppcre :split-sequence :alexandria)

+ :depends-on (:cl-unification-lib :cl-unification :cl-ppcre :split-sequence :alexandria)

Wed Feb 10 08:50:16 UTC 2010 pix@kepibu.org

* Add attribute-equal selector

-*** attribute selectors [1/7]

+*** attribute selectors [2/7]

- * [ ] attribute-equal [att=val]

+ * [X] attribute-equal [att=val]

-(defclass attribute-selector (simple-selector) ())

+(defclass attribute-selector (simple-selector)

+ ((val :reader attribute-value :initarg :value)))

+(defclass attribute-equal-selector (attribute-selector) ())

+ (#T(regexp$ ("[" $name "=" $name "]") (?attribute ?value))

+ (cons (make-instance 'attribute-equal-selector :arg attribute :value value)

+ (parse-selector &rest)))

+(defmethod subject-p ((selector attribute-equal-selector) element)

+ (when-let* ((val (element-attribute (selector-arg selector) element)))

+ (string= val (attribute-value selector))))

+

+(serialize-values

+ (match (#T(html (:model dom)

+ ("[id=foo]" . ?id))

+ "<div><i id='bar'>bar id</i><i>no id</i><i id='foo'>foo id</i></div>")

+ id))

+

Wed Feb 10 08:28:34 UTC 2010 pix@kepibu.org

* Add attribute-present selector

-*** attribute selectors [0/7]

- * [ ] attribute-present [att]

+*** attribute selectors [1/7]

+ * [X] attribute-present [att]

+(defclass attribute-selector (simple-selector) ())

+(defclass attribute-present-selector (attribute-selector) ())

+

+ ;; attribute selectors

+ (#T(regexp$ ("[" $name "]") (?attribute))

+ (cons (make-instance 'attribute-present-selector :arg attribute)

+ (parse-selector &rest)))

+(defmethod subject-p ((selector attribute-present-selector) element)

+ (element-attribute (selector-arg selector) element))

+

+(serialize-values

+ (match (#T(html (:model dom)

+ ("[id]" . ?ids))

+ "<div><i id=''>blank id</i>foo<b>no id</b>bar<i id='id'>id id</i></div>")

+ ids))

Wed Feb 10 08:27:56 UTC 2010 pix@kepibu.org

* Serialize returned tags so it's easier to see what was returned

-(match (#T(html (:model dom)

- ("i" . #t(list ?j ?i))

- ("span>i" . ?span))

- "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

- (values i span))

+(defun make-dom-document (child-node)

+ (make-instance 'rune-dom::document :children (rune-dom::make-node-list (list child-node))))

-(match (#T(html (:model dom)

- ("div:first-child" . ?div)

- ("i:nth-child(1)" . ?i))

- "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

- (values div i))

+(defun serialize (object)

+ (let ((document

+ (etypecase object

+ (rune-dom::document object)

+ (rune-dom::element (make-dom-document object))

+ (chtml:pt object)

+ (list object))))

+ (etypecase document

+ (rune-dom::document

+ (dom:map-document (cxml:make-string-sink :omit-xml-declaration-p t)

+ document))

+ (chtml:pt

+ (chtml:serialize-pt document (chtml:make-string-sink)))

+ (list (mapcar #'serialize document)))))

-(match (#T(html (:model dom)

- ("div:nth-last-child(1)" . ?div)

- ("div:last-child" . ?d2))

- "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

- (values div d2))

+(defmacro serialize-values (form)

+ `(let ((values (multiple-value-list ,form)))

+ (values-list (mapcar #'serialize values))))

-(match (#t(html (:model dom)

- (":nth-last-of-type(2)" . ?first)

- (":nth-of-type(2)" . ?last))

- "<div><span>1</span><i>i</i><span>2</span><i>i</i></div>")

- (values first last))

+(equal '("<i>cheese</i>" "<i>cheese</i>")

+ (serialize-values

+ (match (#T(html (:model dom)

+ ("i" . #t(list ?j ?i))

+ ("span>i" . ?span))

+ "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values i span))))

-(match (#T(html (:model dom)

- ("i:only-child" . ?i)

- ("i:only-of-type" . ?i-type))

- "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

- (values i i-type))

+(serialize-values

+ (match (#T(html (:model dom)

+ ("div:first-child" . ?div)

+ ("i:nth-child(1)" . ?i))

+ "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values div i)))

+

+(serialize-values

+ (match (#T(html (:model dom)

+ ("div:nth-last-child(1)" . ?div)

+ ("div:last-child" . ?d2))

+ "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values div d2)))

+

+(serialize-values

+ (match (#t(html (:model dom)

+ (":nth-last-of-type(2)" . ?first)

+ (":nth-of-type(2)" . ?last))

+ "<div><span>1</span><i>i</i><span>2</span><i>i</i></div>")

+ (values first last)))

-;; throws 'unification-failure

- "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

-(match (#T(html (:model dom)

- ("b + i" . ?i))

- "<div>I <b>really</b> <i>like</i> cheese. Do you not <i>dislike</i> cheese?</div>")

- (values i))

+;; throws 'unification-failure

+(serialize-values

+ (match (#T(html (:model dom)

+ ("i:only-child" . ?i)

+ ("i:only-of-type" . ?i-type))

+ "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span><i>I</i> like <i>cheese</i>.</span></div>")

+ (values i i-type)))

-(match (#T(html (:model dom)

- ("b ~ i" . ?i))

- "<div>I <i>really</i> <b>like</b> cheese. Do you not <i>dislike</i> cheese?</div>")

- (values i))

+(serialize-values

+ (match (#T(html (:model dom)

+ ("b + i" . ?i))

+ "<div>I <b>really</b> <i>like</i> cheese. Do you not <i>dislike</i> cheese?</div>")

+ (values i)))

+

+(serialize-values

+ (match (#T(html (:model dom)

+ ("b ~ i" . ?i))

+ "<div>I <i>really</i> <b>like</b> cheese. Do you <i>not</i> <i>dislike</i> cheese?</div>")

+ (values i)))

-(match (#T(html (:model pt)

- ("body :empty" . ?empty))

- "<div><p><br></p><p>testing<i>i</i>testing</p></div>")

- (values empty))

+(serialize-values

+ (match (#T(html (:model pt)

+ ("body :empty" . ?empty))

+ "<div><p><br></p><p>testing<i>i</i>testing</p></div>")

+ (values empty)))

-(match (#T(html (:model dom)

- ("q" . ?q))

- "<div><i>ham</i> foo <q>bar <i>baz</i></q> quuz <i>spam</i></div>")

- (match (#t(html ("> i" . ?i))

- (first q))

- i))

+(serialize-values

+ (match (#T(html (:model dom)

+ ("q" . ?q))

+ "<div><i>ham</i> foo <q>bar <i>baz</i></q> quuz <i>spam</i></div>")

+ (match (#t(html ("> i" . ?i))

+ (first q))

+ i)))

-(match (#T(html (:model dom)

- ("q" . ?q))

- "<div><i>ham</i> foo <q>bar <i>baz</i></q> quuz <i>spam</i><q></q><i>not match</i></div>")

- (match (#t(html ("+ i" . ?i))

- (first q))

- i))

+(serialize-values

+ (match (#T(html (:model dom)

+ ("q" . ?q))

+ "<div><i>ham</i> foo <q>bar <i>baz</i></q> quuz <i>spam</i><q></q><i>not match</i></div>")

+ (match (#t(html ("+ i" . ?i))

+ (first q))

+ i)))

-(match (#T(html (:model dom)

- ("q" . ?q))

- "<div> foo <q>outer q <i>baz <q>inner q</q></i></q> quuz</div>")

- (match (#t(html ("q" . ?i))

- (first q))

- i))

+(serialize-values

+ (match (#T(html (:model dom)

+ ("q" . ?q))

+ "<div> foo <q>outer q <i>baz <q>inner q</q></i></q> quuz</div>")

+ (match (#t(html ("q" . ?i))

+ (first q))

+ i)))

Wed Feb 10 08:26:34 UTC 2010 pix@kepibu.org

* Formatting.

- "<div id=\"id\">I <i>like</i> cheese.</div>")

+ "<div id=\"id\">I <i>like</i> cheese.</div>")

Wed Feb 10 08:26:25 UTC 2010 pix@kepibu.org

* Use named-readtables instead of set-dispatch-macro-character

+(named-readtables:in-readtable template-readtable)

-#.(set-dispatch-macro-character #\# #\T 'unify::|sharp-T-reader|)

-

Wed Feb 10 08:20:45 UTC 2010 pix@kepibu.org

* Return NIL if attribute was not present

- (dom:get-attribute element attribute))

+ (when-let* ((attribute-node (dom:get-attribute-node element attribute)))

+ (dom:value attribute-node)))

Sun Feb 7 09:21:16 UTC 2010 pix@kepibu.org

* Update notes to reflect updates to cl-unification.

+ * named-readtables

+or

+: (unify:enable-template-reader)

+or

+: (named-readtables:in-readtable unify:template-readtable)

+(The latter two currently only work if you have cl-unification from my

+darcs repo.)

- "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

Mon Jan 4 07:11:36 UTC 2010 pix@kepibu.org

* element-parent now works in lhtml

- (match (#T(html ("div" ("i" . ?i)))

- "<div>I do <i>not</i> like cheese.</div><div>I like <i>cheese</i>.</div>")

+ (match (#T(html (:model lhtml)

+ ("div" ("i" . ?i)))

+ "<div>I do <i>not</i> like cheese.</div><div>I like <i>cheese</i>.</div>")

- (match (#T(html (:model dom)

+ (match (#T(html (:model lhtml)

- "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

- (match (#T(html (:model dom)

+ (match (#T(html (:model lhtml)

- "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

- ((ignore-errors (element-parent document)) ; bleh. element-parent breaks lhtml nodes

+ ((element-parent document)

Mon Jan 4 07:06:50 UTC 2010 pix@kepibu.org

* Support for asking about ancestors under lhtml

-** working lhtml/xmls support [1/2]

+** working lhtml/xmls support [2/2]

- * [ ] selectors involving descendants

+ * [X] selectors involving descendants

+ CAUTION: Won't produce sane results if the document tree is

+ modified or you use nested (match)es.

+(defvar *lhtml-family-tree* nil)

+

+(defun in-hash (key hash)

+ (multiple-value-bind (val present-p) (gethash key hash)

+ (declare (ignore val))

+ present-p))

+

+(defun %mark-parents (parent children)

+ (dolist (item children)

+ (setf (gethash item *lhtml-family-tree*) parent)

+ (%mark-parents item (element-children item))))

+

+;; WARNING: This won't produce sane results for nested (match)es, because we

+;; have no way to bind in a large enough scope.

+(defmethod unify:unify ((template oh-ducks::css-selector-template)

+ (element list)

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

+ &key)

+ (if (and *lhtml-family-tree*

+ (in-hash element *lhtml-family-tree*))

+ (call-next-method)

+ (let ((*lhtml-family-tree* (make-hash-table :test 'eq)))

+ (%mark-parents nil (list element))

+ (%mark-parents element (element-children element))

+ (call-next-method))))

+

-;; FIXME: bleh... may not even be worth trying to support this

- (error "cannot get parent"))

-

-(defmethod element-ancestors ((element list))

- (error "cannot get ancestors"))

+ (multiple-value-bind (parent present?)

+ (gethash element *lhtml-family-tree*)

+ (if present?

+ parent

+ (error "unable to determine parent"))))

Mon Jan 4 06:58:51 UTC 2010 pix@kepibu.org

* Don't need &allow-other-key here

- &key &allow-other-keys)

+ &key)

-

Mon Jan 4 06:36:34 UTC 2010 pix@kepibu.org

* Don't count an+b|b|odd|even as separate items

-*** positional selectors [19/19]

- * [X] :nth-child(an+b)

- * [X] :nth-child(b)

- * [X] :nth-child(odd|even)

- * [X] :nth-last-child(an+b)

- * [X] :nth-last-child(b)

- * [X] :nth-last-child(odd|even)

+*** positional selectors [11/11]

+ * [X] :nth-child

+ * [X] :nth-last-child

- * [X] :nth-of-type(an+b)

- * [X] :nth-of-type(b)

- * [X] :nth-of-type(odd|even)

- * [X] :nth-last-of-type(an+b)

- * [X] :nth-last-of-type(b)

- * [X] :nth-last-of-type(odd|even)

+ * [X] :nth-of-type

+ * [X] :nth-last-of-type

Mon Jan 4 06:32:27 UTC 2010 pix@kepibu.org

* :empty selector

-*** positional selectors [18/19]

+*** positional selectors [19/19]

- * [ ] :empty

+ * [X] :empty

+(defclass empty-selector (simple-selector) ())

+ (#T(regexp$ (":empty") ())

+ (cons (make-instance 'empty-selector) (parse-selector &rest)))

+(defmethod subject-p ((selector empty-selector) element)

+ (= 0 (length (element-children element))))

+

+(match (#T(html (:model pt)

+ ("body :empty" . ?empty))

+ "<div><p><br></p><p>testing<i>i</i>testing</p></div>")

+ (values empty))

+

Mon Jan 4 06:32:07 UTC 2010 pix@kepibu.org

* Add *of-type selectors

-*** positional selectors [9/19]

+*** positional selectors [18/19]

- * [ ] :nth-of-type(an+b)

- * [ ] :nth-of-type(b)

- * [ ] :nth-of-type(odd|even)

- * [ ] :nth-last-of-type(an+b)

- * [ ] :nth-last-of-type(b)

- * [ ] :nth-last-of-type(odd|even)

- * [ ] :first-of-type

- * [ ] :last-of-type

+ * [X] :nth-of-type(an+b)

+ * [X] :nth-of-type(b)

+ * [X] :nth-of-type(odd|even)

+ * [X] :nth-last-of-type(an+b)

+ * [X] :nth-last-of-type(b)

+ * [X] :nth-last-of-type(odd|even)

+ * [X] :first-of-type

+ * [X] :last-of-type

- * [ ] :only-of-type

+ * [X] :only-of-type

+(defclass nth-of-type-selector (nth-child-selector) ())

+(defclass nth-last-of-type-selector (nth-of-type-selector) ())

+ (#T(regexp$ (":nth-of-type(" \s* an+b \s* ")")

+ (?asign ?a ?bsign ?b))

+ (cons (make-instance 'nth-of-type-selector

+ :asign asign :a a

+ :bsign bsign :b b)

+ (parse-selector &rest)))

+ (#T(regexp$ (":nth-last-of-type(" \s* an+b \s* ")")

+ (?asign ?a ?bsign ?b))

+ (cons (make-instance 'nth-last-of-type-selector

+ :asign asign :a a

+ :bsign bsign :b b)

+ (parse-selector &rest)))

+ (#T(regexp$ (":nth-of-type(" \s* b \s* ")")

+ (?b))

+ (cons (make-instance 'nth-of-type-selector :a 0 :b b)

+ (parse-selector &rest)))

+ (#T(regexp$ (":nth-last-of-type(" \s* b \s* ")")

+ (?b))

+ (cons (make-instance 'nth-last-of-type-selector :a 0 :b b)

+ (parse-selector &rest)))

+ (#T(regexp$ (":nth-of-type(" \s* odd/even \s* ")")

+ (?which))

+ (cons (make-instance 'nth-of-type-selector :namedp t :b which)

+ (parse-selector &rest)))

+ (#T(regexp$ (":nth-last-of-type(" \s* odd/even \s* ")")

+ (?which))

+ (cons (make-instance 'nth-last-of-type-selector :namedp t :b which)

+ (parse-selector &rest)))

+ (#T(regexp$ (":first-of-type") ())

+ (cons (make-instance 'nth-of-type-selector :a 0 :b 1)

+ (parse-selector &rest)))

+ (#T(regexp$ (":last-of-type") ())

+ (cons (make-instance 'nth-last-of-type-selector :a 0 :b 1)

+ (parse-selector &rest)))

+ (#T(regexp$ (":only-of-type") ())

+ (list* (make-instance 'nth-of-type-selector :a 0 :b 1)

+ (make-instance 'nth-last-of-type-selector :a 0 :b 1)

+ (parse-selector &rest)))

+(defmethod subject-p ((selector nth-of-type-selector) element)

+ (when-let* ((arg (selector-arg selector))

+ (parent (element-parent element)))

+ (an+b? (car arg) (cdr arg) element

+ (remove-if-not (rcurry #'element-type-equal (element-type element))

+ (element-children parent)))))

+

+(defmethod subject-p ((selector nth-last-of-type-selector) element)

+ (when-let* ((arg (selector-arg selector))

+ (parent (element-parent element)))

+ (an+b? (car arg) (cdr arg) element

+ (reverse

+ (remove-if-not (rcurry #'element-type-equal (element-type element))

+ (element-children parent))))))

+

+(match (#t(html (:model dom)

+ (":nth-last-of-type(2)" . ?first)

+ (":nth-of-type(2)" . ?last))

+ "<div><span>1</span><i>i</i><span>2</span><i>i</i></div>")

+ (values first last))

+

- ("i:only-child" . ?i))

+ ("i:only-child" . ?i)

+ ("i:only-of-type" . ?i-type))

- (values i))

+ (values i i-type))

Mon Jan 4 05:59:48 UTC 2010 pix@kepibu.org

* "lispier" regexps, l*last-child stuff

Probably against best practices to commit monolithic patches, but this

is still an unreleased library, so I don't care.

Not really sure I care for the sexp-based regexps, but they do make it

easy to use the same regexp bits across several places, and I don't

have a lexer/parser handy, so they'll have to do for now.

-*** positional selectors [3/13]

- * [X] :nth-child(n)

- * [X] :nth-child(xn+y)

- * [ ] :nth-last-child

- * [ ] :nth-last-child(xn+y)

+*** positional selectors [9/19]

+ * [X] :nth-child(an+b)

+ * [X] :nth-child(b)

+ * [X] :nth-child(odd|even)

+ * [X] :nth-last-child(an+b)

+ * [X] :nth-last-child(b)

+ * [X] :nth-last-child(odd|even)

- * [ ] :last-child

- * [ ] :nth-of-type

- * [ ] :nth-last-of-type

+ * [X] :last-child

+ * [ ] :nth-of-type(an+b)

+ * [ ] :nth-of-type(b)

+ * [ ] :nth-of-type(odd|even)

+ * [ ] :nth-last-of-type(an+b)

+ * [ ] :nth-last-of-type(b)

+ * [ ] :nth-last-of-type(odd|even)

- * [ ] :only-child

+ * [X] :only-child

- (concatenate 'string "^(.*?)" regexp "$")

+ (cond

+ ((stringp regexp)

+ (concatenate 'string "^(.*?)" regexp "$"))

+ ((listp regexp)

+ `(:sequence :start-anchor

+ (:register (:non-greedy-repetition 0 nil :everything))

+ ,@regexp

+ :end-anchor))

+ (t (error "Unknown regexp format.")))

-

+(defmethod initialize-instance :after ((selector nth-child-selector)

+ &key (asign "+") a

+ (bsign "+") b

+ namedp)

+ (setf (slot-value selector 'arg)

+ (if namedp

+ (cons 2 (if (string-equal "odd" b) 1 0))

+ (cons (parse-integer (format nil "~a~a" asign (or a 1)))

+ (parse-integer (format nil "~a~a" bsign (or b 0)))))))

+

+(cl-ppcre:define-parse-tree-synonym \s*

+ (:non-greedy-repetition 0 nil :whitespace-char-class))

+(cl-ppcre:define-parse-tree-synonym \s+

+ (:greedy-repetition 1 nil :whitespace-char-class))

+(cl-ppcre:define-parse-tree-synonym sign

+ (:char-class #\+ #\-))

+(cl-ppcre:define-parse-tree-synonym sign?

+ (:greedy-repetition 0 1 sign))

+(cl-ppcre:define-parse-tree-synonym integer

+ (:greedy-repetition 1 nil :digit-class))

+(cl-ppcre:define-parse-tree-synonym name

+ (:greedy-repetition 1 nil (:char-class :word-char-class #\-)))

+(cl-ppcre:define-parse-tree-synonym $name

+ (:register name))

+(cl-ppcre:define-parse-tree-synonym an+b

+ (:sequence

+ (:register sign?) (:greedy-repetition 0 1 (:register integer))

+ #\n \s*

+ (:register sign?) \s* (:greedy-repetition 0 1 (:register integer))))

+(cl-ppcre:define-parse-tree-synonym b

+ (:register (:sequence sign? integer)))

+(cl-ppcre:define-parse-tree-synonym odd/even

+ (:register (:alternation "odd" "even")))

+

- (#T(regexp$ "[ ]*[~][ ]*" ())

+ (#T(regexp$ (\s* #\~ \s*) ())

- (#T(regexp$ "[ ]*[+][ ]*" ())

+ (#T(regexp$ (\s* #\+ \s*) ())

- (#T(regexp$ "[ ]*[>][ ]*" ())

+ (#T(regexp$ (\s* #\> \s*) ())

- (#T(regexp$ "[ ]+" ())

+ (#T(regexp$ (\s+) ())

- (#T(regexp$ ":nth-child\\([ ]*([+-]?)([0-9]+)?n[ ]*([+-])[ ]*([0-9]+)?[ ]*\\)" (?asign ?a ?bsign ?b))

+ (#T(regexp$ (":nth-child(" \s* an+b \s* ")")

+ (?asign ?a ?bsign ?b))

- :arg (cons (funcall (if (string= "-" asign) #'- #'+)

- (if (stringp a) (parse-integer a) 1))

- (funcall (if (string= "-" bsign) #'- #'+)

- (if (stringp b) (parse-integer b) 0))))

+ :asign asign :a a

+ :bsign bsign :b b)

+ (parse-selector &rest)))

+ (#T(regexp$ (":nth-last-child(" \s* an+b \s* ")")

+ (?asign ?a ?bsign ?b))

+ (cons (make-instance 'nth-last-child-selector

+ :asign asign :a a

+ :bsign bsign :b b)

- (#T(regexp$ ":nth-child\\([ ]*([+-]?[0-9]+)[ ]*\\)" (?b))

- (cons (make-instance 'nth-child-selector :arg (cons 0 (parse-integer b))) (parse-selector &rest)))

+ (#T(regexp$ (":nth-child(" \s* b \s* ")")

+ (?b))

+ (cons (make-instance 'nth-child-selector :a 0 :b b)

+ (parse-selector &rest)))

+ (#T(regexp$ (":nth-last-child(" \s* b \s* ")")

+ (?b))

+ (cons (make-instance 'nth-last-child-selector :a 0 :b b)

+ (parse-selector &rest)))

- (#T(regexp$ ":nth-child\\([ ]*(odd|even)[ ]*\\)" (?which))

- (cons (make-instance 'nth-child-selector :arg (cons 2 (if (string-equal "odd" which) 1 0)))

+ (#T(regexp$ (":nth-child(" \s* odd/even \s* ")")

+ (?which))

+ (cons (make-instance 'nth-child-selector :namedp t :b which)

+ (parse-selector &rest)))

+ (#T(regexp$ (":nth-last-child(" \s* odd/even \s* ")")

+ (?which))

+ (cons (make-instance 'nth-last-child-selector :namedp t :b which)

- (#T(regexp$ ":first-child" ())

- (cons (make-instance 'nth-child-selector :arg (cons 0 1)) (parse-selector &rest)))

- (#T(regexp$ "[#](\\w+)" (?id))

+ ;; Everybody else

+ (#T(regexp$ (":first-child") ())

+ (cons (make-instance 'nth-child-selector :a 0 :b 1)

+ (parse-selector &rest)))

+ (#T(regexp$ (":last-child") ())

+ (cons (make-instance 'nth-last-child-selector :a 0 :b 1)

+ (parse-selector &rest)))

+ (#T(regexp$ (":only-child") ())

+ (list* (make-instance 'nth-child-selector :a 0 :b 1)

+ (make-instance 'nth-last-child-selector :a 0 :b 1)

+ (parse-selector &rest)))

+ (#T(regexp$ (#\# $name) (?id))

- (#T(regexp$ "[\\.](\\w+)" (?class))

+ (#T(regexp$ (#\. $name) (?class))

- (#T(regexp$ "(\\w+)" (?type))

+ (#T(regexp$ ($name) (?type))

- (#T(regexp$ "\\*" ())

+ (#T(regexp$ (#\*) ())

-;; Hrm... would something like this make things more or less clear?

-;#t(lex$ (":nth-child(" :s? (?a :int) "n" :s? (or #\+ #\-) :s? (?b :int) :s? ")"))

-;#t(lex$ ("#" (?id :identifier)))

-;#t(lex$ (?type :identifier))

-

- (when (subject-p element selector) (list element))

+ (when (subject-p selector element) (list element))

+(defun an+b? (a b element siblings)

+ (when-let* ((pos (1+ (position element siblings :test #'eq))))

+ ;; pos = An + B

+ (cond

+ ;; pos = 0n + B

+ ((= 0 a) (= b pos))

+ ;; (pos - B)/A = n

+ (t (and (zerop (mod (- pos b) a))

+ (not (minusp (/ (- pos b) a))))))))

+

- (when-let* ((parent (element-parent element))

- (pos (position element (funcall (typecase selector

- (nth-last-child-selector #'reverse)

- (nth-child-selector #'identity))

- (element-children parent)) :test #'eq)))

- (let ((pos (1+ pos))

- (a (car (selector-arg selector)))

- (b (cdr (selector-arg selector))))

- ;; pos = An + B

- (cond

- ;; pos = 0n + B

- ((= 0 a) (= b pos))

- ;; (pos - B)/A = n

- (t (and (zerop (mod (- pos b) a))

- (not (minusp (/ (- pos b) a)))))))))

+ (when-let* ((arg (selector-arg selector))

+ (parent (element-parent element)))

+ (an+b? (car arg) (cdr arg) element (element-children parent))))

+

+(defmethod subject-p ((selector nth-last-child-selector) element)

+ (when-let* ((arg (selector-arg selector))

+ (parent (element-parent element)))

+ (an+b? (car arg) (cdr arg) element (reverse (element-children parent)))))

- (element-classes element)

- :test #'string=))

+ (element-classes element)

+ :test #'string=))

+(match (#T(html (:model dom)

+ ("div:nth-last-child(1)" . ?div)

+ ("div:last-child" . ?d2))

+ "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values div d2))

+

+(match (#T(html (:model dom)

+ ("i:only-child" . ?i))

+ "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values i))

+

Mon Jan 4 01:07:02 UTC 2010 pix@kepibu.org

* subject-p makes more sense as (selector, element)

For future reference, I used the following code to do this automatically, plus a

few minor manual edits (e.g., swapping rcurry and curry):

(defun seek-forward (term)

(defun swap-args ()

-(defgeneric subject-p (element selector))

+(defgeneric subject-p (selector element))

-(defmethod subject-p (element (selector type-selector))

+(defmethod subject-p ((selector type-selector) element)

-(defmethod subject-p (element (selector id-selector))

+(defmethod subject-p ((selector id-selector) element)

-(defmethod subject-p (element (selector nth-child-selector))

+(defmethod subject-p ((selector nth-child-selector) element)

-(defmethod subject-p (element (selector class-selector))

+(defmethod subject-p ((selector class-selector) element)

-(defmethod subject-p (element (selector universal-selector))

+(defmethod subject-p ((selector universal-selector) element)

-(defmethod subject-p (element (selector %implicit-element-selector))

+(defmethod subject-p ((selector %implicit-element-selector) element)

-(defmethod subject-p (element (selector list))

- (every (curry #'subject-p element) selector))

+(defmethod subject-p ((selector list) element)

+ (every (rcurry #'subject-p element) selector))

-(defmethod subject-p (element (selector child-combinator))

- (subject-p (element-parent element) (matcher selector)))

+(defmethod subject-p ((selector child-combinator) element)

+ (subject-p (matcher selector) (element-parent element)))

-(defmethod subject-p (element (selector descendant-combinator))

- (some (rcurry #'subject-p (matcher selector)) (element-ancestors element)))

+(defmethod subject-p ((selector descendant-combinator) element)

+ (some (curry #'subject-p (matcher selector)) (element-ancestors element)))

-(defmethod subject-p (element (selector adjacent-combinator))

+(defmethod subject-p ((selector adjacent-combinator) element)

- (subject-p (elt siblings (1- ourpos)) (matcher selector)))))

+ (subject-p (matcher selector) (elt siblings (1- ourpos))))))

-(defmethod subject-p (element (selector sibling-combinator))

+(defmethod subject-p ((selector sibling-combinator) element)

- (find-if (rcurry #'subject-p (matcher selector)) siblings :end ourpos))))

+ (find-if (curry #'subject-p (matcher selector)) siblings :end ourpos))))

Mon Jan 4 01:04:12 UTC 2010 pix@kepibu.org

* Bring element-matches-p more in line with CSS terms as subject-p

Mon Jan 4 01:03:10 UTC 2010 pix@kepibu.org

* Make subjects-of use subjects-in-list

-(defgeneric subjects-of (selector element)

- (:method (selector (element t))

- (flet ((find-in-list (elements)

- (mapcar (curry #'subjects-of selector)

- elements)))

- (nconc

- (when (element-matches-p element selector) (list element))

- (reduce #'nconc

- (find-in-list (element-children element)))))))

+(defun subjects-of (selector element)

+ (nconc

+ (when (element-matches-p element selector) (list element))

+ (subjects-in-list selector (element-children element))))

Mon Jan 4 00:11:25 UTC 2010 pix@kepibu.org

* Rename some functions to better match CSS terminology

Sat Jan 2 09:45:37 UTC 2010 pix@kepibu.org

* Add fixme

+;; FIXME: proper parsing (e.g., by using the W3C's provided FLEX and YACC bits).

Sat Jan 2 08:38:38 UTC 2010 pix@kepibu.org

* &allow-other-keys is not actually necessary

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

+(defmethod initialize-instance :after ((template css-selector-template) &key css-specifiers parent)

- &key &allow-other-keys)

+ &key)

- &key &allow-other-keys)

+ &key)

- &key &allow-other-keys)

+ &key)

- &key &allow-other-keys)

+ &key)

- &key &allow-other-keys)

+ &key)

Fri Jan 1 05:06:19 UTC 2010 pix@kepibu.org

* Patch went in to cl-unification, so no longer need warning

-(warn "parse-selector currently relies on a patch which has not yet made ~

- it in to cl-unification. Be sure to apply the patch from ~

- <http://common-lisp.net/pipermail/cl-unification-devel/attachments/20091201/d5021e15/attachment.obj> ~

- to ensure proper functioning of the \"Oh, Ducks!\" library.")

-

Mon Dec 28 10:00:30 UTC 2009 pix@kepibu.org

* Another nth-last-child

-*** positional selectors [3/12]

+*** positional selectors [3/13]

+ * [ ] :nth-last-child(xn+y)

Mon Dec 28 09:59:18 UTC 2009 pix@kepibu.org

* Minor syntactic changes

To make more modern org-modes happy. Woo.

- :(asdf:oos 'asdf:load-op :oh-ducks)

+: (asdf:oos 'asdf:load-op :oh-ducks)

- :(asdf:oos 'asdf:load-op :closure-html)

+: (asdf:oos 'asdf:load-op :closure-html)

- :(asdf:oos 'asdf:load-op :cxml)

+: (asdf:oos 'asdf:load-op :cxml)

- :#.(set-dispatch-macro-character #\# #\T 'unify::|sharp-T-reader|)

+: #.(set-dispatch-macro-character #\# #\T 'unify::|sharp-T-reader|)

- :depends-on (:oh-ducks :closure-html :cxml)

+: :depends-on (:oh-ducks :closure-html :cxml)

- #t(html ("div" (#t(regexp "f(o+)bar") . ?div)))

+: #t(html ("div" (#t(regexp "f(o+)bar") . ?div)))

- #t(html ("div" . #t(regexp "f(o+)bar" (?o))))

+: #t(html ("div" . #t(regexp "f(o+)bar" (?o))))

Sun Dec 20 08:23:57 UTC 2009 pix@kepibu.org

* Update notes

-

+** Depending Upon in ASDF Systems

+It doesn't take long before managing your dependencies upon ASDF

+systems becomes easiest by creating an ASDF system for whatever

+project you're currently engaged in. It's important to note that, in

+addition to depending upon oh-ducks, you'll also want to depend upon

+whichever library provides your desired object model and parser.

+

+For example,

+ :depends-on (:oh-ducks :closure-html :cxml)

+

-

-The goal is to support all CSS-level-3 selectors. See the below

-section "To Do > Improve Selector Support" for a list of currently

-unsupported simple selectors and combinators.

+The goal is to support all CSS-level-3 selectors. See the section

+[[*improve selector support][To Do > Improve Selector Support]] for a list of currently unsupported

+simple selectors and combinators.

Sun Dec 13 07:28:56 UTC 2009 pix@kepibu.org

* Export xml, too

- (export 'dom))

+ (export 'dom)

+ (export 'xml))

Sun Dec 13 05:32:46 UTC 2009 pix@kepibu.org

* Add some notes

-it does not generally become useful until you have also loading an

+it does not generally become useful until you have also loaded an

- #id => elements with id of "id".

+ #id => elements with id of "id"

+NOTE: selectors are currently bound in parallel. That is, given

+ #t(html (<selector-1> ...)

+ (<selector-2> ...))

+selector-1 and selector-2 do not interact. If they are both "foo", they'll

+return identical results. I often find myself wanting to also say something

+like:

+ #t(html (<selector-1> ...)

+ (<element-after-selector-1> ...))

+Ideas for a syntax to distinguish between the two cases are welcome (:mode

+parallel) vs (:mode sequential), perhaps? (Or even adjacent, sibling?)

+

+Maybe special-case string/regexp-templates, so for example

+ #t(html ("div" (#t(regexp "f(o+)bar") . ?div)))

+would match [<div>foooobar</div>]?

+

+ #t(html ("div" . #t(regexp "f(o+)bar" (?o))))

+might cause some difficulty, however--we should get a list of matched elements

+for the div selector, but the regexp variable (?o) can only match once (without

+some wacky environment merging, anyway).

Sun Dec 13 05:24:52 UTC 2009 pix@kepibu.org

* Add element-content as a prereq to matching on an element's textual content

+ #:element-content

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

+ (mapcar (lambda (node)

+ (typecase node

+ (dom:element node)

+ (dom:text (dom:data node))

+ (t (error "Unsure what to do."))))

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

+

+(defgeneric element-content (element)

+ (:documentation "Returns a string containing the contents of the element, if it contains only textual nodes, or a sequence containing all of the element's child nodes (textual nodes as strings, tag nodes as whatever they'd be under #'element-children).")

+ (:method :around ((element t))

+ (let ((val (call-next-method)))

+ (if (every #'stringp val)

+ (reduce (curry #'concatenate 'string) val)

+ val))))

+(defmethod element-content ((element list))

+ (cddr element))

+

+(defmethod element-content ((element chtml:pt))

+ (mapcar (lambda (node)

+ (cond

+ ((eq :pcdata (chtml:pt-name node))

+ (chtml:pt-attrs node))

+ (t node)))

+ (remove-if (curry #'eq :comment)

+ (chtml:pt-children element)

+ :key #'chtml:pt-name)))

+

Sun Dec 13 05:23:23 UTC 2009 pix@kepibu.org

* Ugly unbreaking of lhtml--man I hate this bit

- ((element-parent document)

+ ((ignore-errors (element-parent document)) ; bleh. element-parent breaks lhtml nodes

Sat Dec 5 07:23:38 UTC 2009 pix@kepibu.org

* Better method to do this in

-(defmethod oh-ducks::find-matching-elements (selector (element dom:document))

- (oh-ducks::find-matching-elements selector (dom:document-element element)))

+(defmethod unify:unify ((template oh-ducks::css-selector-template)

+ (document dom:document)

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

+ &key &allow-other-keys)

+ (unify:unify template (dom:document-element document) env))

+

Sat Dec 5 07:18:05 UTC 2009 pix@kepibu.org

* implicit-element is a better name than root

Also add a bit of support for sibling combinators when dealing with the

implicit element, and note a problem that crops up when dealing with

selections on a non-root element (should a simple-selector select the

element, or is there an implicit descendant combinator?).

-(defvar *effective-root* nil

- "The element to be considered as the root element during unification. Is the implicit element to be matched by combinators without a leading qualifier. E.g., \"> a\" will match <a> tags directly under *effective-root*.")

+(defvar *implicit-element* nil

+ "The element to be considered as an implicit element to be matched by combinators without a leading qualifier. E.g., \"> a\" will match <a> tags directly under *implicit-element*, and \"+ a\" will match <a> tags directly following *implicit-element*.")

-(defclass %root-selector (simple-selector) ())

-(defparameter %root-selector (make-instance '%root-selector))

+(defclass %implicit-element-selector (selector) ())

+(defparameter %implicit-element-selector (make-instance '%implicit-element-selector))

-(defmethod print-object ((selector %root-selector) stream)

+(defmethod print-object ((selector %implicit-element-selector) stream)

- (list (make-instance 'sibling-combinator :matcher (or (parse-selector &rest) %root-selector))))

+ (list (make-instance 'sibling-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))

- (list (make-instance 'adjacent-combinator :matcher (or (parse-selector &rest) %root-selector))))

+ (list (make-instance 'adjacent-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))

- (list (make-instance 'child-combinator :matcher (or (parse-selector &rest) %root-selector))))

+ (list (make-instance 'child-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))

- (list (make-instance 'descendant-combinator :matcher (or (parse-selector &rest) %root-selector))))

+ (list (make-instance 'descendant-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))

+(defun find-matching-elements-in-list (selector element-list)

+ (reduce #'nconc

+ (mapcar (curry #'find-matching-elements selector)

+ element-list)))

+

-(defmethod element-matches-p (element (selector %root-selector))

- (eq element *effective-root*))

+(defmethod element-matches-p (element (selector %implicit-element-selector))

+ (eq element *implicit-element*))

+

+;; Hello excessively long name

+(defun terminating-implicit-sibling-combinator-p (selector)

+ (typecase selector

+ ((or sibling-combinator adjacent-combinator)

+ (typecase (matcher selector)

+ (%implicit-element-selector t)

+ (list (terminating-implicit-sibling-combinator-p (car (last (matcher selector)))))))

+ (combinator (terminating-implicit-sibling-combinator-p (matcher selector)))

+ (selector nil)

+ (null nil)

+ (list (terminating-implicit-sibling-combinator-p (car (last selector))))

+ (t nil)))

-;; Note, however, that searches are strictly recursive. So a sibling

-;; combinator won't match.

-;; FIXME: should it?

+;; siblings will also match, thanks to a bit of ugly code

- "<div><i>ham</i> foo <q>bar <i>baz</i></q> quuz <i>spam</i></div>")

+ "<div><i>ham</i> foo <q>bar <i>baz</i></q> quuz <i>spam</i><q></q><i>not match</i></div>")

+(match (#T(html (:model dom)

+ ("q" . ?q))

+ "<div> foo <q>outer q <i>baz <q>inner q</q></i></q> quuz</div>")

+ (match (#t(html ("q" . ?i))

+ (first q))

+ i))

+

- (let* ((*effective-root* document)

- (val (find-matching-elements css-specifier document)))

+ (let* ((*implicit-element* document)

+ ;; FIXME: this is UGLY!

+ (val (cond

+ ((terminating-implicit-sibling-combinator-p css-specifier)

+ ;; search remaining siblings

+ (find-matching-elements-in-list

+ css-specifier

+ (rest

+ (member document

+ (when-let* ((parent (element-parent document)))

+ (element-children parent))

+ :test #'eq))))

+ ;; search subelements

+;;; FIXME: this assumes if someone passes us a node they want to find

+;;; subelements of that node. In the case of nested matches, that's probably

+;;; true, but it hardly seems fair to assume it. Really we want some sort of

+;;; descendant combinator to be sure, but the general one (#\Space) doesn't

+;;; exactly show up all that well. Somebody might assume " b" was the same as

+;;; "b" and get confused.

+ ((element-parent document)

+ (find-matching-elements-in-list css-specifier (element-children document)))

+ ;; root element includes itself

+ (t (find-matching-elements css-specifier document)))))

Fri Dec 4 05:16:28 UTC 2009 pix@kepibu.org

* Fix an odd clisp compile issue

+;; Don't bother trying to save :parser when compiling

+(defmethod make-load-form ((object css-selector-template) &optional env)

+ (declare (ignore env))

+ `(make-template ',(first (template-spec object)) ',(template-spec object)))

+

Fri Dec 4 04:47:58 UTC 2009 pix@kepibu.org

* Make descendant combinators work with an implicit parent

+(defvar *effective-root* nil

+ "The element to be considered as the root element during unification. Is the implicit element to be matched by combinators without a leading qualifier. E.g., \"> a\" will match <a> tags directly under *effective-root*.")

+

+(defclass %root-selector (simple-selector) ())

+(defparameter %root-selector (make-instance '%root-selector))

+

+(defmethod print-object ((selector %root-selector) stream)

+ (print-unreadable-object (selector stream :type t)))

+

- (list (make-instance 'sibling-combinator :matcher (parse-selector &rest))))

+ (list (make-instance 'sibling-combinator :matcher (or (parse-selector &rest) %root-selector))))

- (list (make-instance 'adjacent-combinator :matcher (parse-selector &rest))))

+ (list (make-instance 'adjacent-combinator :matcher (or (parse-selector &rest) %root-selector))))

- (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

+ (list (make-instance 'child-combinator :matcher (or (parse-selector &rest) %root-selector))))

- (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

+ (list (make-instance 'descendant-combinator :matcher (or (parse-selector &rest) %root-selector))))

+(defmethod element-matches-p (element (selector %root-selector))

+ (eq element *effective-root*))

+

+;; Sometimes, you want to match a thing inside a thing, in which case

+;; combinators should implicitly assume an unspecified right side means

+;; "whatever element I gave you".

+(match (#T(html (:model dom)

+ ("q" . ?q))

+ "<div><i>ham</i> foo <q>bar <i>baz</i></q> quuz <i>spam</i></div>")

+ (match (#t(html ("> i" . ?i))

+ (first q))

+ i))

+

+;; Note, however, that searches are strictly recursive. So a sibling

+;; combinator won't match.

+;; FIXME: should it?

+(match (#T(html (:model dom)

+ ("q" . ?q))

+ "<div><i>ham</i> foo <q>bar <i>baz</i></q> quuz <i>spam</i></div>")

+ (match (#t(html ("+ i" . ?i))

+ (first q))

+ i))

+

- (let ((val (find-matching-elements css-specifier document)))

+ (let* ((*effective-root* document)

+ (val (find-matching-elements css-specifier document)))

Thu Dec 3 03:26:59 UTC 2009 pix@kepibu.org

* declare ignored variables

+ (declare (ignore element selector))

+ (declare (ignore var pat env))

+ (declare (ignore var pat env))

Thu Dec 3 02:41:36 UTC 2009 pix@kepibu.org

* Better messages

-(warn "parse-selector currently relies on a patch which has not only ~

- not been submitted to cl-unification-devel, it has not yet ~

- been copied to penguin.")

+(warn "parse-selector currently relies on a patch which has not yet made ~

+ it in to cl-unification. Be sure to apply the patch from ~

+ <http://common-lisp.net/pipermail/cl-unification-devel/attachments/20091201/d5021e15/attachment.obj> ~

+ to ensure proper functioning of the \"Oh, Ducks!\" library.")

- (t (error "Don't know what to do with ~s and ~s." css-specifier template)))))))

+ (t (error "Don't know what to do with selector ~s and template ~s." css-specifier template)))))))

Thu Dec 3 00:12:02 UTC 2009 pix@kepibu.org

* Add sibling and adjacent combinators

- #+TODO (#T(regexp$ "[ ]*[~][ ]*" ()) (list (make-instance 'sibling-combinator :matcher (parse-selector &rest))))

- #+TODO (#T(regexp$ "[ ]*[+][ ]*" ()) (list (make-instance 'adjacent-combinator :matcher (parse-selector &rest))))

+ (#T(regexp$ "[ ]*[~][ ]*" ())

+ (list (make-instance 'sibling-combinator :matcher (parse-selector &rest))))

+ (#T(regexp$ "[ ]*[+][ ]*" ())

+ (list (make-instance 'adjacent-combinator :matcher (parse-selector &rest))))

-#+TODO

- ...)

+ (let* ((parent (element-parent element))

+ (siblings (element-children parent))

+ (ourpos (position element siblings :test #'eq)))

+ (and ourpos

+ (> ourpos 0)

+ (element-matches-p (elt siblings (1- ourpos)) (matcher selector)))))

-#+TODO

- ...)

+ (let* ((parent (element-parent element))

+ (siblings (element-children parent))

+ (ourpos (position element siblings :test #'eq)))

+ (and ourpos

+ (> ourpos 0)

+ (find-if (rcurry #'element-matches-p (matcher selector)) siblings :end ourpos))))

+(match (#T(html (:model dom)

+ ("b + i" . ?i))

+ "<div>I <b>really</b> <i>like</i> cheese. Do you not <i>dislike</i> cheese?</div>")

+ (values i))

+

+(match (#T(html (:model dom)

+ ("b ~ i" . ?i))

+ "<div>I <i>really</i> <b>like</b> cheese. Do you not <i>dislike</i> cheese?</div>")

+ (values i))

+

+

Thu Dec 3 00:07:44 UTC 2009 pix@kepibu.org

* Fix copy-paste issue.

- (list :model 'pt))

+ (list :model 'dom))

Mon Nov 30 05:04:24 UTC 2009 pix@kepibu.org

* Record idea

+;; Hrm... would something like this make things more or less clear?

+;#t(lex$ (":nth-child(" :s? (?a :int) "n" :s? (or #\+ #\-) :s? (?b :int) :s? ")"))

+;#t(lex$ ("#" (?id :identifier)))

+;#t(lex$ (?type :identifier))

+

Mon Nov 30 05:04:06 UTC 2009 pix@kepibu.org

* Work for spaces between [+-] and B

- (#T(regexp$ ":nth-child\\([ ]*([+-]?)([0-9]+)?n[ ]*([+-]?[0-9]+)?[ ]*\\)" (?asign ?a ?b))

+ (#T(regexp$ ":nth-child\\([ ]*([+-]?)([0-9]+)?n[ ]*([+-])[ ]*([0-9]+)?[ ]*\\)" (?asign ?a ?bsign ?b))

- (if (stringp b) (parse-integer b) 0)))

+ (funcall (if (string= "-" bsign) #'- #'+)

+ (if (stringp b) (parse-integer b) 0))))

Mon Nov 30 04:48:22 UTC 2009 pix@kepibu.org

* Combine nth-child variants

+(warn "parse-selector currently relies on a patch which has not only ~

+ not been submitted to cl-unification-devel, it has not yet ~

+ been copied to penguin.")

+

- ;; FIXME: fix cl-unification so it can handle non-matching groups,

- ;; so we can merge all these nth-child-selector variants

- ;; into one or two

- (#T(regexp$ ":nth-child\\([ ]*([+-]?[0-9]+)n[ ]*([+-]?[0-9]+)[ ]*\\)" (?a ?b))

- (cons (make-instance 'nth-child-selector :arg (cons (parse-integer a) (parse-integer b))) (parse-selector &rest)))

- (#T(regexp$ ":nth-child\\([ ]*([+-]?[0-9]+)n[ ]*\\)" (?a))

- (cons (make-instance 'nth-child-selector :arg (cons (parse-integer a) 0)) (parse-selector &rest)))

- (#T(regexp$ ":nth-child\\([ ]*n[ ]*([+-]?[0-9]+)[ ]*\\)" (?b))

- (cons (make-instance 'nth-child-selector :arg (cons 1 (parse-integer b))) (parse-selector &rest)))

- (#T(regexp$ ":nth-child\\([ ]*-n[ ]*([+-]?[0-9]+)[ ]*\\)" (?b))

- (cons (make-instance 'nth-child-selector :arg (cons -1 (parse-integer b))) (parse-selector &rest)))

+ ;; cyclic (An+B, n+B)

+ (#T(regexp$ ":nth-child\\([ ]*([+-]?)([0-9]+)?n[ ]*([+-]?[0-9]+)?[ ]*\\)" (?asign ?a ?b))

+ (cons (make-instance 'nth-child-selector

+ :arg (cons (funcall (if (string= "-" asign) #'- #'+)

+ (if (stringp a) (parse-integer a) 1))

+ (if (stringp b) (parse-integer b) 0)))

+ (parse-selector &rest)))

+ ;; absolute (B)

- (#T(regexp$ ":nth-child\\([ ]*odd[ ]*\\)" ())

- (cons (make-instance 'nth-child-selector :arg (cons 2 1)) (parse-selector &rest)))

- (#T(regexp$ ":nth-child\\([ ]*even[ ]*\\)" ())

- (cons (make-instance 'nth-child-selector :arg (cons 2 0)) (parse-selector &rest)))

+ ;; named (odd, even)

+ (#T(regexp$ ":nth-child\\([ ]*(odd|even)[ ]*\\)" (?which))

+ (cons (make-instance 'nth-child-selector :arg (cons 2 (if (string-equal "odd" which) 1 0)))

+ (parse-selector &rest)))

Mon Nov 30 04:10:09 UTC 2009 pix@kepibu.org

* Fix bug in element-children for sgml:pt model

- (remove-if (rcurry #'member '(:pcdata :comment) :test #'eq)

+ (remove-if (compose (rcurry #'member '(:pcdata :comment) :test #'eq) #'chtml:pt-name)

- (unless (eq :pcdata (chtml:pt-name element))

- (getf (chtml:pt-attrs element) element-attribute)))

+ (getf (chtml:pt-attrs element) element-attribute))

Mon Nov 30 04:09:10 UTC 2009 pix@kepibu.org

* Add :nth-child selector

-*** positional selectors [2/12]

+*** positional selectors [3/12]

- * [ ] :nth-child(xn+y)

+ * [X] :nth-child(xn+y)

+(defclass nth-last-child-selector (nth-child-selector) ())

- (#T(regexp$ ":nth-child\\([ ]*([0-9]+)[ ]*\\)" (?n))

- (cons (make-instance 'nth-child-selector :arg (parse-integer n)) (parse-selector &rest)))

+ ;; FIXME: fix cl-unification so it can handle non-matching groups,

+ ;; so we can merge all these nth-child-selector variants

+ ;; into one or two

+ (#T(regexp$ ":nth-child\\([ ]*([+-]?[0-9]+)n[ ]*([+-]?[0-9]+)[ ]*\\)" (?a ?b))

+ (cons (make-instance 'nth-child-selector :arg (cons (parse-integer a) (parse-integer b))) (parse-selector &rest)))

+ (#T(regexp$ ":nth-child\\([ ]*([+-]?[0-9]+)n[ ]*\\)" (?a))

+ (cons (make-instance 'nth-child-selector :arg (cons (parse-integer a) 0)) (parse-selector &rest)))

+ (#T(regexp$ ":nth-child\\([ ]*n[ ]*([+-]?[0-9]+)[ ]*\\)" (?b))

+ (cons (make-instance 'nth-child-selector :arg (cons 1 (parse-integer b))) (parse-selector &rest)))

+ (#T(regexp$ ":nth-child\\([ ]*-n[ ]*([+-]?[0-9]+)[ ]*\\)" (?b))

+ (cons (make-instance 'nth-child-selector :arg (cons -1 (parse-integer b))) (parse-selector &rest)))

+ (#T(regexp$ ":nth-child\\([ ]*([+-]?[0-9]+)[ ]*\\)" (?b))

+ (cons (make-instance 'nth-child-selector :arg (cons 0 (parse-integer b))) (parse-selector &rest)))

+ (#T(regexp$ ":nth-child\\([ ]*odd[ ]*\\)" ())

+ (cons (make-instance 'nth-child-selector :arg (cons 2 1)) (parse-selector &rest)))

+ (#T(regexp$ ":nth-child\\([ ]*even[ ]*\\)" ())

+ (cons (make-instance 'nth-child-selector :arg (cons 2 0)) (parse-selector &rest)))

- (cons (make-instance 'nth-child-selector :arg 1) (parse-selector &rest)))

+ (cons (make-instance 'nth-child-selector :arg (cons 0 1)) (parse-selector &rest)))

- (pos (position element (element-children parent) :test #'eq)))

- (= (selector-arg selector) (1+ pos))))

+ (pos (position element (funcall (typecase selector

+ (nth-last-child-selector #'reverse)

+ (nth-child-selector #'identity))

+ (element-children parent)) :test #'eq)))

+ (let ((pos (1+ pos))

+ (a (car (selector-arg selector)))

+ (b (cdr (selector-arg selector))))

+ ;; pos = An + B

+ (cond

+ ;; pos = 0n + B

+ ((= 0 a) (= b pos))

+ ;; (pos - B)/A = n

+ (t (and (zerop (mod (- pos b) a))

+ (not (minusp (/ (- pos b) a)))))))))

Mon Nov 23 13:25:26 UTC 2009 pix@kepibu.org

* Whoops

-(defmethod element-classes (element)

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

Mon Nov 23 13:19:59 UTC 2009 pix@kepibu.org

* Fail unification if no match for a selector

-* Known Bugs

-** Failure to match results in NIL, rather than a unification-failure

-#+FIXME ;; should throw 'unification-failure

+;; throws 'unification-failure

+ ((null val)

+ (error 'unification-failure

+ :format-control "Unable to unify ~s and ~s"

+ :format-arguments (list css-specifier template)))

Mon Nov 23 13:14:45 UTC 2009 pix@kepibu.org

* add FIXME test

-#+LATER

+#+FIXME ;; should throw 'unification-failure

+(match (#T(html (:model dom)

+ ("q" . ?div))

+ "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values div))

+

+#+LATER?

Mon Nov 23 13:14:00 UTC 2009 pix@kepibu.org

* Error when unable to parse CSS selector

-** Does not error on unknown CSS selectors

- (cons (make-instance 'universal-selector) (parse-selector &rest)))))

+ (cons (make-instance 'universal-selector) (parse-selector &rest)))

+ (t (unless (string= selector "")

+ (error "Unable to to parse selector: ~s" selector)))))

Mon Nov 23 13:13:22 UTC 2009 pix@kepibu.org

* Start documentation

+* Purpose

+"Oh, Ducks!" is an extension to cl-unification to make parsing

+structured documents easy, using CSS selectors.

+* Installation

+** Prerequisites

+ + cl-unification

+ + cl-ppcre

+ + split-sequence

+ + alexandria

+ + asdf-system-connections

+ * closure-html

+ * cxml

+[+] Mandatory [*] Optional

+** Loading

+Loading "Oh, Ducks!" is just like loading any other ASDF system.

+However, because it does not mandate a particular HTML or XML parser,

+it does not generally become useful until you have also loading an

+HTML/XML parsing library such as cxml or closure-html.

+

+Start with:

+ :(asdf:oos 'asdf:load-op :oh-ducks)

+If you would like to use the built-in support for parsing via

+closure-html (which you almost certainly do), you'll also want to load

+closure-html:

+ :(asdf:oos 'asdf:load-op :closure-html)

+And, if you want to use DOM objects provided by cxml:

+ :(asdf:oos 'asdf:load-op :cxml)

+

+** Load-order Caveats

+closure-html and cl-unification each define competing readers on #t.

+To avoid load-order issues resulting in an indeterminate reader on #t,

+you'll probably want to add

+ :#.(set-dispatch-macro-character #\# #\T 'unify::|sharp-T-reader|)

+to the top of any file which uses cl-unification's reader templates.

+

+Please feel free to submit patches to closure-html and cl-unification

+to fix this problem.

+* Usage

+The combination of oh-ducks and closure-html provides an HTML template

+for use with cl-unification, and has the following syntax:

+

+ (match (#t(html [(:model <model>)]

+ <selectors>+)

+ <document>)

+ &body)

+ selectors := (<selector> . <binding>) |

+ (<selector> . <template>) |

+ (<selector> <selectors>+)

+ document := <parsed-document> | <document-to-be-parsed>

+

+:model is only necessary for unparsed documents (e.g., a pathname or string).

+

+** Examples

+

+(match (#T(html (:model lhtml)

+ ("#id" . ?div))

+ "<div id=\"id\">I <i>like</i> cheese.</div>")

+ (car div)) =>

+ (:div ((:id "id")) "I " (:i () "like") " cheese.")

+

+(match (#T(html (:model dom)

+ ("i" . #t(list ?j ?i))

+ ("span>i" . ?span))

+ "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values i span)) =>

+ #<ELEMENT i "not">,

+ (#<ELEMENT i "cheese">)

+

+** Selectors

+

+The goal is to support all CSS-level-3 selectors. See the below

+section "To Do > Improve Selector Support" for a list of currently

+unsupported simple selectors and combinators.

+

+Each selector should result in the same elements which would be

+affected by the same CSS selector. That is,

+ #id => elements with id of "id".

+ .foo.bar => elements with both "foo" and "bar" classes

+ div => all <div>s

+and so forth.

+

+*** Limitations

+

+Currently, selector terms are limited to alphanumeric characters, and

+do not support CSS-style character escapes. Patches welcome!

+

+** Included Object Models

+*** LHTML (closure-html)

+A list-based structure provided by closure-html. Cannot be used by

+selectors which require asking about parent or sibling objects.

+*** PT (closure-html)

+A structure-based structure provided by closure-html.

+*** DOM (cxml)

+DOM objects as provided by cxml and defined by the W3C.

+* Extending

+** Adding an object model

+While the supported models should generally be sufficient, you can add

+your own fairly easily. All models are expected to implement the

+generic functions in <traversal/interface.lisp>. See the other files

+under the traversal/ directory for examples.

+

+You might also want to see chtml.lisp and cxml.lisp.

+** Adding a selector or combinator

+see <selectors.lisp>. Generally, you should add a class which is a

+subclass of combinator or simple-selector, augment parse-selector with

+an appropriate regular expression, and define a method on

+element-matches-p.

+

+I also recommend submitting a patch. Other people might want to use

+that selector, too!

+* Known Bugs

+** Does not error on unknown CSS selectors

+** Failure to match results in NIL, rather than a unification-failure

+** Submit patch to cl-unification to add (enable/disable-template-reader) functions

+** Submit patch to closure-html to add (enable/disable-reader) functions

+** non-css templates (e.g., for matching on text of element)?

Mon Nov 23 13:02:12 UTC 2009 pix@kepibu.org

* Import when-let*, too

- #:rcurry))

+ #:rcurry

+ #:when-let*))

- (alexandria:when-let* ((parent (element-parent element))

- (pos (position element (element-children parent) :test #'eq)))

+ (when-let* ((parent (element-parent element))

+ (pos (position element (element-children parent) :test #'eq)))

Mon Nov 23 13:01:50 UTC 2009 pix@kepibu.org

* Indentation

- :components ((:file "lhtml")

- (:file "pt")))))

+ :components ((:file "lhtml")

+ (:file "pt")))))

- :components ((:file "dom")))))

+ :components ((:file "dom")))))

Mon Nov 23 11:54:01 UTC 2009 pix@kepibu.org

* Cut out a few warnings from cl-unification

+(defmethod unify::occurs-in-p ((var symbol) (pat dom:element) env)

+ nil)

+

+(defmethod unify::occurs-in-p ((var symbol) (pat chtml:pt) env)

+ nil)

+

Mon Nov 23 11:38:12 UTC 2009 pix@kepibu.org

* No longer needed

- (format t "cc:: el: ~s, s: ~s~%" (element-parent element) selector)

-(defun merge-environments (env1 env2)

- (assert (or (unify::empty-environment-p env1)

- (equal (unify::environment-variables env1)

- (unify::environment-variables env2))))

- (format t "ev1: ~s, ev2: ~s~%" (unify::environment-values env1) (unify::environment-values env2))

- (format t "q: ~s~%" (unify::find-variable-value '?i env1))

- (unify::fill-environment (unify::environment-variables env1)

- (mapcar (lambda (a b) (format t "a: ~s, b: ~s~%" a b) (append a b))

- (unify::environment-values env1)

- (unify::environment-values env2))

- (make-empty-environment)))

-

Mon Nov 23 11:36:20 UTC 2009 pix@kepibu.org

* Don't return a dom:document as parent

-(defmethod element-parent ((element dom:document))

- nil)

- (dom:parent-node element))

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

+ (unless (typep parent 'dom:document)

+ parent)))

Mon Nov 23 11:33:15 UTC 2009 pix@kepibu.org

* :first-child and :nth-child(n) selectors

-*** positional selectors

- * [ ] :nth-child

+*** positional selectors [2/12]

+ * [X] :nth-child(n)

+ * [ ] :nth-child(xn+y)

- * [ ] :first-child

+ * [X] :first-child

-*** attribute selectors

+*** attribute selectors [0/7]

+(defclass nth-child-selector (simple-selector) ())

+

+(defmethod print-object ((selector universal-selector) stream)

+ (format stream "#<universal-selector>"))

- (#T(regexp$ "[ ]*[>][ ]*" ()) (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

- (#T(regexp$ "[ ]+" ()) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

- ;; simple selector

- (#T(regexp$ "[#](\\w+)" (?id)) (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

- (#T(regexp$ "[\\.](\\w+)" (?class)) (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))

- (#T(regexp$ "(\\w+)" (?type)) (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))

- (#T(regexp$ "\\*" ()) (cons (make-instance 'universal-selector) (parse-selector &rest)))))

+ (#T(regexp$ "[ ]*[>][ ]*" ())

+ (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

+ (#T(regexp$ "[ ]+" ())

+ (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

+ ;; simple selectors

+ (#T(regexp$ ":nth-child\\([ ]*([0-9]+)[ ]*\\)" (?n))

+ (cons (make-instance 'nth-child-selector :arg (parse-integer n)) (parse-selector &rest)))

+ (#T(regexp$ ":first-child" ())

+ (cons (make-instance 'nth-child-selector :arg 1) (parse-selector &rest)))

+ (#T(regexp$ "[#](\\w+)" (?id))

+ (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

+ (#T(regexp$ "[\\.](\\w+)" (?class))

+ (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))

+ (#T(regexp$ "(\\w+)" (?type))

+ (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))

+ (#T(regexp$ "\\*" ())

+ (cons (make-instance 'universal-selector) (parse-selector &rest)))))

+(defmethod element-matches-p (element (selector nth-child-selector))

+ (alexandria:when-let* ((parent (element-parent element))

+ (pos (position element (element-children parent) :test #'eq)))

+ (= (selector-arg selector) (1+ pos))))

+

+(match (#T(html (:model dom)

+ ("div:first-child" . ?div)

+ ("i:nth-child(1)" . ?i))

+ "<div>I do <i>not</i> <i>like</i> cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values div i))

+

Mon Nov 23 10:24:02 UTC 2009 pix@kepibu.org

* Status commit; fix unification

- ("i" . ?i);#t(list ?j ?i))

+ ("i" . #t(list ?j ?i))

+

-#+(or)

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

- (declare (ignore attribute element))

- nil)

+

-#+(or)

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

- (declare (ignore element))

- nil)

+

-#+(or)

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

- (declare (ignore element))

- nil)

-#+FIXME

-(defmethod element-parent ((element list))

- (let ((parent (car *ancestors*)))

- (if (some (alexandria:curry #'eq element) (element-children parent))

- parent

- (error "unable to determine parent"))))

-#+FIXME

-(defmethod element-ancestors ((element list))

- *ancestors*)

+

- :do

- (let ((val (find-matching-elements css-specifier document)))

- (cond

- ;; FIXME: make possible to say things like ("div" . #t(list ?first-div &rest))

- #+(or)

- ((typep template 'css-selector-template)

- (format t "hey! ~s~%" template)

- (let ((menv (reduce #'merge-environments

- (mapcar (curry #'unify template)

- val))))

- (unify::fill-environment (unify::environment-variables menv)

- (unify::environment-values menv)

- env)))

- ((unify::template-p template)

- (let ((menv (reduce #'merge-environments

- (mapcar (curry #'unify template)

- val))))

- (unify::fill-environment (unify::environment-variables menv)

- (unify::environment-values menv)

- env))

- #+(or)

- (unify template val env)

- #+(or)

- (loop :for element :in val

- :do (unify template element env)))

- ((unify::variablep template)

- ;; *ahem* FIXME: this makes ("a" ("b" . ?b)) possible,

- ;; but will cause the wrong thing to happen for [_$_]

- ;; ("a" ("b" . ?b) ("#b" . ?b))

- ;(alexandria:if-let ((varval (find-variable-value template env)))

- ; (nconc varval val)

- (unify::var-unify template val env)

- #+(or)

- (unify::extend-environment template val env));)

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

+ :do (typecase template

+ ;; CSS selectors work backwards, not forwards

+ (css-selector-template

+ (unify template document env))

+ (t

+ (let ((val (find-matching-elements css-specifier document)))

+ (cond

+ ((unify::template-p template)

+ (unify template val env))

+ ((unify::variablep template)

+ (unify::var-unify template val env))

+ (t (error "Don't know what to do with ~s and ~s." css-specifier template)))))))

Sat Nov 21 18:31:09 UTC 2009 pix@kepibu.org

* Tired, probably doing stupid things

- ("div" ("i" . ?i)

- ("span" . ?span)))

+ ("div" (">i" . ?i)

+ ;("i" . #t(list ?j ?i))

+ ("span>i" . ?span)))

+(match (#T(html (:model dom)

+ ("i" . ?i);#t(list ?j ?i))

+ ("span>i" . ?span))

+ "<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

+ (values i span))

+

-(match (#t(lhtml ("div::content" . #t(regexp+ "^f(o+)" (?o))))

+(match (#t(html ("div::content" . #t(regexp+ "^f(o+)" (?o))))

+(defun merge-environments (env1 env2)

+ (assert (or (unify::empty-environment-p env1)

+ (equal (unify::environment-variables env1)

+ (unify::environment-variables env2))))

+ (format t "ev1: ~s, ev2: ~s~%" (unify::environment-values env1) (unify::environment-values env2))

+ (format t "q: ~s~%" (unify::find-variable-value '?i env1))

+ (unify::fill-environment (unify::environment-variables env1)

+ (mapcar (lambda (a b) (format t "a: ~s, b: ~s~%" a b) (append a b))

+ (unify::environment-values env1)

+ (unify::environment-values env2))

+ (make-empty-environment)))

+

+ (declare (optimize debug))

- (setf

- env

- #+(or) (if (null val) (cerror "continue" "null!"))

- (format t "mel: ~s, css: ~s, tpl: ~s~%" val css-specifier template)

+ ;; FIXME: make possible to say things like ("div" . #t(list ?first-div &rest))

+ #+(or)

+ ((typep template 'css-selector-template)

+ (format t "hey! ~s~%" template)

+ (let ((menv (reduce #'merge-environments

+ (mapcar (curry #'unify template)

+ val))))

+ (unify::fill-environment (unify::environment-variables menv)

+ (unify::environment-values menv)

+ env)))

- #+(or) (format t "template-p~%")

+ (let ((menv (reduce #'merge-environments

+ (mapcar (curry #'unify template)

+ val))))

+ (unify::fill-environment (unify::environment-variables menv)

+ (unify::environment-values menv)

+ env))

+ #+(or)

- #+(or) ;; FIXME: in the case of multiple items in val, this will only return one.

+ #+(or)

- :do (setf env (unify template element env))

- :finally (return env)))

+ :do (unify template element env)))

- #+(or) (format t "variable-p~%")

- (unify::extend-environment template val env))

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

+ ;; *ahem* FIXME: this makes ("a" ("b" . ?b)) possible,

+ ;; but will cause the wrong thing to happen for [_$_]

+ ;; ("a" ("b" . ?b) ("#b" . ?b))

+ ;(alexandria:if-let ((varval (find-variable-value template env)))

+ ; (nconc varval val)

+ (unify::var-unify template val env)

+ #+(or)

+ (unify::extend-environment template val env));)

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

Sat Nov 21 16:12:13 UTC 2009 pix@kepibu.org

* Status commit

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

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

+(defclass html-template (css-selector-template) ())

-(defmethod document-parser ((template lhtml-template))

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

-(defmethod document-parser ((template pt-template))

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

+(add-handler 'pt 'chtml:make-pt-builder)

+(add-handler 'lhtml 'chtml:make-lhtml-builder)

-(defmethod make-template-for-parser ((parser (eql 'lhtml)) spec)

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

-(defmethod make-template-for-parser ((parser (eql :lhtml)) spec)

- (make-template-for-parser 'lhtml spec))

+(unless *default-parser*

+ (setf *default-parser* (rcurry #'chtml:parse (get-handler-for-model 'pt))))

-(defmethod make-template-for-parser ((parser (eql 'pt)) spec)

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

-(defmethod make-template-for-parser ((parser (eql :pt)) spec)

- (make-template-for-parser 'pt spec))

-

-(unless *default-parser* (setf *default-parser* 'pt))

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

+ (destructuring-bind (&key parser model)

+ (append (when (%spec-includes-opts spec) (second spec))

+ (list :model 'pt))

+ (make-instance 'html-template

+ :parser (or parser (rcurry #'chtml:parse (get-handler-for-model model)))

+ :spec spec)))

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

+(defclass xml-template (css-selector-template) ())

-(defmethod document-parser ((template dom-template))

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

+(add-handler 'dom 'cxml-dom:make-dom-builder)

-(defmethod make-template-for-parser ((parser (eql 'dom)) spec)

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

-(defmethod make-template-for-parser ((parser (eql :dom)) spec)

- (make-template-for-parser 'dom spec))

+(unless *default-parser*

+ (setf *default-parser* (rcurry #'cxml:parse (get-handler-for-model 'dom))))

-(unless *default-parser* (setf *default-parser* 'dom))

+(defmethod make-template ((kind (eql 'xml)) (spec cons))

+ (destructuring-bind (&key parser model)

+ (append (when (%spec-includes-opts spec) (second spec))

+ (list :model 'pt))

+ (make-instance 'xml-template

+ :parser (or parser (rcurry #'cxml:parse (get-handler-for-model model)))

+ :spec spec)))

-** working lhtml/xmls support

+** working lhtml/xmls support [1/2]

+ * [X] non-descendant cases (class, id, etc.)

+ * [ ] selectors involving descendants

- ;; TODO: submit a patch for cl-unification to use

- ;; asdf-system-connections. Getting an unmodified version of

- ;; cl-unification to load the cl-ppcre stuff is a PITA.

- :components

- ((:file "interface")))

+ :components ((:file "interface")))

- :components (#+FIXME (:file "lhtml")

+ :components ((:file "lhtml")

+(defpackage #:oh-ducks.functional

+ (:import-from #:alexandria . #1=(

+ #:compose

+ #:curry

+ #:rcurry))

+ (:export . #1#))

+

- (:use #:cl)

+ (:use #:cl #:oh-ducks.functional)

- (:use #:cl #:unify #:oh-ducks.traversal)

- (:import-from #:alexandria

- #:compose

- #:curry

- #:rcurry)

+ (:use #:cl #:unify #:oh-ducks.functional #:oh-ducks.traversal)

- (format stream "#<combinator>"))

+ (format stream "#<~s ~s>" (class-name (class-of selector)) (matcher selector)))

-(defgeneric find-matching-elements (selector elements))

-

-(defmethod find-matching-elements (selector (elements list))

- (nconc

- (remove-if-not (rcurry #'element-matches-p selector) elements)

- (reduce #'nconc

- (mapcar (compose (curry #'find-matching-elements selector) #'element-children)

- elements))))

-

-(defmethod find-matching-elements (selector (elements t))

- (find-matching-elements selector (list elements)))

+(defgeneric find-matching-elements (selector element)

+ (:method (selector (element t))

+ (flet ((find-in-list (elements)

+ (mapcar (curry #'find-matching-elements selector)

+ elements)))

+ (nconc

+ (when (element-matches-p element selector) (list element))

+ (reduce #'nconc

+ (find-in-list (element-children element)))))))

+ (format t "cc:: el: ~s, s: ~s~%" (element-parent element) selector)

- ((parser :initarg :parser :initform nil) ;; subtype generally determines parser

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

-;; FIXME: split html-template and xml-template into the cxml/chtml stuff; then,

-;; split dom-template into dom-html-template and dom-xml-template.

-;; Actually, just ditch the subtypes entirely, and build new objects with

-;; a specified handler type.

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

-

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

-

+(defvar *model-handler-map* nil "A mapping between model types and handler functions.")

+(defun add-handler (model handler)

+ (push (cons model handler) *model-handler-map*))

+(defun get-handler-for-model (model)

+ (let ((handler (cdr (assoc model *model-handler-map*))))

+ (typecase handler

+ (null nil)

+ (function (funcall handler))

+ (symbol (funcall (symbol-function handler)))

+ (t handler))))

-(defgeneric document-parser (template)

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

-

-(defmethod document-parser ((template css-selector-template))

- (slot-value template 'parser))

-

-(defgeneric make-template-for-parser (parser spec)

- (:documentation "Returns a template of the appropriate type for a given parser.")

- (:method ((parser t) spec)

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

- (:method ((parser null) spec)

- (declare (ignore parser spec))

- (error "No parser specified.")))

-

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

- (destructuring-bind (&key parser)

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

- (second spec)

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

- (make-template-for-parser parser spec)))

-

- (match (#T(html ("#id" . ?div))

+ (match (#T(html (:model lhtml) ("#id" . ?div))

- (match (#T(html (".fish" . ?divs)

+ (match (#T(html (:model lhtml)

+ (".fish" . ?divs)

- (match (#T(html ("div>i" . ?i))

+ (match (#T(html (:model dom)

+ ("div>i" . ?i))

- (match (#T(html ("div" ("> i" . ?i)

- ("span>i" . ?span)))

+ (match (#T(html (:model dom)

+ ("div" ("i" . ?i)

+ ("span" . ?span)))

+(defmethod oh-ducks::find-matching-elements (selector (element dom:document))

+ (oh-ducks::find-matching-elements selector (dom:document-element element)))

+

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

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

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

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

+ (remove-if-not #'dom:element-p (coerce (dom:child-nodes element) 'list)))

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

+ nil)

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

+#+(or)

+#+(or)

+#+(or)

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

+ (:documentation "Returns a sequence of element's child tags."))

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

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

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

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

- (cddr element))

+ (remove-if-not (lambda (x) (and (listp x) (keywordp (car x))))

+ (cddr element)))

-(defmethod element-attribute ((element-attribute symbol) (element list))

- (cadr (assoc element-attribute (cadr element))))

-(defmethod element-attribute ((element-attribute string) (element list))

- (element-attribute (intern (string-upcase element-attribute) :keyword) element))

+(defmethod element-attribute ((attribute symbol) (element list))

+ (cadr (assoc attribute (cadr element))))

+(defmethod element-attribute ((attribute string) (element list))

+ (element-attribute (intern (string-upcase attribute) :keyword) element))

- (chtml:pt-children element))

+ (remove-if (rcurry #'member '(:pcdata :comment) :test #'eq)

+ (chtml:pt-children element)))

- (let ((val (find-matching-elements css-specifier document)))

+ (setf

+ env

+ (let ((val (find-matching-elements css-specifier document)))

+ #+(or) (if (null val) (cerror "continue" "null!"))

+ (format t "mel: ~s, css: ~s, tpl: ~s~%" val css-specifier template)

- ((unify::template-p template) (unify template val env))

- ((unify::variablep template) (unify::extend-environment template val env))

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

+ ((unify::template-p template)

+ #+(or) (format t "template-p~%")

+ (unify template val env)

+ #+(or) ;; FIXME: in the case of multiple items in val, this will only return one.

+ (loop :for element :in val

+ :do (setf env (unify template element env))

+ :finally (return env)))

+ ((unify::variablep template)

+ #+(or) (format t "variable-p~%")

+ (unify::extend-environment template val env))

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

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

+ (unify template (funcall (slot-value template 'parser) document) env))

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

-

+ (unify template (funcall (slot-value template 'parser) document) env))

Fri Nov 20 13:09:18 UTC 2009 pix@kepibu.org

* Add fixme

+;; FIXME: split html-template and xml-template into the cxml/chtml stuff; then,

+;; split dom-template into dom-html-template and dom-xml-template.

+;; Actually, just ditch the subtypes entirely, and build new objects with

+;; a specified handler type.

Thu Nov 19 06:25:36 UTC 2009 pix@kepibu.org

* Moar CSS selectors, fewer explicit lambdas

-*** :nth-child

-*** :first-child

-*** :last-child

-*** universal selector (*)

+*** positional selectors

+ * [ ] :nth-child

+ * [ ] :nth-last-child

+ * [ ] :first-child

+ * [ ] :last-child

+ * [ ] :nth-of-type

+ * [ ] :nth-last-of-type

+ * [ ] :first-of-type

+ * [ ] :last-of-type

+ * [ ] :only-child

+ * [ ] :only-of-type

+ * [ ] :empty

+*** attribute selectors

+ * [ ] attribute-present [att]

+ * [ ] attribute-equal [att=val]

+ * [ ] attribute-member [att~=val]

+ * [ ] attribute-lang [att|=val]

+ * [ ] attribute-begins [att^=val]

+ * [ ] attribute-ends [att$=val]

+ * [ ] attribute-contains [att*=val]

+*** :not(...)

+** namespace support(?)

- :depends-on (:cl-unification :cl-ppcre :split-sequence)

+ :depends-on (:cl-unification :cl-ppcre :split-sequence :alexandria)

+ (:import-from #:alexandria

+ #:compose

+ #:curry

+ #:rcurry)

-#+FIXME ; is this the right name?

+ #+TODO (#T(regexp$ "[ ]*[~][ ]*" ()) (list (make-instance 'sibling-combinator :matcher (parse-selector &rest))))

+ #+TODO (#T(regexp$ "[ ]*[+][ ]*" ()) (list (make-instance 'adjacent-combinator :matcher (parse-selector &rest))))

- #+TODO

- (remove-if-not (lambda (el) (element-matches-p el selector)) elements)

+ (remove-if-not (rcurry #'element-matches-p selector) elements)

- (remove-if #'null

- (mapcar (lambda (element) (find-matching-elements selector (element-children element)))

- elements)))))

+ (mapcar (compose (curry #'find-matching-elements selector) #'element-children)

+ elements))))

+(defmethod element-matches-p (element (selector universal-selector))

+ t)

+

- (every (lambda (s) (element-matches-p element s)) selector))

+ (every (curry #'element-matches-p element) selector))

- (some (lambda (a) (element-matches-p a (matcher selector))) (element-ancestors element)))

+ (some (rcurry #'element-matches-p (matcher selector)) (element-ancestors element)))

+

+#+TODO

+(defmethod element-matches-p (element (selector adjacent-combinator))

+ ...)

+

+#+TODO

+(defmethod element-matches-p (element (selector sibling-combinator))

+ ...)

+ (declare (ignore parser spec))

Wed Nov 18 10:25:48 UTC 2009 pix@kepibu.org

* Try to set a sensible default for *default-parser*

+(unless *default-parser* (setf *default-parser* 'pt))

+

+(unless *default-parser* (setf *default-parser* 'dom))

+

Wed Nov 18 10:23:22 UTC 2009 pix@kepibu.org

* Add notes file

+#-*-mode: org;-*-

+* To Do

+** working lhtml/xmls support

+** write documentation

+** improve selector support

+*** :nth-child

+*** :first-child

+*** :last-child

+*** universal selector (*)

+*** any others?

Wed Nov 18 10:23:05 UTC 2009 pix@kepibu.org

* Status commit; split to avoid absolute dependency on cxml and closure-html

+(in-package #:oh-ducks)

+

+;; avoid conflicting with 'sgml:pt

+(eval-when (:compile-toplevel :load-toplevel :execute)

+ (import 'closure-html:pt))

+(eval-when (:compile-toplevel :load-toplevel :execute)

+ (export 'pt)

+ (export 'lhtml))

+

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

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

+

+(defmethod document-parser ((template lhtml-template))

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

+(defmethod document-parser ((template pt-template))

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

+

+(defmethod make-template-for-parser ((parser (eql 'lhtml)) spec)

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

+(defmethod make-template-for-parser ((parser (eql :lhtml)) spec)

+ (make-template-for-parser 'lhtml spec))

+

+(defmethod make-template-for-parser ((parser (eql 'pt)) spec)

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

+(defmethod make-template-for-parser ((parser (eql :pt)) spec)

+ (make-template-for-parser 'pt spec))

+(in-package #:oh-ducks)

+

+(eval-when (:compile-toplevel :load-toplevel :execute)

+ (export 'dom))

+

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

+

+(defmethod document-parser ((template dom-template))

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

+

+(defmethod make-template-for-parser ((parser (eql 'dom)) spec)

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

+(defmethod make-template-for-parser ((parser (eql :dom)) spec)

+ (make-template-for-parser 'dom spec))

+#+(or fixme todo)

+(cerror "Continue anyway."

+ "The author of \"Oh, ducks!\" tends to use #+FIXME and #+TODO to ~

+ mark things as being in-progress. At least one of these exists ~

+ in *features*, which may cause unusual behavior.")

+

+(eval-when (:compile-toplevel :load-toplevel :execute)

+ (asdf:operate 'asdf:load-op 'asdf-system-connections))

+

-(asdf:defsystem oh-ducks

+(defsystem oh-ducks

- :depends-on (:cl-unification :cl-ppcre :cxml :closure-html :split-sequence)

+ :depends-on (:cl-unification :cl-ppcre :split-sequence)

- ;; FIXME: ordering

- #+(or) (:file "tests")

- (:module traversal

+ (:module "traversal"

- ((:file "interface")

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

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

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

+ ((:file "interface")))

- (:file "unification-templates")))

+ (:file "templates")

+ (:file "unify")

+ #+FIXME (:file "tests")))

+

+(defsystem-connection ducks+closure-html

+ :requires (:oh-ducks :closure-html)

+ :components ((:file "chtml")

+ (:module "traversal"

+ :components (#+FIXME (:file "lhtml")

+ (:file "pt")))))

+

+(defsystem-connection ducks+cxml

+ :requires (:oh-ducks :cxml)

+ :components ((:file "cxml")

+ (:module "traversal"

+ :components ((:file "dom")))))

+(defpackage #:oh-ducks.traversal

+ (:use #:cl)

+ (:export #:element-children

+ #:element-parent

+ #:element-attribute

+ #:element-type

+

+ #:element-id

+ #:element-classes

+ #:element-type-equal

+ #:element-ancestors))

+

- (:use #:cl #:unify)

- (:export #:lhtml))

+ (:use #:cl #:unify #:oh-ducks.traversal)

+ (:export ;; template machinery

+ #:*default-parser*

+ #:html

+ ))

-#||

-Okay, here's how I figure selectors should work:

-* breadth-first traversal through the document

-* collect nodes (elements) which match the selector(s)

-

-Matching selectors:

-- The original plan was to start with the first selector in our

- list and work our way into the document.

-- Another plan might be to start with the last selector in our

- list and work our way up the document tree.

-- Yet another option would be to utilize the recursive structure

- of the document in our search, keeping track of which nodes

- match which selectors as we traverse into the document.

- Though, by that description, I'm not sure I'm clever enough to

- actually make it work.

-We have to work our way through the entire document structure

-anyway, which means starting from the outside and working our way

-in won't gain us any efficiency, as I had originally thought.

-

-For example, given a structure of

- (html

- (body

- (p ((class "foo")) "text")

- (p () (span ((class "bar")) "more text"))))

-and a selector of

- html p>span.bar

-we would walk the document tree asking first

- "Does this element have class 'bar'?"

-and only if that is true, continuing to ask

- "Is this a 'span' element?"

- "Is this element a child of a 'p' element?"

- "Is that 'p' element a descendant of an 'html' element?"

-

-I note, however, that a fully-reversed ordering should not be strictly

-necessary--we really only need reverse at the combinators. So we

-could also ask:

- "Is this a 'span' element?"

- "Is it of the 'bar' class?"

- "Is it a child of a 'p' element?"

- "Is that 'p' element a descendant of an 'html' element?"

-

-Hrm... how does ScrAPI do this? Or any of the other projects which

-offer element selection by CSS selector?

-||#

- #+(or)

+ #+TODO

+(in-package #:oh-ducks)

+

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

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

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

+ ))

+

+(defclass xml-template (css-selector-template) ()) ;; parses xml

+

+(defclass html-template (css-selector-template) ()) ;; parses html

+

+

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

+

+(defgeneric document-parser (template)

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

+

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

+ (slot-value template 'parser))

+

+(defgeneric make-template-for-parser (parser spec)

+ (:documentation "Returns a template of the appropriate type for a given parser.")

+ (:method ((parser t) spec)

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

+ (:method ((parser null) spec)

+ (error "No parser specified.")))

+

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

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

+

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

+ (destructuring-bind (&key parser)

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

+ (second spec)

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

+ (make-template-for-parser parser spec)))

+

+(defun combine-selectors (selector parent)

+ (let ((combinator (car (last selector))))

+ (cond

+ ((null parent)

+ selector)

+ ((combinator-p combinator)

+ (setf (slot-value combinator 'matcher) parent)

+ selector)

+ (t

+ (nconc selector (list (make-instance 'descendant-combinator :matcher parent)))))))

+

+(defun parse-specifiers (specs template parent)

+ (loop :for (css-specifier . rest) :in specs

+ :for selector = (combine-selectors (parse-selector css-specifier) parent)

+ :collect (cons selector

+ (cond

+ ((unify::template-p rest) rest)

+ ((unify::variablep rest) rest)

+ ((consp rest)

+ (make-instance (class-of template)

+ :spec (list* (first (template-spec template)) rest)

+ :css-specifiers rest

+ :parent selector))))))

+

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

+ (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))))

+#.(set-dispatch-macro-character #\# #\T 'unify::|sharp-T-reader|)

+

+#+(or) (setq *default-parser* 'pt)

+

-(in-package #:oh-ducks)

+(in-package #:oh-ducks.traversal)

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

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

+ (declare (ignore attribute element))

+ nil)

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

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

+ (declare (ignore element))

+ nil)

+ (declare (ignore element))

-(in-package #:oh-ducks)

+(in-package #:oh-ducks.traversal)

-(in-package #:oh-ducks)

+(in-package #:oh-ducks.traversal)

-(in-package #:oh-ducks)

+(in-package #:oh-ducks.traversal)

-;; FIXME: rather than having separate

-;; #t(pt-html ...) [_$_]

-;; #t(lhtml ...)

-;; etc.

-;; syntaxes for every possible parser, have a single

-;; #t(html [(:parser parser-function)] ...)

-;; which uses the value of :parser to handle parsing. Or, if no

-;; 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)

- ((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) ())

-

-(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))

- (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* ((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))))

-

-(defun combine-selectors (selector parent)

- (let ((combinator (car (last selector))))

- (cond

- ((null parent)

- selector)

- ((combinator-p combinator)

- (setf (slot-value combinator 'matcher) parent)

- selector)

- (t

- (nconc selector (list (make-instance 'descendant-combinator :matcher parent)))))))

-

-(defun parse-specifiers (specs template parent)

- (loop :for (css-specifier . rest) :in specs

- :for selector = (combine-selectors (parse-selector css-specifier) parent)

- :collect (cons selector

- (cond

- ((unify::template-p rest) rest)

- ((unify::variablep rest) rest)

- ((consp rest)

- (make-instance (class-of template)

- :spec (list* (first (template-spec template)) rest)

- :css-specifiers rest

- :parent selector))))))

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

* status commit; add cxml:dom support

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

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

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

+(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))

-(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."))

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

+ (:documentation "Equivalent in spirit to (element-attribute :id 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.")

- (: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.")

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

+

- (#+(or)

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

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

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

+(defclass dom-template (xml-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))))

- (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)))))

- (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)))))

+ (declare (ignore env))

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

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

- (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)

- (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))

+

Wed Nov 18 07:35:08 UTC 2009 pix@kepibu.org

* Forgot to rename the .asd file

Wed Nov 18 07:21:49 UTC 2009 pix@kepibu.org

* The library finally has a name!

Mon Nov 16 09:02:50 UTC 2009 pix@kepibu.org

* Status commit

- (format t "rex: ~s, ~s~%"

- (concatenate 'string "^(.*?)" regexp "$")

- (append '(?&rest) vars))

+#+FIXME ; is this the right name?

+(defclass universal-selector (simple-selector) ())

-;; forwards

-#+(or)

- (#T(regexp+ "^[ ]*[>][ ]*" ()) (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

- (#T(regexp+ "^[ ]+" ()) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

+ (#T(regexp$ "[ ]*[>][ ]*" ()) (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

+ (#T(regexp$ "[ ]+" ()) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

- (#T(regexp+ "^(\\w+)" (?type)) (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))

- (#T(regexp+ "^[#](\\w+)" (?id)) (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

- (#T(regexp+ "^[\\.](\\w+)" (?class)) (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))))

-

-;; backwards

-;; FIXME: somehow, selector is ending up as "NIL"

-(defun parse-selector (selector)

- (when (string= "NIL" selector) (error "selector is nil"))

- (format t "selector: ~s~%" selector)

- (macrolet ((prest (x) `(format t "rest~s: ~S~%" ,x &rest)))

- (match-case (selector)

- ;; combinators

- (#T(regexp$ "[ ]*[>][ ]*" ()) (prest 'a) (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

- (#T(regexp$ "[ ]+" ()) (prest 'b) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

- ;; simple selector

- (#T(regexp$ "[#](\\w+)" (?id)) (prest 'c) (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

- (#T(regexp$ "[\\.](\\w+)" (?class)) (prest 'd) (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))

- (#T(regexp$ "(\\w+)" (?type)) (prest 'e) (cons (make-instance 'type-selector :arg type) (parse-selector &rest))))))

-

-

-;; FIXME: the find/matches split seems to be causing me some mental

-;; trouble. I'm not sure how to handle combinators now. (Not that I

-;; was doing very well with them before.)

-;;

-;; Should probably map this out on a whiteboard. I'm not doing very

-;; well with just trying to hack it.

+ (#T(regexp$ "[#](\\w+)" (?id)) (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

+ (#T(regexp$ "[\\.](\\w+)" (?class)) (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))

+ (#T(regexp$ "(\\w+)" (?type)) (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))

+ #+(or)

+ (#T(regexp$ "\\*" ()) (cons (make-instance 'universal-selector) (parse-selector &rest)))))

-(defmethod find-matching-elements ((selectors list) element)

- (call-next-method)

- #+(or)

- (prog1

- (when (element-matches-p selectors element)

- (when (every (alexandria:rcurry #'find-matching-elements element) selectors)

- element)

- (format t "lv fme~%"))))

-

-(defmethod find-matching-elements ((selector selector) (elements list))

- (call-next-method))

-

- (format t "in fme: ~s~%" elements)

- (prog1

- elements))))

- (format t "lv fme~%")))

+ elements)))))

-;; for lhtml compatibility

-#||

-(defvar *ancestors* nil)

-(defmethod find-matching-elements ((selector selector) (elements cons))

- (if (keywordp (car elements))

- (remove-if #'null

- (nconc

- (when (element-matches-p elements selector) (list elements))

- (let ((*ancestors* (cons elements nil)))

- (mapcar (lambda (el) (find-matching-elements selector el))

- (element-children elements)))))

- (call-next-method)))

-||#

-

-(defmethod element-matches-p ((element t) (selector selector))

- (error "ar?")

- nil)

-(defmethod element-matches-p :around ((element string) (selector selector))

- (call-next-method))

-

-(defmethod element-matches-p :around ((element t) (selector selector))

- (call-next-method)

- #+(or)

- (format t "c: ~s, ~s, ~s~%"

- (class-of element)

- (class-of selector)

- (find-method #'element-matches-p '() (list (find-class t) (class-of selector)) nil))

- #+(or)

- (when (find-method #'element-matches-p '() (mapcar #'class-of (list element selector)) nil)

- (call-next-method)))

-

- ;(cerror "hrm" element)

- (format t "id: ~s~%" (element-id element))

-#+(or)

-(defmethod element-matches-p (element (selector child-combinator))

- (plusp (length (find-matching-elements selector (element-children element)))))

-

-#+TODO

-(defmethod element-matches-p (element (selector descendant-combinator))

- (flet ((all-match (element) (every (lambda (m) (element-matches-p element m)) (matcher selector))))

- #+nil

- (when (all-match element) element)

- (let ((elements (cddr element)))

- (format t "el: ~s~%" elements)

- (case (selector-arg selector)

- (:direct (loop :for element :in elements

- :when (all-match element)

- :collect element))

- (t (css-collect-elements selector elements))))))

-

- (match (#T(html ("div" ("> i" . ?i)))

+ (match (#T(html ("div" ("> i" . ?i)

+ ("span>i" . ?span)))

- i))

+ (values i span)))

+#+FIXME

+(defmethod element-parent ((element list))

+ (error "cannot get parent"))

+#+FIXME

+(defmethod element-ancestors ((element list))

+ (error "cannot get ancestors"))

+;; FIXME: rather than having separate

+;; #t(pt-html ...) [_$_]

+;; #t(lhtml ...)

+;; etc.

+;; syntaxes for every possible parser, have a single

+;; #t(html [(:parser parser-function)] ...)

+;; which uses the value of :parser to handle parsing. Or, if no

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

+;; in.

- #+(or)

- (parent :reader parent-template :initarg :parent :initform nil)

-(defmethod parent-template ((template t)) nil)

-

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

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

- (setf (slot-value template 'specifiers)

- (parse-specifiers specifiers-and-vars 'lhtml-template))))

-

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

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

- (format t "sss: ~s~%" selector)

- (format t "ok!~%")

- ((consp rest) (make-instance (class-of template) :css-specifiers rest :parent selector))))))

+ ((consp rest)

+ (make-instance (class-of template)

+ :spec (list* (first (template-spec template)) rest)

+ :css-specifiers rest

+ :parent selector))))))

- (format t "ts: ~s~%" (template-spec template))

- (format t "spec: ~s, tpl: ~s~%" css-specifier template)

- (format t "val: ~s~%" val)

Mon Nov 16 08:14:42 UTC 2009 pix@kepibu.org

* Status commit

+ (format t "rex: ~s, ~s~%"

+ (concatenate 'string "^(.*?)" regexp "$")

+ (append '(?&rest) vars))

- (concatenate 'string "^(.*)" regexp "$")

+ (concatenate 'string "^(.*?)" regexp "$")

-(defclass simple-selector (simple-selector)

+(defclass simple-selector (selector)

+

+(defgeneric combinator-p (object)

+ (:method ((ob combinator)) t)

+ (:method ((ob t)) nil))

+

+(defmethod print-object ((selector combinator) stream)

+ (format stream "#<combinator>"))

+

-(defmethod initialize-instance :after ((template selector) &key)

+(defmethod initialize-instance :after ((template combinator) &key)

+#+(or)

-#+(or)

+;; FIXME: somehow, selector is ending up as "NIL"

+ (when (string= "NIL" selector) (error "selector is nil"))

+ (format t "selector: ~s~%" selector)

+ (macrolet ((prest (x) `(format t "rest~s: ~S~%" ,x &rest)))

- (#T(regexp$ "[ ]*[>][ ]*" ()) (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

- (#T(regexp$ "[ ]+" ()) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

+ (#T(regexp$ "[ ]*[>][ ]*" ()) (prest 'a) (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

+ (#T(regexp$ "[ ]+" ()) (prest 'b) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

- (#T(regexp$ "(\\w+)" (?type)) (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))

- (#T(regexp$ "[#](\\w+)" (?id)) (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

- (#T(regexp$ "[\\.](\\w+)" (?class)) (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))))

+ (#T(regexp$ "[#](\\w+)" (?id)) (prest 'c) (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

+ (#T(regexp$ "[\\.](\\w+)" (?class)) (prest 'd) (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))

+ (#T(regexp$ "(\\w+)" (?type)) (prest 'e) (cons (make-instance 'type-selector :arg type) (parse-selector &rest))))))

-(defmethod find-matching-elements ((selector simple-selector) (elements list))

- (nconc

- (remove-if-not (lambda (el) (element-matches-p selector el)) elements)

- (remove-if #'null

- (mapcar (lambda (element) (find-matching-elements selector (element-children element)))

- elements)))

+(defmethod find-matching-elements ((selectors list) element)

+ (call-next-method)

- (loop :for element :in elements

- :when (element-matches-p selector element)

- :collect element))

+ (prog1

+ (when (element-matches-p selectors element)

+ (when (every (alexandria:rcurry #'find-matching-elements element) selectors)

+ element)

+ (format t "lv fme~%"))))

-#+(or) ;; hrm...this doesn't seem right... doesn't handle combinators!

-(defmethod find-matching-elements ((selector list) (elements list))

- (flet ((all-selectors-match (element)

- (every (lambda (s) (element-matches-p s element)) selector)))

- (remove-if-not #'all-selectors-match elements))

- #+(or)

- (loop :for element :in elements

- :when (every (lambda (s) (element-matches-p m element)) selector)

- :collect element))

+(defmethod find-matching-elements ((selector selector) (elements list))

+ (call-next-method))

-(defvar *parent*)

-;; if *parent* is equal to element-parent, we've found a child element.

-;; But, uh, who sets *parent*?

-(defmethod find-matching-elements ((selector child-combinator) (elements list))

- )

+(defmethod find-matching-elements (selector (elements list))

+ (format t "in fme: ~s~%" elements)

+ (prog1

+ (nconc

+ (remove-if-not (lambda (el) (element-matches-p el selector)) elements)

+ (reduce #'nconc

+ (remove-if #'null

+ (mapcar (lambda (element) (find-matching-elements selector (element-children element)))

+ elements))))

+ (format t "lv fme~%")))

-(defvar *ancestor*)

+(defmethod find-matching-elements (selector (elements t))

+ (find-matching-elements selector (list elements)))

+;; for lhtml compatibility

+#||

+(defvar *ancestors* nil)

+(defmethod find-matching-elements ((selector selector) (elements cons))

+ (if (keywordp (car elements))

+ (remove-if #'null

+ (nconc

+ (when (element-matches-p elements selector) (list elements))

+ (let ((*ancestors* (cons elements nil)))

+ (mapcar (lambda (el) (find-matching-elements selector el))

+ (element-children elements)))))

+ (call-next-method)))

+||#

-(defgeneric element-matches-p (selector element))

+(defgeneric element-matches-p (element selector))

-(defmethod element-matches-p ((selector selector) (element t))

+(defmethod element-matches-p ((element t) (selector selector))

+ (error "ar?")

+(defmethod element-matches-p :around ((element string) (selector selector))

+ (call-next-method))

-(defmethod element-matches-p ((selector type-selector) element)

+(defmethod element-matches-p :around ((element t) (selector selector))

+ (call-next-method)

+ #+(or)

+ (format t "c: ~s, ~s, ~s~%"

+ (class-of element)

+ (class-of selector)

+ (find-method #'element-matches-p '() (list (find-class t) (class-of selector)) nil))

+ #+(or)

+ (when (find-method #'element-matches-p '() (mapcar #'class-of (list element selector)) nil)

+ (call-next-method)))

+

+(defmethod element-matches-p (element (selector type-selector))

-(defmethod element-matches-p ((selector id-selector) element)

+(defmethod element-matches-p (element (selector id-selector))

+ ;(cerror "hrm" element)

+ (format t "id: ~s~%" (element-id element))

-(defmethod element-matches-p ((selector class-selector) element)

+(defmethod element-matches-p (element (selector class-selector))

-(defmethod element-matches-p ((selector child-combinator) element)

+#+(or)

+(defmethod element-matches-p (element (selector child-combinator))

-(defmethod element-matches-p ((selector descendant-combinator) element)

- (flet ((all-match (element) (every (lambda (m) (element-matches-p m element)) (matcher selector))))

+(defmethod element-matches-p (element (selector descendant-combinator))

+ (flet ((all-match (element) (every (lambda (m) (element-matches-p element m)) (matcher selector))))

+

+(defmethod element-matches-p (element (selector list))

+ (every (lambda (s) (element-matches-p element s)) selector))

+

+(defmethod element-matches-p (element (selector child-combinator))

+ (element-matches-p (element-parent element) (matcher selector)))

+

+(defmethod element-matches-p (element (selector descendant-combinator))

+ (some (lambda (a) (element-matches-p a (matcher selector))) (element-ancestors element)))

+;; FIXME: the switch to chtml:pt nodes means our #'equalp no longer

+;; works.

- (match (#T(lhtml ("#id" . ?div))

+ (match (#T(html ("#id" . ?div))

- (match (#T(lhtml (".fish" . ?divs)

- (".pig" . ?pig))

+ (match (#T(html (".fish" . ?divs)

+ (".pig" . ?pig))

- (match (#T(lhtml ("div" ("i" . ?i)))

+ (match (#T(html ("div" ("i" . ?i)))

- (match (#T(lhtml ("div>i" . ?i))

+ (match (#T(html ("div>i" . ?i))

-;; FIXME: it seems our options for this are either to return incorrect results

-;; ((:i not) (:i cheese)) or make ?i fail to acknowledge all available

-;; items under div>i. This probably means my strategy of implementation

-;; is faulty.

- (match (#T(lhtml ("div" ("> i" . ?i)))

+ (match (#T(html ("div" ("> i" . ?i)))

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

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

+

+(defgeneric element-ancestors (element)

+ (:documentation "The result of calling element-parent repeatedly up the document tree.")

+ (:method (element)

+ (let ((parent (element-parent element)))

+ (when parent

+ (cons parent (element-ancestors parent))))))

+;; FIXME: bleh... may not even be worth trying to support this

- ;; FIXME: figure out how to do this. Maybe we can do something involving

- ;; signals and restart-cases. Ask "are you my mother?" up the stack, and

- ;; only error if everybody says no.

- (error "Unable to locate element-parent or suitable guardian."))

+ (let ((parent (car *ancestors*)))

+ (if (some (alexandria:curry #'eq element) (element-children parent))

+ parent

+ (error "unable to determine parent"))))

+(defmethod element-ancestors ((element list))

+ *ancestors*)

- (getf (chtml:pt-attrs element) element-attribute))

+ (unless (eq :pcdata (chtml:pt-name element))

+ (getf (chtml:pt-attrs element) element-attribute)))

+ #+(or)

+ (parent :reader parent-template :initarg :parent :initform nil)

+(defmethod parent-template ((template t)) nil)

+

-(defun parse-specifiers (specs template-kind)

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

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

+ (setf (slot-value template 'specifiers)

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

+

+(defun combine-selectors (selector parent)

+ (format t "sss: ~s~%" selector)

+ (let ((combinator (car (last selector))))

+ (cond

+ ((null parent)

+ selector)

+ ((combinator-p combinator)

+ (format t "ok!~%")

+ (setf (slot-value combinator 'matcher) parent)

+ selector)

+ (t

+ (nconc selector (list (make-instance 'descendant-combinator :matcher parent)))))))

+

+(defun parse-specifiers (specs template parent)

- :collect (cons (make-instance 'css-specifier :spec css-specifier)

+ :for selector = (combine-selectors (parse-selector css-specifier) parent)

+ :collect (cons selector

- ((consp rest) (make-instance template-kind :css-specifiers rest))))))

+ ((consp rest) (make-instance (class-of template) :css-specifiers rest :parent selector))))))

- (let ((val (css-select css-specifier document)))

+ (let ((val (find-matching-elements css-specifier document)))

+

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

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

+ &key &allow-other-keys)

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

Sun Nov 15 14:25:29 UTC 2009 pix@kepibu.org

* Status commit

Move the CSS-selector-specific stuff into its own file.

Still don't have it working, of course. Bleh.

+ (:file "selectors")

+;; for parsing front-to-back

+(defmethod make-template ((kind (eql 'regexp^)) (spec cons))

+ (destructuring-bind (re-kwd regexp &optional vars &rest keys)

+ spec

+ (declare (ignore re-kwd))

+ (make-instance 'unify::regular-expression-template

+ :spec (list* 'unify::regexp

+ (concatenate 'string "^" regexp "(.*)$")

+ (append vars '(?&rest))

+ keys))))

+

+;; For parsing back-to-front

+(defmethod make-template ((kind (eql 'regexp$)) (spec cons))

+ (destructuring-bind (re-kwd regexp &optional vars &rest keys)

+ spec

+ (declare (ignore re-kwd))

+ (make-instance 'unify::regular-expression-template

+ :spec (list* 'unify::regexp

+ (concatenate 'string "^(.*)" regexp "$")

+ (append '(?&rest) vars)

+ keys))))

+

+

+#||

+Okay, here's how I figure selectors should work:

+* breadth-first traversal through the document

+* collect nodes (elements) which match the selector(s)

+

+Matching selectors:

+- The original plan was to start with the first selector in our

+ list and work our way into the document.

+- Another plan might be to start with the last selector in our

+ list and work our way up the document tree.

+- Yet another option would be to utilize the recursive structure

+ of the document in our search, keeping track of which nodes

+ match which selectors as we traverse into the document.

+ Though, by that description, I'm not sure I'm clever enough to

+ actually make it work.

+We have to work our way through the entire document structure

+anyway, which means starting from the outside and working our way

+in won't gain us any efficiency, as I had originally thought.

+

+For example, given a structure of

+ (html

+ (body

+ (p ((class "foo")) "text")

+ (p () (span ((class "bar")) "more text"))))

+and a selector of

+ html p>span.bar

+we would walk the document tree asking first

+ "Does this element have class 'bar'?"

+and only if that is true, continuing to ask

+ "Is this a 'span' element?"

+ "Is this element a child of a 'p' element?"

+ "Is that 'p' element a descendant of an 'html' element?"

+

+I note, however, that a fully-reversed ordering should not be strictly

+necessary--we really only need reverse at the combinators. So we

+could also ask:

+ "Is this a 'span' element?"

+ "Is it of the 'bar' class?"

+ "Is it a child of a 'p' element?"

+ "Is that 'p' element a descendant of an 'html' element?"

+

+Hrm... how does ScrAPI do this? Or any of the other projects which

+offer element selection by CSS selector?

+||#

+(in-package #:css-selector-unifier)

+

+#.(set-dispatch-macro-character #\# #\T 'unify::|sharp-T-reader|)

+

+(defclass selector (unify::string-template)

+ ((matcher :reader matcher :initarg :matcher)))

+

+(defgeneric selector-p (object)

+ (:method ((ob selector)) t)

+ (:method ((ob t)) nil))

+

+(defclass simple-selector (simple-selector)

+ ((arg :reader selector-arg :initarg :arg)))

+

+(defmethod print-object ((selector simple-selector) stream)

+ (format stream "#<selector ~s>" (selector-arg selector)))

+

+(defclass combinator (selector) ())

+(defclass child-combinator (combinator) ())

+(defclass descendant-combinator (combinator) ())

+(defclass adjacent-combinator (combinator) ())

+(defclass sibling-combinator (combinator) ())

+

+(defclass type-selector (simple-selector) ())

+(defclass id-selector (simple-selector) ())

+(defclass class-selector (simple-selector) ())

+

+(defmethod initialize-instance :after ((template selector) &key)

+ (unless (slot-boundp template 'matcher)

+ (let ((selector (template-spec template)))

+ (setf (slot-value template 'matcher) (parse-selector (string-trim " " selector))))))

+

+;; forwards

+(defun parse-selector (selector)

+ (match-case (selector)

+ ;; combinators

+ (#T(regexp+ "^[ ]*[>][ ]*" ()) (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

+ (#T(regexp+ "^[ ]+" ()) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

+ ;; simple selector

+ (#T(regexp+ "^(\\w+)" (?type)) (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))

+ (#T(regexp+ "^[#](\\w+)" (?id)) (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

+ (#T(regexp+ "^[\\.](\\w+)" (?class)) (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))))

+

+;; backwards

+#+(or)

+(defun parse-selector (selector)

+ (match-case (selector)

+ ;; combinators

+ (#T(regexp$ "[ ]*[>][ ]*" ()) (list (make-instance 'child-combinator :matcher (parse-selector &rest))))

+ (#T(regexp$ "[ ]+" ()) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest))))

+ ;; simple selector

+ (#T(regexp$ "(\\w+)" (?type)) (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))

+ (#T(regexp$ "[#](\\w+)" (?id)) (cons (make-instance 'id-selector :arg id) (parse-selector &rest)))

+ (#T(regexp$ "[\\.](\\w+)" (?class)) (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))))

+

+

+;; FIXME: the find/matches split seems to be causing me some mental

+;; trouble. I'm not sure how to handle combinators now. (Not that I

+;; was doing very well with them before.)

+;;

+;; Should probably map this out on a whiteboard. I'm not doing very

+;; well with just trying to hack it.

+

+(defgeneric find-matching-elements (selector elements))

+

+(defmethod find-matching-elements ((selector simple-selector) (elements list))

+ (nconc

+ (remove-if-not (lambda (el) (element-matches-p selector el)) elements)

+ (remove-if #'null

+ (mapcar (lambda (element) (find-matching-elements selector (element-children element)))

+ elements)))

+ #+(or)

+ (loop :for element :in elements

+ :when (element-matches-p selector element)

+ :collect element))

+

+#+(or) ;; hrm...this doesn't seem right... doesn't handle combinators!

+(defmethod find-matching-elements ((selector list) (elements list))

+ (flet ((all-selectors-match (element)

+ (every (lambda (s) (element-matches-p s element)) selector)))

+ (remove-if-not #'all-selectors-match elements))

+ #+(or)

+ (loop :for element :in elements

+ :when (every (lambda (s) (element-matches-p m element)) selector)

+ :collect element))

+

+(defvar *parent*)

+;; if *parent* is equal to element-parent, we've found a child element.

+;; But, uh, who sets *parent*?

+(defmethod find-matching-elements ((selector child-combinator) (elements list))

+ )

+

+(defvar *ancestor*)

+

+

+(defgeneric element-matches-p (selector element))

+

+(defmethod element-matches-p ((selector selector) (element t))

+ nil)

+

+(defmethod element-matches-p ((selector type-selector) element)

+ (element-type-equal element (selector-arg selector)))

+

+(defmethod element-matches-p ((selector id-selector) element)

+ (string= (element-id element) (selector-arg selector)))

+

+(defmethod element-matches-p ((selector class-selector) element)

+ (member (selector-arg selector)

+ (element-classes element)

+ :test #'string=))

+

+(defmethod element-matches-p ((selector child-combinator) element)

+ (plusp (length (find-matching-elements selector (element-children element)))))

+

+#+TODO

+(defmethod element-matches-p ((selector descendant-combinator) element)

+ (flet ((all-match (element) (every (lambda (m) (element-matches-p m element)) (matcher selector))))

+ #+nil

+ (when (all-match element) element)

+ (let ((elements (cddr element)))

+ (format t "el: ~s~%" elements)

+ (case (selector-arg selector)

+ (:direct (loop :for element :in elements

+ :when (all-match element)

+ :collect element))

+ (t (css-collect-elements selector elements))))))

-#.(set-dispatch-macro-character #\# #\T 'unify::|sharp-T-reader|)

-

-

-[_^L_][_$_]

-

-;; FIXME: rename to selector

-(defclass css-specifier (unify::string-template)

- ((matcher :reader matcher :initarg :matcher)))

-

-(defgeneric specifier-p (object)

- (:method ((ob css-specifier)) t)

- (:method ((ob t)) nil))

-

-;; FIXME: rename to simple-selector

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

- ((arg :reader selector-arg :initarg :arg)))

-

-#|| TODO

- (defclass combinator (selector) ())

- (defclass child-combinator (combinator) ())

- (defclass descendant-combinator (combinator) ())

- (defclass adjacent-combinator (combinator) ())

- (defclass sibling-combinator (combinator) ())

-||#

-

-(defmethod print-object ((selector css-selector) stream)

- (format stream "#<selector ~s>" (selector-arg selector)))

-

-(defclass css-type-selector (css-selector) ())

-(defclass css-id-selector (css-selector) ())

-(defclass css-class-selector (css-selector) ())

-

-(defclass css-descendant-selector (css-specifier css-selector) ())

-

-(defmethod initialize-instance :after ((template css-specifier) &key)

- (unless (slot-boundp template 'matcher)

- (let ((specifier (template-spec template)))

- (setf (slot-value template 'matcher) (parse-css-specifier (string-trim " " specifier))))))

-

-(defun parse-css-specifier (specifier)

- (match-case (specifier)

- ;; combinators

- (#T(regexp+ "^[ ]*[>][ ]*" ()) (list (make-instance 'css-descendant-selector :arg :direct :matcher (parse-css-specifier &rest))))

- (#T(regexp+ "^[ ]+" ()) (list (make-instance 'css-descendant-selector :arg t :matcher (parse-css-specifier &rest))))

- ;; simple selector sequence

- (#T(regexp+ "^(\\w+)" (?type)) (cons (make-instance 'css-type-selector :arg type) (parse-css-specifier &rest)))

- (#T(regexp+ "^[#](\\w+)" (?id)) (cons (make-instance 'css-id-selector :arg id) (parse-css-specifier &rest)))

- (#T(regexp+ "^[\\.](\\w+)" (?class)) (cons (make-instance 'css-class-selector :arg class) (parse-css-specifier &rest)))))

-

-;; FIXME: rename to select-subject?

-;; FIXME: make css-select methods use functions defined in traversal/implementation.lisp

-(defgeneric css-select (specifier document))

-

-;; FIXME?: move to within (css-select css-specifier cons)

-;; FIXME: Should this really be this ugly?

-(defun css-collect-elements (selector elements)

- (flet ((last-matcher () (car (last (matcher selector))))

- (all-match (element) (every (lambda (m) (css-select m element)) (matcher selector))))

- (loop :for element :in elements

- :when (all-match element)

- :if (specifier-p (last-matcher))

- :nconc (css-select (last-matcher) element)

- :else

- :collect element

- :end

- :end

- :when (consp element)

- :nconc (css-collect-elements selector (cddr element)))))

-

-(defmethod css-select ((selector css-selector) (element string))

- nil)

-

-(defmethod css-select ((selector css-specifier) (document cons))

- (css-collect-elements selector

- ;; Urg. I may be doing something wrong here. :P

- (if (and (listp document) (listp (car document)))

- document

- (list document))))

-

-

-(defmethod css-select ((selector css-type-selector) (element cons))

- (when (string-equal (car element) (selector-arg selector))

- element))

-

-(defun lhtml-attr (attr element)

- (cadr (assoc attr (cadr element))))

-

-(defmethod css-select ((selector css-id-selector) (element cons))

- (when (string= (lhtml-attr :id element) (selector-arg selector))

- element))

-

-(defmethod css-select ((selector css-class-selector) (element cons))

- (when (member (selector-arg selector)

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

- :test #'string=)

- element))

-

-(defmethod css-select ((selector css-descendant-selector) (element cons))

- (flet ((all-match (element) (every (lambda (m) (css-select m element)) (matcher selector))))

- #+nil

- (when (all-match element) element)

- (let ((elements (cddr element)))

- (format t "el: ~s~%" elements)

- (case (selector-arg selector)

- (:direct (loop :for element :in elements

- :when (all-match element)

- :collect element))

- (t (css-collect-elements selector elements))))))