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))))