ecss/ecss-cascade.el
Kinneyzhang 9f6025ee12 feat(ecss): finalize independent cascade contract
Add shorthand-aware direct declaration composition, keep the public API consumer-neutral, and record the initial standalone release contract.

Verified: make check; make package-lint.
2026-08-06 23:42:01 +08:00

1000 lines
43 KiB
EmacsLisp

;;; ecss-cascade.el --- Pure CSS cascade computation -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; This module owns property schemas, stylesheets, cascade precedence,
;; inheritance, CSS-wide values, custom properties, and provenance. All
;; computation is independent of buffers, text properties, TP, and Ebox.
;;; Code:
(require 'cl-lib)
(require 'seq)
(require 'subr-x)
(require 'ecss-selector)
(define-error 'ecss-invalid-property-schema
"Invalid ECSS property schema" 'ecss-error)
(define-error 'ecss-invalid-declaration
"Invalid ECSS declaration" 'ecss-error)
(define-error 'ecss-invalid-rule "Invalid ECSS rule" 'ecss-error)
(cl-defstruct (ecss-property-schema
(:constructor ecss--make-property-schema))
"Schema governing one namespaced cascade property."
id initial inherits normalizer validator equality shorthand)
(cl-defstruct (ecss-schema-set
(:constructor ecss--make-schema-set)
(:conc-name ecss--schema-set-))
"Explicit registry of consumer-owned property schemas."
table order)
(cl-defstruct (ecss-stylesheet
(:constructor ecss--make-stylesheet)
(:conc-name ecss--stylesheet-))
"Ordered rules and cascade layers with no global state."
rules layers source-order)
(cl-defstruct (ecss-rule (:constructor ecss--make-rule))
"One validated stylesheet rule."
selector declarations origin layer layer-rank scope source-order)
(cl-defstruct (ecss-computed-style
(:constructor ecss--make-computed-style)
(:conc-name ecss--computed-style-))
"Computed declarations, custom properties, provenance, and diagnostics."
values custom-properties active-properties provenance diagnostics)
(cl-defstruct (ecss--wide (:constructor ecss--make-wide)) kind)
(cl-defstruct (ecss--important (:constructor ecss--make-important)) value)
(cl-defstruct (ecss--var-ref (:constructor ecss--make-var-ref))
name fallback-present-p fallback)
(cl-defstruct (ecss--candidate (:constructor ecss--make-candidate))
property value origin important inline layer layer-rank specificity
scope-distance source-order declaration-order selector)
(defconst ecss--schema-option-keys
'(:initial :inherits :normalizer :validator :equality :shorthand)
"Accepted property schema option keys.")
(defconst ecss--origins '(ua user author animation transition)
"Supported standard CSS cascade origins.")
(defconst ecss--wide-kinds '(initial inherit unset revert revert-layer)
"Supported CSS-wide value kinds.")
(defconst ecss--invalid (make-symbol "ecss-invalid-value"))
(defconst ecss--absent (make-symbol "ecss-absent-value"))
(defun ecss-schema-set-create ()
"Create an empty independent property schema set."
(ecss--make-schema-set :table (make-hash-table :test #'eq) :order nil))
(defun ecss--schema-set-check (schemas)
"Return SCHEMAS or signal when it is not a schema set."
(unless (ecss-schema-set-p schemas)
(signal 'wrong-type-argument (list 'ecss-schema-set-p schemas)))
schemas)
(defun ecss--canonical-property-id-p (id)
"Return non-nil when ID is a namespaced property symbol."
(and (symbolp id)
(let ((name (symbol-name id)))
(and (string-match-p "/" name)
(not (string-prefix-p "/" name))
(not (string-suffix-p "/" name))))))
(defun ecss--custom-property-p (property)
"Return non-nil when PROPERTY names a custom property."
(and (symbolp property)
(string-prefix-p "--" (symbol-name property))))
(defun ecss--options-valid-p (options)
"Return non-nil when OPTIONS is an accepted property option plist."
(and (listp options)
(zerop (% (length options) 2))
(cl-loop for key in options by #'cddr
always (memq key ecss--schema-option-keys))))
(defun ecss--schema-option (options key fallback)
"Return KEY from OPTIONS when present, otherwise FALLBACK."
(if (plist-member options key) (plist-get options key) fallback))
(defun ecss--validate-schema-functions (options)
"Validate callable schema fields in OPTIONS."
(dolist (key '(:normalizer :validator :equality :shorthand))
(let ((value (plist-get options key)))
(unless (or (null value) (functionp value))
(signal 'ecss-invalid-property-schema (list key value))))))
(defun ecss--normalize-schema-initial (initial normalizer validator)
"Normalize and validate schema INITIAL with NORMALIZER and VALIDATOR."
(let ((normalized (funcall normalizer (copy-tree initial))))
(unless (funcall validator normalized)
(signal 'ecss-invalid-property-schema
(list :invalid-initial initial)))
normalized))
(defun ecss--build-property-schema (id options)
"Build a validated property schema for ID from OPTIONS."
(unless (and (ecss--canonical-property-id-p id)
(ecss--options-valid-p options))
(signal 'ecss-invalid-property-schema (list :property id options)))
(ecss--validate-schema-functions options)
(let* ((normalizer (ecss--schema-option options :normalizer #'identity))
(validator (ecss--schema-option
options :validator (lambda (_value) t)))
(initial (ecss--normalize-schema-initial
(plist-get options :initial) normalizer validator)))
(ecss--make-property-schema
:id id :initial initial
:inherits (and (plist-get options :inherits) t)
:normalizer normalizer :validator validator
:equality (ecss--schema-option options :equality #'equal)
:shorthand (plist-get options :shorthand))))
;;;###autoload
(defun ecss-schema-set-define (schemas id &rest options)
"Atomically define property ID with OPTIONS in SCHEMAS."
(ecss--schema-set-check schemas)
(let* ((schema (ecss--build-property-schema id options))
(table (ecss--schema-set-table schemas)))
(unless (gethash id table)
(setf (ecss--schema-set-order schemas)
(append (ecss--schema-set-order schemas) (list id))))
(puthash id schema table)
(ecss--copy-property-schema schema)))
(defun ecss--copy-property-schema (schema)
"Return a defensive copy of SCHEMA."
(let ((copy (copy-ecss-property-schema schema)))
(setf (ecss-property-schema-initial copy)
(copy-tree (ecss-property-schema-initial schema)))
copy))
(defun ecss-schema-set-property (schemas id)
"Return a defensive copy of property ID from SCHEMAS, or nil."
(ecss--schema-set-check schemas)
(when-let ((schema (gethash id (ecss--schema-set-table schemas))))
(ecss--copy-property-schema schema)))
(defun ecss-schema-set-property-ids (schemas)
"Return property identifiers from SCHEMAS in registration order."
(ecss--schema-set-check schemas)
(copy-sequence (ecss--schema-set-order schemas)))
(defun ecss-schema-set-clear (schemas)
"Remove every property schema from SCHEMAS."
(ecss--schema-set-check schemas)
(clrhash (ecss--schema-set-table schemas))
(setf (ecss--schema-set-order schemas) nil)
schemas)
(defun ecss-property-equal-p (schemas property left right)
"Return whether PROPERTY values LEFT and RIGHT are equal in SCHEMAS."
(ecss--schema-set-check schemas)
(let ((schema (gethash property (ecss--schema-set-table schemas))))
(unless schema
(signal 'ecss-invalid-declaration (list :unknown-property property)))
(funcall (ecss-property-schema-equality schema) left right)))
;;;###autoload
(defun ecss-wide-value (kind)
"Return a tagged CSS-wide value of KIND."
(unless (memq kind ecss--wide-kinds)
(signal 'ecss-invalid-declaration (list :wide-value kind)))
(ecss--make-wide :kind kind))
;;;###autoload
(defun ecss-important (value)
"Return VALUE tagged as an important declaration."
(ecss--make-important :value value))
;;;###autoload
(defun ecss-var (name &rest fallback)
"Return a custom property reference to NAME with optional FALLBACK."
(unless (ecss--custom-property-p name)
(signal 'ecss-invalid-declaration (list :custom-property name)))
(when (> (length fallback) 1)
(signal 'wrong-number-of-arguments
(list 'ecss-var (+ 1 (length fallback)))))
(ecss--make-var-ref
:name name :fallback-present-p (and fallback t) :fallback (car fallback)))
(defun ecss--declaration-list-p (declarations)
"Return non-nil when DECLARATIONS is an even property/value list."
(and (listp declarations) (zerop (% (length declarations) 2))))
(defun ecss--schema-for (schemas property)
"Return PROPERTY schema from SCHEMAS, or nil."
(gethash property (ecss--schema-set-table schemas)))
(defun ecss--validate-declaration-property (schemas property)
"Return PROPERTY when it is valid for SCHEMAS."
(unless (or (ecss--custom-property-p property)
(ecss--schema-for schemas property))
(signal 'ecss-invalid-declaration (list :unknown-property property)))
property)
(defun ecss--unwrap-important (value)
"Return VALUE paired with whether it carries an important tag."
(if (ecss--important-p value)
(cons (ecss--important-value value) t)
(cons value nil)))
(defun ecss--tag-important (declarations important)
"Tag DECLARATIONS as IMPORTANT when requested."
(if (not important)
declarations
(cl-loop for (property value) on declarations by #'cddr
append (list property (ecss-important value)))))
(defun ecss--validate-expanded-longhands (schemas shorthand declarations)
"Validate SHORTHAND expansion DECLARATIONS against SCHEMAS."
(unless (ecss--declaration-list-p declarations)
(signal 'ecss-invalid-declaration
(list :shorthand shorthand declarations)))
(cl-loop for (property _value) on declarations by #'cddr
for schema = (progn
(ecss--validate-declaration-property schemas property)
(ecss--schema-for schemas property))
when (and schema (ecss-property-schema-shorthand schema))
do (signal 'ecss-invalid-declaration
(list :nested-shorthand shorthand property))))
(defun ecss--expand-declaration (schemas property value)
"Expand one PROPERTY VALUE declaration using SCHEMAS."
(ecss--validate-declaration-property schemas property)
(let ((schema (ecss--schema-for schemas property)))
(if-let ((expander (and schema
(ecss-property-schema-shorthand schema))))
(pcase-let* ((`(,raw . ,important) (ecss--unwrap-important value))
(expanded (funcall expander raw)))
(ecss--validate-expanded-longhands schemas property expanded)
(ecss--tag-important expanded important))
(list property value))))
;;;###autoload
(defun ecss-expand-declarations (schemas declarations)
"Validate and expand DECLARATIONS through SCHEMAS."
(ecss--schema-set-check schemas)
(unless (ecss--declaration-list-p declarations)
(signal 'ecss-invalid-declaration (list :declarations declarations)))
(cl-loop for (property value) on declarations by #'cddr
append (ecss--expand-declaration schemas property value)))
;;;###autoload
(defun ecss-merge-declarations (schemas &rest declaration-groups)
"Merge DECLARATION-GROUPS into canonical longhands using SCHEMAS.
Groups are applied from left to right. Later values replace earlier values for
the same expanded longhand, including explicit nil declarations."
(ecss--schema-set-check schemas)
(let (result)
(dolist (declarations declaration-groups result)
(cl-loop for (property value)
on (ecss-expand-declarations schemas declarations) by #'cddr
do (setq result
(plist-put result property (copy-tree value)))))))
(defun ecss-stylesheet-create ()
"Create an empty independent stylesheet."
(ecss--make-stylesheet :rules nil :layers nil :source-order 0))
(defun ecss--stylesheet-check (stylesheet)
"Return STYLESHEET or signal when it is invalid."
(unless (ecss-stylesheet-p stylesheet)
(signal 'wrong-type-argument (list 'ecss-stylesheet-p stylesheet)))
stylesheet)
(defun ecss--copy-rule (rule)
"Return a defensive copy of RULE."
(let ((copy (copy-ecss-rule rule)))
(setf (ecss-rule-selector copy) (copy-tree (ecss-rule-selector rule))
(ecss-rule-declarations copy) (copy-tree (ecss-rule-declarations rule))
(ecss-rule-scope copy) (copy-tree (ecss-rule-scope rule)))
copy))
(defun ecss-stylesheet-rules (stylesheet)
"Return defensive rule copies from STYLESHEET."
(ecss--stylesheet-check stylesheet)
(mapcar #'ecss--copy-rule (ecss--stylesheet-rules stylesheet)))
(defun ecss--origin-layers (stylesheet origin)
"Return internal STYLESHEET layer order for ORIGIN."
(cdr (assq origin (ecss--stylesheet-layers stylesheet))))
(defun ecss--set-origin-layers (stylesheet origin layers)
"Set STYLESHEET ORIGIN order to LAYERS."
(if-let ((cell (assq origin (ecss--stylesheet-layers stylesheet))))
(setcdr cell layers)
(setf (ecss--stylesheet-layers stylesheet)
(append (ecss--stylesheet-layers stylesheet)
(list (cons origin layers))))))
(defun ecss-stylesheet-layers (stylesheet &optional origin)
"Return STYLESHEET layers for ORIGIN in declared order.
ORIGIN defaults to `author'."
(ecss--stylesheet-check stylesheet)
(copy-tree
(ecss--origin-layers
stylesheet (ecss--validate-origin (or origin 'author)))))
(defun ecss-stylesheet-clear (stylesheet)
"Remove all rules and layers from STYLESHEET."
(ecss--stylesheet-check stylesheet)
(setf (ecss--stylesheet-rules stylesheet) nil
(ecss--stylesheet-layers stylesheet) nil
(ecss--stylesheet-source-order stylesheet) 0)
stylesheet)
(defun ecss-stylesheet-declare-layers (stylesheet layers &optional origin)
"Append unseen LAYERS to STYLESHEET for ORIGIN and return their order.
ORIGIN defaults to `author'."
(ecss--stylesheet-check stylesheet)
(setq origin (ecss--validate-origin (or origin 'author)))
(unless (and (listp layers) (cl-every (lambda (layer) layer) layers))
(signal 'ecss-invalid-rule (list :layers layers)))
(let ((result (copy-tree (ecss--origin-layers stylesheet origin))))
(dolist (layer layers)
(unless (member layer result)
(setq result (append result (list (copy-tree layer))))))
(ecss--set-origin-layers stylesheet origin result)
(copy-tree result)))
(defun ecss--validate-origin (origin)
"Return ORIGIN when it is a standard cascade origin."
(unless (memq origin ecss--origins)
(signal 'ecss-invalid-rule (list :origin origin)))
origin)
(defun ecss--prospective-layer-rank (stylesheet origin layer)
"Return ORIGIN LAYER rank in STYLESHEET without mutation."
(when layer
(let ((layers (ecss--origin-layers stylesheet origin)))
(or (cl-position layer layers :test #'equal) (length layers)))))
(defun ecss--commit-rule (stylesheet rule layer)
"Commit RULE and optional new LAYER to STYLESHEET."
(let* ((origin (ecss-rule-origin rule))
(layers (ecss--origin-layers stylesheet origin)))
(when (and layer (not (member layer layers)))
(ecss--set-origin-layers
stylesheet origin (append layers (list (copy-tree layer))))))
(setf (ecss--stylesheet-source-order stylesheet)
(ecss-rule-source-order rule)
(ecss--stylesheet-rules stylesheet)
(append (ecss--stylesheet-rules stylesheet) (list rule))))
;;;###autoload
(cl-defun ecss-stylesheet-add-rule
(stylesheet schemas selector declarations
&key (origin 'author) layer scope)
"Add SELECTOR and DECLARATIONS to STYLESHEET using SCHEMAS.
ORIGIN defaults to `author'. LAYER follows declaration order. SCOPE is an
optional selector limiting the rule to a matching subject or ancestor."
(ecss--stylesheet-check stylesheet)
(ecss--schema-set-check schemas)
(let* ((selector (ecss-selector-normalize selector))
(scope (and scope (ecss-selector-normalize scope)))
(origin (ecss--validate-origin origin))
(expanded (ecss-expand-declarations schemas declarations))
(source-order (1+ (ecss--stylesheet-source-order stylesheet)))
(rule (ecss--make-rule
:selector selector :declarations (copy-tree expanded)
:origin origin :layer (copy-tree layer)
:layer-rank (ecss--prospective-layer-rank
stylesheet origin layer)
:scope scope :source-order source-order)))
(ecss--commit-rule stylesheet rule layer)
(ecss--copy-rule rule)))
(defun ecss--scope-distance (scope subject adapter)
"Return SUBJECT distance to matching SCOPE through ADAPTER, or nil."
(if (null scope)
most-positive-fixnum
(cl-loop for current = subject then (ecss--subject-parent current adapter)
for distance from 0 while current
when (ecss-selector-match-p scope current adapter)
return distance)))
(defun ecss--rule-match-facts (rule subject adapter)
"Return RULE match facts for SUBJECT through ADAPTER, or nil."
(when-let ((specificity
(ecss--selector-matched-specificity
(ecss-rule-selector rule) subject adapter)))
(let ((distance (ecss--scope-distance
(ecss-rule-scope rule) subject adapter)))
(when (numberp distance) (cons specificity distance)))))
(defun ecss--candidate-from-rule
(rule property value specificity distance declaration-order)
"Create a candidate from RULE, PROPERTY, and VALUE.
SPECIFICITY, DISTANCE, and DECLARATION-ORDER are the match precedence facts."
(pcase-let ((`(,raw . ,important) (ecss--unwrap-important value)))
(ecss--make-candidate
:property property :value raw :origin (ecss-rule-origin rule)
:important important :inline nil :layer (ecss-rule-layer rule)
:layer-rank (ecss-rule-layer-rank rule) :specificity specificity
:scope-distance distance :source-order (ecss-rule-source-order rule)
:declaration-order declaration-order
:selector (copy-tree (ecss-rule-selector rule)))))
(defun ecss--rule-candidates (rule subject adapter)
"Return candidates from matching RULE for SUBJECT through ADAPTER."
(when-let ((facts (ecss--rule-match-facts rule subject adapter)))
(cl-loop for (property value) on (ecss-rule-declarations rule) by #'cddr
for declaration-order from 0
collect (ecss--candidate-from-rule
rule property value (car facts) (cdr facts)
declaration-order))))
(defun ecss--max-source-order (rules)
"Return greatest source order in RULES."
(cl-loop for rule in rules maximize (ecss-rule-source-order rule) into value
finally return (or value 0)))
(defun ecss--inline-candidates (schemas declarations source-order)
"Return inline candidates from DECLARATIONS using SCHEMAS and SOURCE-ORDER."
(when declarations
(cl-loop for (property value)
on (ecss-expand-declarations schemas declarations) by #'cddr
for declaration-order from 0
collect
(pcase-let ((`(,raw . ,important) (ecss--unwrap-important value)))
(ecss--make-candidate
:property property :value raw :origin 'author
:important important :inline t :layer nil :layer-rank nil
:specificity '(0 0 0)
:scope-distance most-positive-fixnum
:source-order source-order :declaration-order declaration-order
:selector :inline)))))
(defun ecss--collect-candidates
(schemas subject adapter declarations rules)
"Collect candidates for SUBJECT, DECLARATIONS, and RULES.
SCHEMAS validates inline declarations and ADAPTER exposes SUBJECT."
(append
(cl-loop for rule in rules
append (ecss--rule-candidates rule subject adapter))
(ecss--inline-candidates
schemas declarations (1+ (ecss--max-source-order rules)))))
(defun ecss--cascade-level-rank (candidate)
"Return standard CSS origin and importance rank for CANDIDATE."
(let ((origin (ecss--candidate-origin candidate))
(important (ecss--candidate-important candidate)))
(cond ((eq origin 'transition) 7)
((and important (eq origin 'ua)) 6)
((and important (eq origin 'user)) 5)
((and important (eq origin 'author)) 4)
((eq origin 'animation) 3)
((eq origin 'author) 2)
((eq origin 'user) 1)
((eq origin 'ua) 0))))
(defun ecss--candidate-cascade-layer-rank (candidate)
"Return cascade layer rank for CANDIDATE."
(let ((layer (ecss--candidate-layer candidate))
(rank (ecss--candidate-layer-rank candidate))
(important (ecss--candidate-important candidate)))
(cond ((ecss--candidate-inline candidate) 2000000)
((and important (null layer)) -1000000)
((null layer) 1000000)
(important (- (or rank 0)))
(t (or rank 0)))))
(defun ecss--compare-number (left right)
"Compare LEFT and RIGHT, returning 1, -1, or 0."
(cond ((> left right) 1) ((< left right) -1) (t 0)))
(defun ecss--rank-list-comparison (left right)
"Compare numeric rank lists LEFT and RIGHT."
(catch 'comparison
(cl-mapc (lambda (a b)
(let ((value (ecss--compare-number a b)))
(unless (zerop value) (throw 'comparison value))))
left right)
0))
(defun ecss--candidate-primary-ranks (candidate)
"Return primary cascade ranks for CANDIDATE."
(list (ecss--cascade-level-rank candidate)
(ecss--candidate-cascade-layer-rank candidate)))
(defun ecss--candidate-higher-p (left right)
"Return non-nil when candidate LEFT outranks RIGHT."
(let ((rank (ecss--rank-list-comparison
(ecss--candidate-primary-ranks left)
(ecss--candidate-primary-ranks right))))
(cond ((not (zerop rank)) (> rank 0))
((not (equal (ecss--candidate-specificity left)
(ecss--candidate-specificity right)))
(ecss--specificity-greater-p
(ecss--candidate-specificity left)
(ecss--candidate-specificity right)))
((/= (ecss--candidate-scope-distance left)
(ecss--candidate-scope-distance right))
(< (ecss--candidate-scope-distance left)
(ecss--candidate-scope-distance right)))
((/= (ecss--candidate-source-order left)
(ecss--candidate-source-order right))
(> (ecss--candidate-source-order left)
(ecss--candidate-source-order right)))
(t (> (ecss--candidate-declaration-order left)
(ecss--candidate-declaration-order right))))))
(defun ecss--group-candidates (candidates)
"Group and sort CANDIDATES by property."
(let ((table (make-hash-table :test #'eq)))
(dolist (candidate candidates)
(let ((property (ecss--candidate-property candidate)))
(puthash property (cons candidate (gethash property table)) table)))
(maphash (lambda (property values)
(puthash property
(sort values #'ecss--candidate-higher-p) table))
table)
table))
(defun ecss--skip-reverted-origin (candidates winner)
"Remove WINNER origin from CANDIDATES."
(seq-remove
(lambda (candidate)
(eq (ecss--candidate-origin candidate)
(ecss--candidate-origin winner)))
candidates))
(defun ecss--skip-reverted-layer (candidates winner)
"Remove WINNER origin and layer from CANDIDATES."
(seq-remove
(lambda (candidate)
(and (eq (ecss--candidate-origin candidate)
(ecss--candidate-origin winner))
(equal (ecss--candidate-layer candidate)
(ecss--candidate-layer winner))))
candidates))
(defun ecss--resolve-source (value property subject resolver)
"Resolve VALUE for PROPERTY and SUBJECT only through explicit RESOLVER."
(if resolver (funcall resolver value property subject) value))
(defun ecss--parent-values (parent-style)
"Return computed values from PARENT-STYLE."
(cond ((ecss-computed-style-p parent-style)
(ecss--computed-style-values parent-style))
((listp parent-style) parent-style)))
(defun ecss--parent-custom-properties (parent-style)
"Return custom properties from PARENT-STYLE."
(when (ecss-computed-style-p parent-style)
(ecss--computed-style-custom-properties parent-style)))
(defun ecss--parent-property-active-p (parent-style property)
"Return non-nil when PARENT-STYLE actively supplies PROPERTY."
(cond ((ecss-computed-style-p parent-style)
(memq property (ecss--computed-style-active-properties parent-style)))
((listp parent-style) (and (plist-member parent-style property) t))))
(defun ecss--property-default (schema parent-style)
"Return default value and source for SCHEMA using PARENT-STYLE."
(let* ((property (ecss-property-schema-id schema))
(values (ecss--parent-values parent-style)))
(if (and (ecss-property-schema-inherits schema)
(plist-member values property))
(cons (copy-tree (plist-get values property)) 'inherit)
(cons (copy-tree (ecss-property-schema-initial schema)) 'initial))))
(defun ecss--wide-default (wide schema parent-style)
"Resolve non-revert WIDE value for SCHEMA using PARENT-STYLE."
(pcase (ecss--wide-kind wide)
('initial (cons (ecss-property-schema-initial schema) 'initial))
('inherit
(let ((values (ecss--parent-values parent-style))
(property (ecss-property-schema-id schema)))
(if (plist-member values property)
(cons (copy-tree (plist-get values property)) 'inherit)
(cons (copy-tree (ecss-property-schema-initial schema)) 'initial))))
('unset (if (ecss-property-schema-inherits schema)
(ecss--wide-default (ecss-wide-value 'inherit)
schema parent-style)
(cons (copy-tree (ecss-property-schema-initial schema))
'initial)))))
(defun ecss--candidate-provenance (candidate &rest extra)
"Return public provenance for CANDIDATE followed by EXTRA facts."
(append
(if candidate
(list :source 'declaration
:selector (copy-tree (ecss--candidate-selector candidate))
:origin (ecss--candidate-origin candidate)
:important (and (ecss--candidate-important candidate) t)
:inline (and (ecss--candidate-inline candidate) t)
:layer (copy-tree (ecss--candidate-layer candidate))
:specificity (copy-sequence
(ecss--candidate-specificity candidate))
:scope-distance (ecss--candidate-scope-distance candidate)
:source-order (ecss--candidate-source-order candidate)
:declaration-order (ecss--candidate-declaration-order candidate))
'(:source initial :origin ua))
extra))
(defun ecss--select-custom-candidate
(candidates inherited property subject resolver)
"Select custom PROPERTY from CANDIDATES and INHERITED values."
(let ((remaining candidates) selected winner done)
(while (and remaining (not done))
(setq winner (pop remaining))
(let ((value (ecss--resolve-source
(ecss--candidate-value winner) property subject resolver)))
(if (not (ecss--wide-p value))
(setq selected value done t)
(pcase (ecss--wide-kind value)
('revert (setq remaining
(ecss--skip-reverted-origin remaining winner)))
('revert-layer (setq remaining
(ecss--skip-reverted-layer remaining winner)))
((or 'inherit 'unset)
(setq selected (gethash property inherited ecss--absent)
done t))
('initial (setq selected ecss--absent done t))))))
(unless done
(setq selected (gethash property inherited ecss--absent)
winner nil))
(cons selected winner)))
(defun ecss--custom-candidate-properties (candidate-table)
"Return custom property keys from CANDIDATE-TABLE in stable order."
(let (properties)
(maphash (lambda (property _candidates)
(when (ecss--custom-property-p property)
(push property properties)))
candidate-table)
(sort properties
(lambda (left right)
(string< (symbol-name left) (symbol-name right))))))
(defun ecss--custom-raw-table
(candidate-table parent-style subject resolver provenance-p)
"Build raw custom properties from CANDIDATE-TABLE.
PARENT-STYLE supplies inheritance. SUBJECT and RESOLVER handle explicit value
sources. Retain winner facts when PROVENANCE-P is non-nil."
(let ((table (make-hash-table :test #'eq)) provenance)
(cl-loop for (property value) on (ecss--parent-custom-properties parent-style)
by #'cddr
do (puthash property value table)
when provenance-p
do (setq provenance
(plist-put provenance property '(:source inherit))))
(dolist (property (ecss--custom-candidate-properties candidate-table))
(pcase-let ((`(,value . ,winner)
(ecss--select-custom-candidate
(gethash property candidate-table) table property
subject resolver)))
(if (eq value ecss--absent)
(remhash property table)
(puthash property value table))
(when provenance-p
(setq provenance
(plist-put provenance property
(if winner (ecss--candidate-provenance winner)
'(:source inherit)))))))
(list table provenance)))
(defun ecss--record-cycle (stack name diagnostics)
"Record a custom property cycle from STACK through NAME in DIAGNOSTICS."
(let ((path (reverse (cons name stack))))
(unless (member (list :type 'variable-cycle :path path) (car diagnostics))
(push (list :type 'variable-cycle :path path) (car diagnostics)))))
(defun ecss--resolve-var-fallback
(reference raw resolved stack diagnostics)
"Resolve REFERENCE fallback using RAW, RESOLVED, STACK, and DIAGNOSTICS."
(if (ecss--var-ref-fallback-present-p reference)
(ecss--resolve-variable-value
(ecss--var-ref-fallback reference) raw resolved stack diagnostics)
ecss--invalid))
(defun ecss--resolve-custom-property
(name raw resolved stack diagnostics)
"Resolve custom property NAME using RAW, RESOLVED, STACK, and DIAGNOSTICS."
(let ((memo (gethash name resolved ecss--absent)))
(cond ((not (eq memo ecss--absent)) memo)
((memq name stack)
(ecss--record-cycle stack name diagnostics)
ecss--invalid)
(t
(let ((value (gethash name raw ecss--absent)))
(if (eq value ecss--absent)
ecss--invalid
(let ((answer (ecss--resolve-variable-value
value raw resolved (cons name stack)
diagnostics)))
(puthash name answer resolved)
answer)))))))
(defun ecss--resolve-compound-value
(value raw resolved stack diagnostics)
"Resolve custom references recursively inside VALUE.
RAW and RESOLVED are custom-property tables. STACK detects cycles and
DIAGNOSTICS records them."
(cond ((functionp value) value)
((vectorp value)
(let ((items (mapcar
(lambda (item)
(ecss--resolve-variable-value
item raw resolved stack diagnostics))
(append value nil))))
(if (memq ecss--invalid items) ecss--invalid (vconcat items))))
((consp value)
(let ((car-value (ecss--resolve-variable-value
(car value) raw resolved stack diagnostics))
(cdr-value (ecss--resolve-variable-value
(cdr value) raw resolved stack diagnostics)))
(if (or (eq car-value ecss--invalid)
(eq cdr-value ecss--invalid))
ecss--invalid
(cons car-value cdr-value))))
(t value)))
(defun ecss--resolve-variable-value
(value raw resolved stack diagnostics)
"Resolve custom references in VALUE using RAW and RESOLVED tables.
STACK detects cycles and DIAGNOSTICS records them."
(if (not (ecss--var-ref-p value))
(ecss--resolve-compound-value value raw resolved stack diagnostics)
(let ((answer (ecss--resolve-custom-property
(ecss--var-ref-name value) raw resolved stack diagnostics)))
(if (eq answer ecss--invalid)
(ecss--resolve-var-fallback
value raw resolved stack diagnostics)
answer))))
(defun ecss--resolved-custom-properties (raw diagnostics)
"Return resolved custom properties from RAW with DIAGNOSTICS."
(let ((resolved (make-hash-table :test #'eq)) names result)
(maphash (lambda (name _value) (push name names)) raw)
(dolist (name (sort names
(lambda (left right)
(string< (symbol-name left) (symbol-name right)))))
(let ((value (ecss--resolve-custom-property
name raw resolved nil diagnostics)))
(unless (eq value ecss--invalid)
(setq result (plist-put result name value)))))
result))
(defun ecss--custom-value-tables (custom)
"Build RAW and RESOLVED tables from computed CUSTOM properties."
(let ((raw (make-hash-table :test #'eq))
(resolved (make-hash-table :test #'eq)))
(cl-loop for (name value) on custom by #'cddr
do (puthash name value raw)
do (puthash name value resolved))
(cons raw resolved)))
(defun ecss--resolve-property-value
(value schema parent-style custom diagnostics)
"Resolve VALUE for SCHEMA using PARENT-STYLE, CUSTOM, and DIAGNOSTICS."
(cond ((and (ecss--wide-p value)
(memq (ecss--wide-kind value) '(initial inherit unset)))
(ecss--wide-default value schema parent-style))
(t
(pcase-let ((`(,raw . ,resolved)
(ecss--custom-value-tables custom)))
(cons (ecss--resolve-variable-value
value raw resolved nil diagnostics)
'declaration)))))
(defun ecss--normalize-property-value (schema value)
"Normalize and validate VALUE for SCHEMA, or return invalid sentinel."
(if (eq value ecss--invalid)
value
(let ((normalized
(funcall (ecss-property-schema-normalizer schema) value)))
(if (funcall (ecss-property-schema-validator schema) normalized)
normalized
ecss--invalid))))
(defun ecss--compute-candidate-value
(candidate schema parent-style custom subject resolver diagnostics)
"Resolve CANDIDATE for SCHEMA and computation context.
PARENT-STYLE and CUSTOM supply inherited values. SUBJECT and RESOLVER handle
explicit sources, and DIAGNOSTICS records variable failures."
(let* ((property (ecss-property-schema-id schema))
(source (ecss--resolve-source
(ecss--candidate-value candidate)
property subject resolver))
(resolved (ecss--resolve-property-value
source schema parent-style custom diagnostics)))
(cons (if (eq (cdr resolved) 'declaration)
(ecss--normalize-property-value schema (car resolved))
(copy-tree (car resolved)))
(cdr resolved))))
(defun ecss--fallback-value (schema parent-style)
"Return the computed default for SCHEMA using PARENT-STYLE."
(pcase-let ((`(,value . ,source)
(ecss--property-default schema parent-style)))
(cons value source)))
(defun ecss--resolve-property-candidates
(schema candidates parent-style custom subject resolver diagnostics)
"Resolve SCHEMA from ordered CANDIDATES.
PARENT-STYLE and CUSTOM supply inherited values. SUBJECT and RESOLVER handle
explicit sources, and DIAGNOSTICS records variable failures."
(let ((remaining candidates) winner resolved)
(while (and remaining (null winner))
(let* ((candidate (pop remaining))
(raw (ecss--resolve-source
(ecss--candidate-value candidate)
(ecss-property-schema-id schema) subject resolver)))
(cond ((and (ecss--wide-p raw) (eq (ecss--wide-kind raw) 'revert))
(setq remaining (ecss--skip-reverted-origin
remaining candidate)))
((and (ecss--wide-p raw)
(eq (ecss--wide-kind raw) 'revert-layer))
(setq remaining (ecss--skip-reverted-layer
remaining candidate)))
(t
(setq winner candidate
resolved
(ecss--compute-candidate-value
candidate schema parent-style custom subject
(lambda (_value _property _subject) raw) diagnostics))))))
(let* ((invalid (and winner (eq (car resolved) ecss--invalid)))
(final (if (or (null winner) invalid)
(ecss--fallback-value schema parent-style)
resolved)))
(list (car final) winner invalid (cdr final)))))
(defun ecss--property-provenance (winner invalid source)
"Return provenance from WINNER, INVALID state, and fallback SOURCE."
(if winner
(ecss--candidate-provenance
winner :valid (not invalid)
:value-source source
:fallback (and invalid source))
(list :source source :origin (if (eq source 'initial) 'ua 'inherit))))
(defun ecss--compute-property-values
(schemas table parent-style custom subject resolver diagnostics provenance-p)
"Compute SCHEMAS property values from TABLE and context.
PARENT-STYLE and CUSTOM supply inherited values. SUBJECT and RESOLVER handle
explicit sources. DIAGNOSTICS records failures; PROVENANCE-P retains facts."
(let (values active provenance)
(dolist (property (ecss--schema-set-order schemas))
(let ((schema (ecss--schema-for schemas property)))
(unless (ecss-property-schema-shorthand schema)
(pcase-let ((`(,value ,winner ,invalid ,source)
(ecss--resolve-property-candidates
schema (gethash property table) parent-style custom
subject resolver diagnostics)))
(setq values (plist-put values property value))
(when (or (and winner (not invalid))
(and (ecss-property-schema-inherits schema)
(ecss--parent-property-active-p parent-style property)))
(push property active))
(when provenance-p
(setq provenance
(plist-put provenance property
(ecss--property-provenance
winner invalid source))))))))
(list values (nreverse active) provenance)))
(defun ecss--validate-rule-declarations (schemas rule)
"Validate canonical declarations in RULE against SCHEMAS."
(unless (ecss--declaration-list-p (ecss-rule-declarations rule))
(signal 'ecss-invalid-rule (list :declarations rule)))
(cl-loop for (property _value) on (ecss-rule-declarations rule) by #'cddr
do (ecss--validate-declaration-property schemas property)
for schema = (ecss--schema-for schemas property)
when (and schema (ecss-property-schema-shorthand schema))
do (signal 'ecss-invalid-rule (list :shorthand-snapshot property))))
(defun ecss--validate-rule-snapshot (schemas rule)
"Return RULE after validating it against SCHEMAS."
(unless (ecss-rule-p rule)
(signal 'ecss-invalid-rule (list :rule rule)))
(ecss--validate-selector (ecss-rule-selector rule))
(when (ecss-rule-scope rule)
(ecss--validate-selector (ecss-rule-scope rule)))
(ecss--validate-origin (ecss-rule-origin rule))
(unless (natnump (ecss-rule-source-order rule))
(signal 'ecss-invalid-rule (list :source-order rule)))
(ecss--validate-rule-declarations schemas rule)
rule)
(defun ecss--active-rules (schemas stylesheet rules)
"Return active rules for SCHEMAS from STYLESHEET or RULES."
(when (and stylesheet rules)
(signal 'ecss-invalid-rule (list :stylesheet-and-rules)))
(let ((active (cond (stylesheet
(ecss--stylesheet-check stylesheet)
(ecss--stylesheet-rules stylesheet))
(rules rules))))
(when rules
(mapc (lambda (rule) (ecss--validate-rule-snapshot schemas rule)) active))
active))
;;;###autoload
(cl-defun ecss-compute-style
(schemas subject &key stylesheet rules declarations parent-style
adapter provenance value-resolver)
"Compute a deterministic style for SUBJECT using SCHEMAS.
STYLESHEET or RULES supplies validated rules. DECLARATIONS are inline.
PARENT-STYLE may be another computed style or a values plist. ADAPTER exposes
caller-owned subjects. PROVENANCE retains winner facts. VALUE-RESOLVER, when
non-nil, is the only function allowed to evaluate caller-owned value sources;
it receives VALUE, PROPERTY, and SUBJECT."
(ecss--schema-set-check schemas)
(let ((adapter (or adapter ecss-default-subject-adapter)))
(unless (ecss-subject-adapter-p adapter)
(signal 'wrong-type-argument (list 'ecss-subject-adapter-p adapter)))
(let* ((rules (ecss--active-rules schemas stylesheet rules))
(table (ecss--group-candidates
(ecss--collect-candidates
schemas subject adapter declarations rules)))
(diagnostics (list nil))
(raw-facts (ecss--custom-raw-table
table parent-style subject value-resolver provenance))
(custom (ecss--resolved-custom-properties
(car raw-facts) diagnostics)))
(pcase-let ((`(,values ,active ,property-facts)
(ecss--compute-property-values
schemas table parent-style custom subject value-resolver
diagnostics provenance)))
(ecss--make-computed-style
:values values :custom-properties custom :active-properties active
:provenance (and provenance
(append (cadr raw-facts) property-facts))
:diagnostics (nreverse (car diagnostics)))))))
(defun ecss--computed-style-check (style)
"Return STYLE or signal when it is not a computed style."
(unless (ecss-computed-style-p style)
(signal 'wrong-type-argument (list 'ecss-computed-style-p style)))
style)
(defun ecss-computed-style-values (style)
"Return a defensive values plist from computed STYLE."
(ecss--computed-style-check style)
(copy-tree (ecss--computed-style-values style)))
(defun ecss-computed-style-custom-properties (style)
"Return a defensive custom property plist from computed STYLE."
(ecss--computed-style-check style)
(copy-tree (ecss--computed-style-custom-properties style)))
(defun ecss-computed-style-active-properties (style)
"Return actively supplied property identifiers from computed STYLE."
(ecss--computed-style-check style)
(copy-sequence (ecss--computed-style-active-properties style)))
(defun ecss-computed-style-provenance (style)
"Return defensive winner provenance from computed STYLE."
(ecss--computed-style-check style)
(copy-tree (ecss--computed-style-provenance style)))
(defun ecss-computed-style-diagnostics (style)
"Return defensive diagnostics from computed STYLE."
(ecss--computed-style-check style)
(copy-tree (ecss--computed-style-diagnostics style)))
(defun ecss-computed-style-value (style property &optional fallback)
"Return PROPERTY from computed STYLE, or FALLBACK when absent."
(let ((values (ecss--computed-style-values
(ecss--computed-style-check style))))
(if (plist-member values property) (plist-get values property) fallback)))
(defun ecss-computed-style-present-p (style property)
"Return non-nil when PROPERTY is actively supplied in computed STYLE."
(memq property
(ecss--computed-style-active-properties
(ecss--computed-style-check style))))
(provide 'ecss-cascade)
;;; ecss-cascade.el ends here