(in-package #:oh-ducks)
(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 tags directly under *implicit-element*, and \"+ a\" will match tags directly following *implicit-element*.")
#.(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 (selector)
((arg :reader selector-arg :initarg :arg)))
(defmethod print-object ((selector simple-selector) stream)
(format stream "#" (selector-arg selector)))
(defclass combinator (selector) ())
(defgeneric combinator-p (object)
(:method ((ob combinator)) t)
(:method ((ob t)) nil))
(defmethod print-object ((selector combinator) stream)
(format stream "#<~s ~s>" (class-name (class-of selector)) (matcher selector)))
(defclass child-combinator (combinator) ())
(defclass descendant-combinator (combinator) ())
(defclass adjacent-combinator (combinator) ())
(defclass sibling-combinator (combinator) ())
(defclass universal-selector (simple-selector) ())
(defclass type-selector (simple-selector) ())
(defclass id-selector (simple-selector) ())
(defclass class-selector (simple-selector) ())
(defclass nth-child-selector (simple-selector) ())
(defclass nth-last-child-selector (nth-child-selector) ())
(defclass nth-of-type-selector (nth-child-selector) ())
(defclass nth-last-of-type-selector (nth-of-type-selector) ())
(defclass empty-selector (simple-selector) ())
(defclass attribute-selector (simple-selector)
((val :reader attribute-value :initarg :value)))
(defclass attribute-present-selector (attribute-selector) ())
(defclass attribute-equal-selector (attribute-selector) ())
(defclass attribute-starts-with-selector (attribute-selector) ())
(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)))))))
(defmethod print-object ((selector universal-selector) stream)
(format stream "#"))
(defmethod initialize-instance :after ((template combinator) &key)
(unless (slot-boundp template 'matcher)
(let ((selector (template-spec template)))
(setf (slot-value template 'matcher) (parse-selector (string-trim " " selector))))))
(defclass %implicit-element-selector (selector) ())
(defparameter %implicit-element-selector (make-instance '%implicit-element-selector))
(defmethod print-object ((selector %implicit-element-selector) stream)
(print-unreadable-object (selector stream :type t)))
(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")))
;; FIXME: proper parsing (e.g., by using the W3C's provided FLEX and YACC bits).
(defun parse-selector (selector)
(match-case (selector)
;; combinators
(#T(regexp$ (\s* #\~ \s*) ())
(list (make-instance 'sibling-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))
(#T(regexp$ (\s* #\+ \s*) ())
(list (make-instance 'adjacent-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))
(#T(regexp$ (\s* #\> \s*) ())
(list (make-instance 'child-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))
(#T(regexp$ (\s+) ())
(list (make-instance 'descendant-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))
;; simple selectors
;; attribute selectors
(#T(regexp$ ("[" $name "]") (?attribute))
(cons (make-instance 'attribute-present-selector :arg attribute)
(parse-selector &rest)))
(#T(regexp$ ("[" $name "=" $name "]") (?attribute ?value))
(cons (make-instance 'attribute-equal-selector :arg attribute :value value)
(parse-selector &rest)))
(#T(regexp$ ("[" $name "^=" $name "]") (?attribute ?value))
(cons (make-instance 'attribute-starts-with-selector :arg attribute :value value)
(parse-selector &rest)))
;; cyclic (An+B, n+B)
(#T(regexp$ (":nth-child(" \s* an+b \s* ")")
(?asign ?a ?bsign ?b))
(cons (make-instance 'nth-child-selector
: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)
(parse-selector &rest)))
(#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)))
;; absolute (B)
(#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-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)))
;; named (odd, even)
(#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)
(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)))
;; 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$ (":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)))
(#T(regexp$ (":empty") ())
(cons (make-instance 'empty-selector) (parse-selector &rest)))
(#T(regexp$ (#\# $name) (?id))
(cons (make-instance 'id-selector :arg id) (parse-selector &rest)))
(#T(regexp$ (#\. $name) (?class))
(cons (make-instance 'class-selector :arg class) (parse-selector &rest)))
(#T(regexp$ ($name) (?type))
(cons (make-instance 'type-selector :arg type) (parse-selector &rest)))
(#T(regexp$ (#\*) ())
(cons (make-instance 'universal-selector) (parse-selector &rest)))
(t (unless (string= selector "")
(error "Unable to to parse selector: ~s" selector)))))
(defun subjects-in-list (selector element-list)
(reduce #'nconc
(mapcar (curry #'subjects-of selector)
element-list)))
(defun subjects-of (selector element)
(nconc
(when (subject-p selector element) (list element))
(subjects-in-list selector (element-children element))))
(defgeneric subject-p (selector element))
(defmethod subject-p ((selector type-selector) element)
(element-type-equal element (selector-arg selector)))
(defmethod subject-p ((selector id-selector) element)
(string= (element-id element) (selector-arg selector)))
(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))))))))
(defmethod subject-p ((selector nth-child-selector) element)
(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)))))
(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))))))
(defmethod subject-p ((selector empty-selector) element)
(= 0 (length (element-children element))))
(defmethod subject-p ((selector class-selector) element)
(member (selector-arg selector)
(element-classes element)
:test #'string=))
(defmethod subject-p ((selector universal-selector) element)
(declare (ignore element selector))
t)
(defmethod subject-p ((selector attribute-present-selector) element)
(element-attribute (selector-arg selector) element))
(defmethod subject-p ((selector attribute-equal-selector) element)
(when-let* ((val (element-attribute (selector-arg selector) element)))
(string= val (attribute-value selector))))
(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))))
(defmethod subject-p ((selector %implicit-element-selector) element)
(eq element *implicit-element*))
(defmethod subject-p ((selector list) element)
(every (rcurry #'subject-p element) selector))
(defmethod subject-p ((selector child-combinator) element)
(subject-p (matcher selector) (element-parent element)))
(defmethod subject-p ((selector descendant-combinator) element)
(some (curry #'subject-p (matcher selector)) (element-ancestors element)))
(defmethod subject-p ((selector adjacent-combinator) element)
(let* ((parent (element-parent element))
(siblings (element-children parent))
(ourpos (position element siblings :test #'eq)))
(and ourpos
(> ourpos 0)
(subject-p (matcher selector) (elt siblings (1- ourpos))))))
(defmethod subject-p ((selector sibling-combinator) element)
(let* ((parent (element-parent element))
(siblings (element-children parent))
(ourpos (position element siblings :test #'eq)))
(and ourpos
(> ourpos 0)
(find-if (curry #'subject-p (matcher selector)) siblings :end ourpos))))
;; 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)))