713 lines
30 KiB
EmacsLisp
713 lines
30 KiB
EmacsLisp
;;; ecss-selector.el --- Generic CSS selector model -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Geekinney
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; This module parses, validates, matches, and scores CSS-like selectors over
|
|
;; either `ecss-subject' values or caller-owned values exposed through an
|
|
;; `ecss-subject-adapter'. It has no dependency on buffers or rendering code.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'seq)
|
|
(require 'subr-x)
|
|
|
|
(define-error 'ecss-error "ECSS error")
|
|
(define-error 'ecss-invalid-selector "Invalid ECSS selector" 'ecss-error)
|
|
(define-error 'ecss-invalid-subject-adapter
|
|
"Invalid ECSS subject adapter" 'ecss-error)
|
|
|
|
(cl-defstruct (ecss-subject (:constructor ecss--make-subject))
|
|
"Generic selector subject independent of a rendering consumer."
|
|
type id classes attributes states parent children)
|
|
|
|
(cl-defstruct (ecss-subject-adapter
|
|
(:constructor ecss--make-subject-adapter))
|
|
"Functions exposing caller-owned subjects to the selector engine."
|
|
type id classes attributes states parent children)
|
|
|
|
(cl-defstruct (ecss--selector-parser
|
|
(:constructor ecss--make-selector-parser))
|
|
input position length)
|
|
|
|
(defconst ecss--attribute-operators '("=" "~=" "|=" "^=" "$=" "*=")
|
|
"Supported attribute selector operators.")
|
|
|
|
(defconst ecss--selector-delimiters
|
|
'(?\s ?\t ?\n ?\r ?\f ?. ?# ?\[ ?\] ?: ?, ?> ?+ ?~ ?\( ?\) ?*
|
|
?= ?| ?^ ?$ ?' ?\" ?/)
|
|
"Characters that terminate an unescaped selector identifier.")
|
|
|
|
(defvar ecss--selector-anchor nil
|
|
"Dynamically bound subject anchoring a relative selector.")
|
|
|
|
(defun ecss--copy-boundary-data (value)
|
|
"Return a detached copy of mutable caller boundary VALUE.
|
|
Function values retain identity so executable literals remain callable."
|
|
(cond
|
|
((functionp value) value)
|
|
((hash-table-p value)
|
|
(let ((copy (copy-hash-table value)))
|
|
(clrhash copy)
|
|
(maphash
|
|
(lambda (key item)
|
|
(puthash (ecss--copy-boundary-data key)
|
|
(ecss--copy-boundary-data item)
|
|
copy))
|
|
value)
|
|
copy))
|
|
((consp value)
|
|
(cons (ecss--copy-boundary-data (car value))
|
|
(ecss--copy-boundary-data (cdr value))))
|
|
((stringp value) (copy-sequence value))
|
|
((bool-vector-p value) (copy-sequence value))
|
|
((or (vectorp value) (recordp value))
|
|
(let ((copy (copy-sequence value)))
|
|
(dotimes (index (length copy))
|
|
(aset copy index (ecss--copy-boundary-data (aref copy index))))
|
|
copy))
|
|
(t value)))
|
|
|
|
(defun ecss--adapter-callback-p (value)
|
|
"Return non-nil when VALUE is a valid adapter callback."
|
|
(functionp value))
|
|
|
|
(cl-defun ecss-subject-adapter-create
|
|
(&key type id classes attributes states parent children)
|
|
"Create a subject adapter from the supplied callbacks.
|
|
TYPE, ID, CLASSES, ATTRIBUTES, STATES, PARENT, and CHILDREN each accept one
|
|
caller-owned subject and return the named field."
|
|
(let ((callbacks (list type id classes attributes states parent children)))
|
|
(unless (cl-every #'ecss--adapter-callback-p callbacks)
|
|
(signal 'ecss-invalid-subject-adapter callbacks)))
|
|
(ecss--make-subject-adapter
|
|
:type type :id id :classes classes :attributes attributes
|
|
:states states :parent parent :children children))
|
|
|
|
(defconst ecss-default-subject-adapter
|
|
(ecss--make-subject-adapter
|
|
:type #'ecss-subject-type
|
|
:id #'ecss-subject-id
|
|
:classes #'ecss-subject-classes
|
|
:attributes #'ecss-subject-attributes
|
|
:states #'ecss-subject-states
|
|
:parent #'ecss-subject-parent
|
|
:children #'ecss-subject-children)
|
|
"Adapter for built-in `ecss-subject' values.")
|
|
|
|
(cl-defun ecss-subject-create
|
|
(&key type id classes attributes states parent children)
|
|
"Create a generic subject.
|
|
TYPE and ID identify it. CLASSES and STATES are token lists. ATTRIBUTES is
|
|
an alist. PARENT and CHILDREN establish its initial tree position."
|
|
(when (and parent (not (ecss-subject-p parent)))
|
|
(signal 'wrong-type-argument (list 'ecss-subject-p parent)))
|
|
(let ((subject (ecss--make-subject
|
|
:type (ecss--copy-boundary-data type)
|
|
:id (ecss--copy-boundary-data id)
|
|
:classes (ecss--copy-boundary-data classes)
|
|
:attributes (ecss--copy-boundary-data attributes)
|
|
:states (ecss--copy-boundary-data states))))
|
|
(ecss-subject-set-children subject children)
|
|
(when parent
|
|
(ecss-subject-set-children
|
|
parent (append (ecss-subject-children parent) (list subject))))
|
|
subject))
|
|
|
|
(defun ecss-subject-set-children (subject children)
|
|
"Replace SUBJECT's CHILDREN and maintain their parent links."
|
|
(unless (ecss-subject-p subject)
|
|
(signal 'wrong-type-argument (list 'ecss-subject-p subject)))
|
|
(unless (cl-every #'ecss-subject-p children)
|
|
(signal 'wrong-type-argument (list 'ecss-subject-p children)))
|
|
(dolist (old-child (ecss-subject-children subject))
|
|
(when (eq (ecss-subject-parent old-child) subject)
|
|
(setf (ecss-subject-parent old-child) nil)))
|
|
(setf (ecss-subject-children subject) (copy-sequence children))
|
|
(dolist (child children)
|
|
(when-let* ((old-parent (ecss-subject-parent child)))
|
|
(unless (eq old-parent subject)
|
|
(setf (ecss-subject-children old-parent)
|
|
(delq child (ecss-subject-children old-parent)))))
|
|
(setf (ecss-subject-parent child) subject))
|
|
subject)
|
|
|
|
(defun ecss--adapter-call (adapter field subject)
|
|
"Call ADAPTER callback FIELD for SUBJECT."
|
|
(funcall
|
|
(pcase field
|
|
('type (ecss-subject-adapter-type adapter))
|
|
('id (ecss-subject-adapter-id adapter))
|
|
('classes (ecss-subject-adapter-classes adapter))
|
|
('attributes (ecss-subject-adapter-attributes adapter))
|
|
('states (ecss-subject-adapter-states adapter))
|
|
('parent (ecss-subject-adapter-parent adapter))
|
|
('children (ecss-subject-adapter-children adapter)))
|
|
subject))
|
|
|
|
(defun ecss--subject-parent (subject adapter)
|
|
"Return SUBJECT's parent through ADAPTER."
|
|
(ecss--adapter-call adapter 'parent subject))
|
|
|
|
(defun ecss--subject-children (subject adapter)
|
|
"Return SUBJECT's children through ADAPTER."
|
|
(ecss--adapter-call adapter 'children subject))
|
|
|
|
(defun ecss--parser-end-p (parser)
|
|
"Return non-nil when PARSER reached the input end."
|
|
(>= (ecss--selector-parser-position parser)
|
|
(ecss--selector-parser-length parser)))
|
|
|
|
(defun ecss--parser-peek (parser &optional offset)
|
|
"Return PARSER character at optional OFFSET without consuming it."
|
|
(let ((position (+ (ecss--selector-parser-position parser) (or offset 0))))
|
|
(when (< position (ecss--selector-parser-length parser))
|
|
(aref (ecss--selector-parser-input parser) position))))
|
|
|
|
(defun ecss--parser-take (parser)
|
|
"Consume and return PARSER's current character."
|
|
(prog1 (ecss--parser-peek parser)
|
|
(cl-incf (ecss--selector-parser-position parser))))
|
|
|
|
(defun ecss--selector-space-p (character)
|
|
"Return non-nil when CHARACTER is CSS whitespace."
|
|
(memq character '(?\s ?\t ?\n ?\r ?\f)))
|
|
|
|
(defun ecss--parser-skip-comment (parser)
|
|
"Skip one comment at PARSER and return non-nil when found."
|
|
(when (and (eq (ecss--parser-peek parser) ?/)
|
|
(eq (ecss--parser-peek parser 1) ?*))
|
|
(cl-incf (ecss--selector-parser-position parser) 2)
|
|
(let ((end (string-match "\\*/" (ecss--selector-parser-input parser)
|
|
(ecss--selector-parser-position parser))))
|
|
(unless end
|
|
(signal 'ecss-invalid-selector (list :unclosed-comment)))
|
|
(setf (ecss--selector-parser-position parser) (+ end 2)))
|
|
t))
|
|
|
|
(defun ecss--parser-skip-space (parser)
|
|
"Skip whitespace and comments at PARSER and report actual whitespace."
|
|
(let (space progress)
|
|
(while
|
|
(progn
|
|
(setq progress nil)
|
|
(while (ecss--selector-space-p (ecss--parser-peek parser))
|
|
(setq progress t space t)
|
|
(ecss--parser-take parser))
|
|
(when (ecss--parser-skip-comment parser)
|
|
(setq progress t))
|
|
progress))
|
|
space))
|
|
|
|
(defun ecss--parser-skip-comments (parser)
|
|
"Skip consecutive comments at PARSER without implying a combinator."
|
|
(while (ecss--parser-skip-comment parser)))
|
|
|
|
(defun ecss--identifier-character-p (character)
|
|
"Return non-nil when CHARACTER may occur unescaped in an identifier."
|
|
(and character (not (memq character ecss--selector-delimiters))))
|
|
|
|
(defun ecss--parser-read-escape (parser)
|
|
"Read one escaped character from PARSER."
|
|
(ecss--parser-take parser)
|
|
(when (ecss--parser-end-p parser)
|
|
(signal 'ecss-invalid-selector (list :trailing-escape)))
|
|
(ecss--parser-take parser))
|
|
|
|
(defun ecss--parser-read-identifier (parser)
|
|
"Read and return one identifier from PARSER."
|
|
(let (characters)
|
|
(while (or (ecss--identifier-character-p (ecss--parser-peek parser))
|
|
(eq (ecss--parser-peek parser) ?\\))
|
|
(push (if (eq (ecss--parser-peek parser) ?\\)
|
|
(ecss--parser-read-escape parser)
|
|
(ecss--parser-take parser))
|
|
characters))
|
|
(unless characters
|
|
(signal 'ecss-invalid-selector
|
|
(list :expected-identifier
|
|
(ecss--selector-parser-position parser))))
|
|
(apply #'string (nreverse characters))))
|
|
|
|
(defun ecss--parser-expect (parser character)
|
|
"Consume CHARACTER from PARSER or signal an invalid-selector error."
|
|
(unless (eq (ecss--parser-peek parser) character)
|
|
(signal 'ecss-invalid-selector
|
|
(list :expected character
|
|
:position (ecss--selector-parser-position parser))))
|
|
(ecss--parser-take parser))
|
|
|
|
(defun ecss--parser-read-string (parser)
|
|
"Read one quoted string from PARSER."
|
|
(let ((quote (ecss--parser-take parser)) characters done)
|
|
(while (and (not done) (not (ecss--parser-end-p parser)))
|
|
(let ((character (ecss--parser-take parser)))
|
|
(cond ((eq character quote) (setq done t))
|
|
((eq character ?\\)
|
|
(when (ecss--parser-end-p parser)
|
|
(signal 'ecss-invalid-selector (list :trailing-escape)))
|
|
(push (ecss--parser-take parser) characters))
|
|
(t (push character characters)))))
|
|
(unless done
|
|
(signal 'ecss-invalid-selector (list :unclosed-string)))
|
|
(apply #'string (nreverse characters))))
|
|
|
|
(defun ecss--parser-read-attribute-value (parser)
|
|
"Read one attribute value from PARSER."
|
|
(if (memq (ecss--parser-peek parser) '(?' ?\"))
|
|
(ecss--parser-read-string parser)
|
|
(ecss--parser-read-identifier parser)))
|
|
|
|
(defun ecss--parser-attribute-operator (parser)
|
|
"Read an optional attribute operator from PARSER."
|
|
(let ((first (ecss--parser-peek parser))
|
|
(second (ecss--parser-peek parser 1)))
|
|
(cond ((eq first ?=) (ecss--parser-take parser) "=")
|
|
((and (memq first '(?~ ?| ?^ ?$ ?*)) (eq second ?=))
|
|
(cl-incf (ecss--selector-parser-position parser) 2)
|
|
(string first second)))))
|
|
|
|
(defun ecss--parser-read-attribute (parser)
|
|
"Read one attribute selector from PARSER."
|
|
(ecss--parser-expect parser ?\[)
|
|
(ecss--parser-skip-space parser)
|
|
(let ((name (ecss--parser-read-identifier parser)) operator value flag)
|
|
(ecss--parser-skip-space parser)
|
|
(setq operator (ecss--parser-attribute-operator parser))
|
|
(when operator
|
|
(ecss--parser-skip-space parser)
|
|
(setq value (ecss--parser-read-attribute-value parser))
|
|
(ecss--parser-skip-space parser)
|
|
(when (and (ecss--identifier-character-p (ecss--parser-peek parser))
|
|
(not (eq (ecss--parser-peek parser) ?\])))
|
|
(setq flag (downcase (ecss--parser-read-identifier parser)))
|
|
(unless (member flag '("i" "s"))
|
|
(signal 'ecss-invalid-selector (list :attribute-flag flag)))
|
|
(ecss--parser-skip-space parser)))
|
|
(ecss--parser-expect parser ?\])
|
|
(if operator
|
|
(list :attr name operator value flag)
|
|
(list :attr name))))
|
|
|
|
(defun ecss--parser-read-raw-function (parser)
|
|
"Read an unknown pseudo function argument from PARSER."
|
|
(let ((start (ecss--selector-parser-position parser))
|
|
(depth 1) quote escaped)
|
|
(while (and (> depth 0) (not (ecss--parser-end-p parser)))
|
|
(let ((character (ecss--parser-take parser)))
|
|
(cond (escaped (setq escaped nil))
|
|
((eq character ?\\) (setq escaped t))
|
|
(quote (when (eq character quote) (setq quote nil)))
|
|
((memq character '(?' ?\")) (setq quote character))
|
|
((eq character ?\() (cl-incf depth))
|
|
((eq character ?\)) (cl-decf depth)))))
|
|
(unless (zerop depth)
|
|
(signal 'ecss-invalid-selector (list :unclosed-pseudo)))
|
|
(string-trim
|
|
(substring (ecss--selector-parser-input parser) start
|
|
(1- (ecss--selector-parser-position parser))))))
|
|
|
|
(defun ecss--anchor-relative-selector (selector kind)
|
|
"Anchor relative SELECTOR with leading combinator KIND."
|
|
(if (memq (car-safe selector) '(:descendant :child :adjacent :sibling))
|
|
(list (car selector)
|
|
(ecss--anchor-relative-selector (nth 1 selector) kind)
|
|
(nth 2 selector))
|
|
(list kind '(:anchor) selector)))
|
|
|
|
(defun ecss--parser-read-relative-list (parser)
|
|
"Read a relative selector list from PARSER through its closing parenthesis."
|
|
(ecss--parser-skip-space parser)
|
|
(let (selectors done)
|
|
(while (not done)
|
|
(let ((kind (or (ecss--combinator-kind (ecss--parser-peek parser))
|
|
:descendant)))
|
|
(unless (eq kind :descendant)
|
|
(ecss--parser-take parser)
|
|
(ecss--parser-skip-space parser))
|
|
(push (ecss--anchor-relative-selector
|
|
(ecss--parser-read-complex parser ?\)) kind)
|
|
selectors))
|
|
(ecss--parser-skip-space parser)
|
|
(cond ((eq (ecss--parser-peek parser) ?,)
|
|
(ecss--parser-take parser)
|
|
(ecss--parser-skip-space parser))
|
|
((eq (ecss--parser-peek parser) ?\))
|
|
(ecss--parser-take parser)
|
|
(setq done t))
|
|
(t (signal 'ecss-invalid-selector (list :unterminated-relative)))))
|
|
(nreverse selectors)))
|
|
|
|
(defun ecss--parser-read-pseudo (parser)
|
|
"Read one pseudo-class selector from PARSER."
|
|
(ecss--parser-expect parser ?:)
|
|
(when (eq (ecss--parser-peek parser) ?:)
|
|
(signal 'ecss-invalid-selector (list :pseudo-elements-unsupported)))
|
|
(let ((name (downcase (ecss--parser-read-identifier parser))))
|
|
(if (not (eq (ecss--parser-peek parser) ?\())
|
|
(list :state name)
|
|
(ecss--parser-take parser)
|
|
(cond
|
|
((equal name "has")
|
|
(cons :has (ecss--parser-read-relative-list parser)))
|
|
((member name '("is" "where" "not"))
|
|
(let ((selectors (ecss--parser-read-selector-list parser ?\))))
|
|
(cons (intern (concat ":" name))
|
|
(if (eq (car-safe selectors) :list)
|
|
(cdr selectors)
|
|
(list selectors)))))
|
|
(t (list :state
|
|
(list name (ecss--parser-read-raw-function parser))))))))
|
|
|
|
(defun ecss--compound-item-p (character)
|
|
"Return non-nil when CHARACTER can start a compound selector item."
|
|
(memq character '(?# ?. ?\[ ?:)))
|
|
|
|
(defun ecss--parser-read-compound (parser)
|
|
"Read one compound selector from PARSER."
|
|
(let (items)
|
|
(cond ((eq (ecss--parser-peek parser) ?*)
|
|
(ecss--parser-take parser)
|
|
(push '(:universal) items))
|
|
((ecss--identifier-character-p (ecss--parser-peek parser))
|
|
(push (list :type (ecss--parser-read-identifier parser)) items)))
|
|
(ecss--parser-skip-comments parser)
|
|
(while (ecss--compound-item-p (ecss--parser-peek parser))
|
|
(pcase (ecss--parser-peek parser)
|
|
(?# (ecss--parser-take parser)
|
|
(push (list :id (ecss--parser-read-identifier parser)) items))
|
|
(?. (ecss--parser-take parser)
|
|
(push (list :class (ecss--parser-read-identifier parser)) items))
|
|
(?\[ (push (ecss--parser-read-attribute parser) items))
|
|
(?: (push (ecss--parser-read-pseudo parser) items)))
|
|
(ecss--parser-skip-comments parser))
|
|
(setq items (nreverse items))
|
|
(cond ((null items)
|
|
(signal 'ecss-invalid-selector
|
|
(list :expected-compound
|
|
(ecss--selector-parser-position parser))))
|
|
((null (cdr items)) (car items))
|
|
(t (cons :and items)))))
|
|
|
|
(defun ecss--combinator-kind (character)
|
|
"Return AST combinator kind for CHARACTER."
|
|
(pcase character (?> :child) (?+ :adjacent) (?~ :sibling)))
|
|
|
|
(defun ecss--selector-list-end-p (parser terminator)
|
|
"Return non-nil when PARSER is at a list boundary TERMINATOR."
|
|
(or (ecss--parser-end-p parser)
|
|
(eq (ecss--parser-peek parser) ?,)
|
|
(and terminator (eq (ecss--parser-peek parser) terminator))))
|
|
|
|
(defun ecss--parser-read-complex (parser terminator)
|
|
"Read one complex selector from PARSER up to TERMINATOR."
|
|
(let ((left (ecss--parser-read-compound parser)) done)
|
|
(while (not done)
|
|
(let ((space (ecss--parser-skip-space parser)) kind)
|
|
(cond ((ecss--selector-list-end-p parser terminator)
|
|
(setq done t))
|
|
((setq kind (ecss--combinator-kind (ecss--parser-peek parser)))
|
|
(ecss--parser-take parser)
|
|
(ecss--parser-skip-space parser)
|
|
(setq left (list kind left
|
|
(ecss--parser-read-compound parser))))
|
|
(space
|
|
(setq left (list :descendant left
|
|
(ecss--parser-read-compound parser))))
|
|
(t
|
|
(signal 'ecss-invalid-selector
|
|
(list :unexpected-character
|
|
(ecss--parser-peek parser)))))))
|
|
left))
|
|
|
|
(defun ecss--parser-read-selector-list (parser &optional terminator)
|
|
"Read a selector list from PARSER up to optional TERMINATOR."
|
|
(ecss--parser-skip-space parser)
|
|
(let (selectors done)
|
|
(while (not done)
|
|
(push (ecss--parser-read-complex parser terminator) selectors)
|
|
(ecss--parser-skip-space parser)
|
|
(cond ((eq (ecss--parser-peek parser) ?,)
|
|
(ecss--parser-take parser)
|
|
(ecss--parser-skip-space parser))
|
|
((and terminator (eq (ecss--parser-peek parser) terminator))
|
|
(ecss--parser-take parser)
|
|
(setq done t))
|
|
((and (null terminator) (ecss--parser-end-p parser))
|
|
(setq done t))
|
|
(t (signal 'ecss-invalid-selector (list :unterminated-list)))))
|
|
(setq selectors (nreverse selectors))
|
|
(if (null (cdr selectors)) (car selectors) (cons :list selectors))))
|
|
|
|
;;;###autoload
|
|
(defun ecss-selector-parse (selector)
|
|
"Parse CSS-like SELECTOR text into a structured selector AST."
|
|
(unless (and (stringp selector) (not (string-empty-p selector)))
|
|
(signal 'ecss-invalid-selector (list selector)))
|
|
(let ((parser (ecss--make-selector-parser
|
|
:input selector :position 0 :length (length selector))))
|
|
(ecss--parser-read-selector-list parser)))
|
|
|
|
(defun ecss--selector-form-p (selector kind arity)
|
|
"Return non-nil when SELECTOR is KIND with ARITY arguments."
|
|
(and (consp selector) (eq (car selector) kind)
|
|
(= (length (cdr selector)) arity)))
|
|
|
|
(defun ecss--selector-list-valid-p (selectors)
|
|
"Return non-nil when SELECTORS is a nonempty valid selector list."
|
|
(and selectors (cl-every #'ecss-selector-valid-p selectors)))
|
|
|
|
(defun ecss--attribute-selector-valid-p (selector)
|
|
"Return non-nil when attribute SELECTOR is valid."
|
|
(or (ecss--selector-form-p selector :attr 1)
|
|
(and (ecss--selector-form-p selector :attr 4)
|
|
(member (nth 2 selector) ecss--attribute-operators)
|
|
(or (null (nth 4 selector))
|
|
(member (nth 4 selector) '("i" "s"))))))
|
|
|
|
(defun ecss-selector-valid-p (selector)
|
|
"Return non-nil when structured SELECTOR is valid."
|
|
(pcase (car-safe selector)
|
|
((or :type :id :class :state)
|
|
(and (ecss--selector-form-p selector (car selector) 1)
|
|
(nth 1 selector)))
|
|
(:attr (ecss--attribute-selector-valid-p selector))
|
|
((or :and :list :is :where :not :has)
|
|
(ecss--selector-list-valid-p (cdr selector)))
|
|
((or :descendant :child :adjacent :sibling)
|
|
(and (ecss--selector-form-p selector (car selector) 2)
|
|
(ecss--selector-list-valid-p (cdr selector))))
|
|
((or :universal :anchor) (null (cdr selector)))
|
|
(_ nil)))
|
|
|
|
(defun ecss--validate-selector (selector)
|
|
"Return SELECTOR or signal when it is invalid."
|
|
(unless (ecss-selector-valid-p selector)
|
|
(signal 'ecss-invalid-selector (list selector)))
|
|
selector)
|
|
|
|
;;;###autoload
|
|
(defun ecss-selector-normalize (selector)
|
|
"Return a validated defensive AST for string or structured SELECTOR."
|
|
(let ((ast (if (stringp selector) (ecss-selector-parse selector) selector)))
|
|
(ecss--copy-boundary-data (ecss--validate-selector ast))))
|
|
|
|
(defun ecss--selector-subject-local-p (selector)
|
|
"Return non-nil when validated SELECTOR reads only its subject."
|
|
(pcase (car selector)
|
|
((or :universal :type :id :class :state :attr) t)
|
|
((or :and :list :is :where :not)
|
|
(cl-every #'ecss--selector-subject-local-p (cdr selector)))
|
|
(_ nil)))
|
|
|
|
;;;###autoload
|
|
(defun ecss-selector-subject-local-p (selector)
|
|
"Return non-nil when SELECTOR depends only on the matched subject.
|
|
|
|
Subject-local selectors may inspect type, id, classes, attributes, states,
|
|
and local logical combinations such as `:is' and `:not'. Selectors involving
|
|
ancestors, children, or siblings return nil. Invalid selectors signal
|
|
`ecss-invalid-selector'."
|
|
(ecss--selector-subject-local-p (ecss-selector-normalize selector)))
|
|
|
|
(defun ecss--subject-attribute-cell (subject adapter name)
|
|
"Return SUBJECT attribute NAME through ADAPTER."
|
|
(assoc name (ecss--adapter-call adapter 'attributes subject)))
|
|
|
|
(defun ecss--subject-previous-siblings (subject adapter)
|
|
"Return SUBJECT's preceding siblings through ADAPTER."
|
|
(when-let* ((parent (ecss--subject-parent subject adapter)))
|
|
(let ((siblings (ecss--subject-children parent adapter)) result)
|
|
(while (and siblings (not (eq (car siblings) subject)))
|
|
(push (pop siblings) result))
|
|
(nreverse result))))
|
|
|
|
(defun ecss--attribute-token-member-p (needle value insensitive)
|
|
"Return whether NEEDLE occurs in whitespace-separated VALUE.
|
|
Compare without case when INSENSITIVE is non-nil."
|
|
(let ((tokens (split-string (format "%s" value) "[ \t\n\r\f]+" t)))
|
|
(cl-some (lambda (token)
|
|
(if insensitive
|
|
(string-equal (downcase needle) (downcase token))
|
|
(string-equal needle token)))
|
|
tokens)))
|
|
|
|
(defun ecss--attribute-string-match-p (operator expected actual insensitive)
|
|
"Match EXPECTED against ACTUAL with OPERATOR and case mode INSENSITIVE."
|
|
(let ((expected (format "%s" expected)) (actual (format "%s" actual)))
|
|
(when insensitive
|
|
(setq expected (downcase expected) actual (downcase actual)))
|
|
(cond ((equal operator "=") (string-equal actual expected))
|
|
((equal operator "~=")
|
|
(ecss--attribute-token-member-p expected actual insensitive))
|
|
((equal operator "|=")
|
|
(or (string-equal actual expected)
|
|
(string-prefix-p (concat expected "-") actual)))
|
|
((equal operator "^=") (string-prefix-p expected actual))
|
|
((equal operator "$=") (string-suffix-p expected actual))
|
|
((equal operator "*=")
|
|
(string-match-p (regexp-quote expected) actual)))))
|
|
|
|
(defun ecss--selector-match-attribute (selector subject adapter)
|
|
"Return whether attribute SELECTOR matches SUBJECT through ADAPTER."
|
|
(let ((cell (ecss--subject-attribute-cell subject adapter (nth 1 selector))))
|
|
(and cell
|
|
(or (= (length selector) 2)
|
|
(ecss--attribute-string-match-p
|
|
(nth 2 selector) (nth 3 selector) (cdr cell)
|
|
(equal (nth 4 selector) "i"))))))
|
|
|
|
(defun ecss--selector-match-descendant (selector subject adapter)
|
|
"Return whether descendant SELECTOR matches SUBJECT through ADAPTER."
|
|
(and (ecss-selector-match-p (nth 2 selector) subject adapter)
|
|
(cl-loop for parent = (ecss--subject-parent subject adapter)
|
|
then (ecss--subject-parent parent adapter)
|
|
while parent
|
|
thereis (ecss-selector-match-p
|
|
(nth 1 selector) parent adapter))))
|
|
|
|
(defun ecss--selector-match-adjacent (selector subject adapter)
|
|
"Return whether adjacent SELECTOR matches SUBJECT through ADAPTER."
|
|
(let ((siblings (ecss--subject-previous-siblings subject adapter)))
|
|
(and siblings
|
|
(ecss-selector-match-p (nth 1 selector) (car (last siblings)) adapter)
|
|
(ecss-selector-match-p (nth 2 selector) subject adapter))))
|
|
|
|
(defun ecss--selector-match-sibling (selector subject adapter)
|
|
"Return whether sibling SELECTOR matches SUBJECT through ADAPTER."
|
|
(and (ecss-selector-match-p (nth 2 selector) subject adapter)
|
|
(cl-some (lambda (sibling)
|
|
(ecss-selector-match-p (nth 1 selector) sibling adapter))
|
|
(ecss--subject-previous-siblings subject adapter))))
|
|
|
|
(defun ecss--subject-descendants (subject adapter)
|
|
"Return all descendants of SUBJECT through ADAPTER."
|
|
(cl-loop for child in (ecss--subject-children subject adapter)
|
|
append (cons child (ecss--subject-descendants child adapter))))
|
|
|
|
(defun ecss--subject-following-siblings (subject adapter)
|
|
"Return siblings following SUBJECT through ADAPTER."
|
|
(when-let* ((parent (ecss--subject-parent subject adapter)))
|
|
(let ((siblings (ecss--subject-children parent adapter)))
|
|
(while (and siblings (not (eq (pop siblings) subject))))
|
|
siblings)))
|
|
|
|
(defun ecss--relative-candidates (subject adapter)
|
|
"Return possible relative-selector targets from SUBJECT through ADAPTER."
|
|
(append
|
|
(ecss--subject-descendants subject adapter)
|
|
(cl-loop for sibling in (ecss--subject-following-siblings subject adapter)
|
|
append (cons sibling (ecss--subject-descendants sibling adapter)))))
|
|
|
|
(defun ecss--selector-match-has (selectors subject adapter)
|
|
"Return whether SUBJECT has a relative target matching SELECTORS."
|
|
(let ((ecss--selector-anchor subject))
|
|
(cl-some (lambda (candidate)
|
|
(cl-some (lambda (selector)
|
|
(ecss-selector-match-p selector candidate adapter))
|
|
selectors))
|
|
(ecss--relative-candidates subject adapter))))
|
|
|
|
(defun ecss--selector-match-valid (selector subject adapter)
|
|
"Match validated SELECTOR against SUBJECT through ADAPTER."
|
|
(pcase (car selector)
|
|
(:universal t)
|
|
(:anchor (eq subject ecss--selector-anchor))
|
|
(:type (equal (nth 1 selector) (ecss--adapter-call adapter 'type subject)))
|
|
(:id (equal (nth 1 selector) (ecss--adapter-call adapter 'id subject)))
|
|
(:class (member (nth 1 selector)
|
|
(ecss--adapter-call adapter 'classes subject)))
|
|
(:state (member (nth 1 selector)
|
|
(ecss--adapter-call adapter 'states subject)))
|
|
(:attr (ecss--selector-match-attribute selector subject adapter))
|
|
(:and (cl-every (lambda (item)
|
|
(ecss-selector-match-p item subject adapter))
|
|
(cdr selector)))
|
|
((or :list :is :where)
|
|
(cl-some (lambda (item)
|
|
(ecss-selector-match-p item subject adapter))
|
|
(cdr selector)))
|
|
(:not (not (cl-some (lambda (item)
|
|
(ecss-selector-match-p item subject adapter))
|
|
(cdr selector))))
|
|
(:has (ecss--selector-match-has (cdr selector) subject adapter))
|
|
(:descendant (ecss--selector-match-descendant selector subject adapter))
|
|
(:child (and (ecss-selector-match-p (nth 2 selector) subject adapter)
|
|
(when-let* ((parent (ecss--subject-parent subject adapter)))
|
|
(ecss-selector-match-p (nth 1 selector) parent adapter))))
|
|
(:adjacent (ecss--selector-match-adjacent selector subject adapter))
|
|
(:sibling (ecss--selector-match-sibling selector subject adapter))))
|
|
|
|
;;;###autoload
|
|
(defun ecss-selector-match-p
|
|
(selector subject &optional adapter)
|
|
"Return non-nil when SELECTOR matches SUBJECT through optional ADAPTER."
|
|
(let ((adapter (or adapter ecss-default-subject-adapter))
|
|
(selector (if (stringp selector)
|
|
(ecss-selector-parse selector)
|
|
selector)))
|
|
(unless (ecss-subject-adapter-p adapter)
|
|
(signal 'wrong-type-argument (list 'ecss-subject-adapter-p adapter)))
|
|
(ecss--validate-selector selector)
|
|
(ecss--selector-match-valid selector subject adapter)))
|
|
|
|
(defun ecss--specificity-add (left right)
|
|
"Add specificity triples LEFT and RIGHT."
|
|
(cl-mapcar #'+ left right))
|
|
|
|
(defun ecss--specificity-greater-p (left right)
|
|
"Return non-nil when specificity LEFT is greater than RIGHT."
|
|
(catch 'result
|
|
(cl-mapc (lambda (a b)
|
|
(cond ((> a b) (throw 'result t))
|
|
((< a b) (throw 'result nil))))
|
|
left right)
|
|
nil))
|
|
|
|
(defun ecss--specificity-max (values)
|
|
"Return the lexicographically greatest specificity in VALUES."
|
|
(cl-reduce (lambda (left right)
|
|
(if (ecss--specificity-greater-p left right) left right))
|
|
values :initial-value '(0 0 0)))
|
|
|
|
(defun ecss--specificity-list-sum (selectors)
|
|
"Return the combined specificity of SELECTORS."
|
|
(cl-reduce #'ecss--specificity-add selectors
|
|
:key #'ecss-selector-specificity
|
|
:initial-value '(0 0 0)))
|
|
|
|
;;;###autoload
|
|
(defun ecss-selector-specificity (selector)
|
|
"Return SELECTOR specificity as an (ID CLASS TYPE) list."
|
|
(setq selector (if (stringp selector)
|
|
(ecss-selector-parse selector)
|
|
selector))
|
|
(ecss--validate-selector selector)
|
|
(pcase (car selector)
|
|
(:id '(1 0 0))
|
|
((or :class :attr :state) '(0 1 0))
|
|
(:type '(0 0 1))
|
|
((or :universal :anchor :where) '(0 0 0))
|
|
(:and (ecss--specificity-list-sum (cdr selector)))
|
|
((or :list :is :not :has)
|
|
(ecss--specificity-max
|
|
(mapcar #'ecss-selector-specificity (cdr selector))))
|
|
((or :descendant :child :adjacent :sibling)
|
|
(ecss--specificity-list-sum (cdr selector)))))
|
|
|
|
(defun ecss--selector-matched-specificity (selector subject adapter)
|
|
"Return matched specificity for SELECTOR, SUBJECT, and ADAPTER, or nil."
|
|
(when (ecss-selector-match-p selector subject adapter)
|
|
(if (eq (car selector) :list)
|
|
(ecss--specificity-max
|
|
(cl-loop for item in (cdr selector)
|
|
when (ecss-selector-match-p item subject adapter)
|
|
collect (ecss-selector-specificity item)))
|
|
(ecss-selector-specificity selector))))
|
|
|
|
(provide 'ecss-selector)
|
|
;;; ecss-selector.el ends here
|