905d3523ac
Expose one-shot string and buffer styling plus reactive range watches over the same schema, mutation, binding, and retained surface core. Verification: 712 ERT tests; 92 doctests; shuffled seed 20260806; compile-all WERROR=t.
927 lines
39 KiB
EmacsLisp
927 lines
39 KiB
EmacsLisp
;;; tp-style.el --- Schema-driven text property cascade -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Geekinney
|
|
|
|
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
|
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation; either version 3 of
|
|
;; the License, or (at your option) any later version.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Pure property schema, structured selector, and cascade computation for TP.
|
|
;; This module owns no buffers, markers, mounts, or reactive subscriptions.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'seq)
|
|
(require 'tp-core)
|
|
|
|
(define-error 'tp-style-error "TP style error")
|
|
(define-error 'tp-invalid-property-schema "Invalid TP property schema"
|
|
'tp-style-error)
|
|
(define-error 'tp-invalid-style "Invalid TP style declaration"
|
|
'tp-style-error)
|
|
(define-error 'tp-invalid-selector "Invalid TP selector" 'tp-style-error)
|
|
|
|
(cl-defstruct (tp-property-schema
|
|
(:constructor tp--make-property-schema))
|
|
"Schema governing one namespaced cascade property."
|
|
id initial inherits normalizer validator equality merge projector shorthand)
|
|
|
|
(cl-defstruct (tp-subject (:constructor tp--make-subject))
|
|
"Generic selector subject independent of any rendering consumer."
|
|
type id classes attributes state parent children)
|
|
|
|
(cl-defstruct (tp-computed-style (:constructor tp--make-computed-style))
|
|
"Computed values, active properties, custom properties, and provenance."
|
|
values custom-properties active-properties provenance)
|
|
|
|
(cl-defstruct (tp--computed-source (:constructor tp--make-computed-source))
|
|
function)
|
|
|
|
(cl-defstruct (tp--wide (:constructor tp--make-wide)) kind)
|
|
(cl-defstruct (tp--important (:constructor tp--make-important)) value)
|
|
(cl-defstruct (tp--var-ref (:constructor tp--make-var-ref))
|
|
name fallback-present-p fallback)
|
|
|
|
(cl-defstruct (tp--style-rule (:constructor tp--make-style-rule))
|
|
selector declarations origin layer scope specificity source-order)
|
|
|
|
(cl-defstruct (tp--candidate (:constructor tp--make-candidate))
|
|
property value origin important layer specificity scope-distance
|
|
source-order declaration-order selector)
|
|
|
|
(defconst tp--style-origin-order
|
|
'(default theme package author inline runtime user)
|
|
"Cascade origins ordered from weakest to strongest.")
|
|
|
|
(defconst tp--wide-kinds '(initial inherit unset revert revert-layer)
|
|
"Supported CSS-wide value kinds.")
|
|
|
|
(defconst tp--style-all-rules (make-symbol "tp-all-style-rules"))
|
|
(defconst tp--style-invalid (make-symbol "tp-invalid-style-value"))
|
|
(defconst tp--style-absent (make-symbol "tp-absent-style-value"))
|
|
|
|
(defvar tp--property-schemas (make-hash-table :test #'eq))
|
|
(defvar tp--property-schema-order nil)
|
|
(defvar tp--named-styles (make-hash-table :test #'eq))
|
|
(defvar tp--stylesheet-rules nil)
|
|
(defvar tp--cascade-layers nil)
|
|
(defvar tp--style-source-order 0)
|
|
|
|
(defconst tp--style-runtime-properties
|
|
'(tp-name tp-layers tp-meta tp-hidden tp-text)
|
|
"Runtime-only properties excluded from declarative text styles.")
|
|
|
|
(defun tp--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 tp--custom-property-p (property)
|
|
"Return non-nil when PROPERTY names a custom cascade variable."
|
|
(and (symbolp property)
|
|
(string-prefix-p "--" (symbol-name property))))
|
|
|
|
(defun tp--callable-option-p (value)
|
|
"Return non-nil when VALUE is nil or callable."
|
|
(or (null value) (functionp value)))
|
|
|
|
(defun tp--validate-schema-functions (options)
|
|
"Validate callable fields in schema OPTIONS."
|
|
(dolist (key '(:normalizer :validator :equality :merge
|
|
:projector :shorthand))
|
|
(unless (tp--callable-option-p (plist-get options key))
|
|
(signal 'tp-invalid-property-schema
|
|
(list key (plist-get options key))))))
|
|
|
|
(defun tp--schema-option (options key default)
|
|
"Return KEY from OPTIONS when present, otherwise DEFAULT."
|
|
(if (plist-member options key) (plist-get options key) default))
|
|
|
|
(defun tp--build-property-schema (id options)
|
|
"Build and validate a property schema for ID from OPTIONS."
|
|
(unless (tp--canonical-property-id-p id)
|
|
(signal 'tp-invalid-property-schema (list :property id)))
|
|
(tp--validate-schema-functions options)
|
|
(tp--make-property-schema
|
|
:id id
|
|
:initial (plist-get options :initial)
|
|
:inherits (and (plist-get options :inherits) t)
|
|
:normalizer (tp--schema-option options :normalizer #'identity)
|
|
:validator (tp--schema-option options :validator (lambda (_value) t))
|
|
:equality (tp--schema-option options :equality #'equal)
|
|
:merge (tp--schema-option options :merge (lambda (_old new) new))
|
|
:projector (plist-get options :projector)
|
|
:shorthand (plist-get options :shorthand)))
|
|
|
|
;;;###autoload
|
|
(defun tp-define-property (id &rest options)
|
|
"Register namespaced property ID using schema OPTIONS.
|
|
OPTIONS support :initial, :inherits, :normalizer, :validator, :equality,
|
|
:merge, :projector, and :shorthand. Registration is atomic."
|
|
(let ((schema (tp--build-property-schema id options)))
|
|
(unless (gethash id tp--property-schemas)
|
|
(setq tp--property-schema-order
|
|
(append tp--property-schema-order (list id))))
|
|
(puthash id schema tp--property-schemas)
|
|
schema))
|
|
|
|
(defun tp-property-schema (id)
|
|
"Return the registered property schema for ID, or nil."
|
|
(gethash id tp--property-schemas))
|
|
|
|
(defun tp-text-property-id (property)
|
|
"Return the canonical `text/' schema id for Emacs PROPERTY."
|
|
(unless (symbolp property)
|
|
(signal 'wrong-type-argument (list 'symbolp property)))
|
|
(intern (format "text/%s" property)))
|
|
|
|
(defun tp--text-property-inherits-p (property)
|
|
"Return non-nil when PROPERTY inherits in TP's text domain."
|
|
(memq property '(face font-lock-face)))
|
|
|
|
(defun tp--text-property-merge-function (property)
|
|
"Return the schema merge function for Emacs PROPERTY."
|
|
(if (memq property tp-face-properties)
|
|
#'tp--merge-face-values
|
|
(lambda (_old new) new)))
|
|
|
|
(defun tp-register-text-property (property)
|
|
"Register and return a canonical schema for Emacs PROPERTY."
|
|
(let ((id (tp-text-property-id property)))
|
|
(or (tp-property-schema id)
|
|
(tp-define-property
|
|
id :initial nil :inherits (tp--text-property-inherits-p property)
|
|
:equality #'equal :merge (tp--text-property-merge-function property)
|
|
:projector (lambda (value) (list property value))))))
|
|
|
|
(defun tp--register-default-text-properties ()
|
|
"Register schemas for TP's known native Emacs properties."
|
|
(dolist (property tp--builtin-text-properties)
|
|
(tp-register-text-property property)))
|
|
|
|
(defun tp-text-declarations (properties)
|
|
"Convert raw Emacs PROPERTIES to canonical text declarations."
|
|
(unless (tp--declaration-list-p properties)
|
|
(signal 'tp-invalid-style (list :text-properties properties)))
|
|
(cl-loop for (property value) on properties by #'cddr
|
|
unless (memq property tp--style-runtime-properties)
|
|
append (list (tp-property-schema-id
|
|
(tp-register-text-property property))
|
|
(copy-tree value))))
|
|
|
|
(defun tp-style-reset-rules ()
|
|
"Clear stylesheet rules and their cascade-layer order."
|
|
(setq tp--stylesheet-rules nil
|
|
tp--cascade-layers nil
|
|
tp--style-source-order 0))
|
|
|
|
(defun tp-style-reset ()
|
|
"Clear all TP style schemas, definitions, rules, and ordering state."
|
|
(clrhash tp--property-schemas)
|
|
(clrhash tp--named-styles)
|
|
(setq tp--property-schema-order nil)
|
|
(tp-style-reset-rules)
|
|
(tp--register-default-text-properties))
|
|
|
|
(defun tp-undefine-style (name)
|
|
"Remove named style NAME and return nil."
|
|
(remhash name tp--named-styles)
|
|
nil)
|
|
|
|
;;;###autoload
|
|
(defun tp-computed (function)
|
|
"Return an explicit computed value source wrapping FUNCTION."
|
|
(unless (functionp function)
|
|
(signal 'wrong-type-argument (list 'functionp function)))
|
|
(tp--make-computed-source :function function))
|
|
|
|
;;;###autoload
|
|
(defun tp-wide-value (kind)
|
|
"Return a tagged CSS-wide value of KIND."
|
|
(unless (memq kind tp--wide-kinds)
|
|
(signal 'tp-invalid-style (list :wide-value kind)))
|
|
(tp--make-wide :kind kind))
|
|
|
|
;;;###autoload
|
|
(defun tp-important (value)
|
|
"Return VALUE tagged as an important declaration."
|
|
(tp--make-important :value value))
|
|
|
|
;;;###autoload
|
|
(defun tp-var (name &rest fallback)
|
|
"Return a custom-property reference to NAME with optional FALLBACK."
|
|
(unless (tp--custom-property-p name)
|
|
(signal 'tp-invalid-style (list :custom-property name)))
|
|
(when (> (length fallback) 1)
|
|
(signal 'wrong-number-of-arguments (list 'tp-var (+ 1 (length fallback)))))
|
|
(tp--make-var-ref :name name
|
|
:fallback-present-p (and fallback t)
|
|
:fallback (car fallback)))
|
|
|
|
(cl-defun tp-subject-create (&key type id classes attributes state parent children)
|
|
"Create a generic cascade subject from TYPE, ID, and metadata.
|
|
CLASSES and STATE are symbol lists. ATTRIBUTES is an alist. PARENT and
|
|
CHILDREN must be TP subjects when present."
|
|
(when (and parent (not (tp-subject-p parent)))
|
|
(signal 'wrong-type-argument (list 'tp-subject-p parent)))
|
|
(let ((subject (tp--make-subject
|
|
:type type :id id :classes (copy-sequence classes)
|
|
:attributes (copy-tree attributes)
|
|
:state (copy-sequence state) :parent parent)))
|
|
(tp-subject-set-children subject children)))
|
|
|
|
(defun tp-subject-set-children (subject children)
|
|
"Replace SUBJECT's CHILDREN and establish their parent links."
|
|
(unless (tp-subject-p subject)
|
|
(signal 'wrong-type-argument (list 'tp-subject-p subject)))
|
|
(dolist (child children)
|
|
(unless (tp-subject-p child)
|
|
(signal 'wrong-type-argument (list 'tp-subject-p child))))
|
|
(dolist (old-child (tp-subject-children subject))
|
|
(when (eq (tp-subject-parent old-child) subject)
|
|
(setf (tp-subject-parent old-child) nil)))
|
|
(setf (tp-subject-children subject) (copy-sequence children))
|
|
(dolist (child children)
|
|
(setf (tp-subject-parent child) subject))
|
|
subject)
|
|
|
|
(defun tp--subject-attribute-cell (subject name)
|
|
"Return SUBJECT's attribute cell for NAME."
|
|
(assq name (tp-subject-attributes subject)))
|
|
|
|
(defun tp--subject-previous-siblings (subject)
|
|
"Return SUBJECT's preceding siblings in document order."
|
|
(when-let ((parent (tp-subject-parent subject)))
|
|
(let ((siblings (tp-subject-children parent)) result)
|
|
(while (and siblings (not (eq (car siblings) subject)))
|
|
(push (pop siblings) result))
|
|
(nreverse result))))
|
|
|
|
(defun tp--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 tp--validate-selector-list (selectors)
|
|
"Validate every selector in SELECTORS."
|
|
(and selectors (cl-every #'tp--selector-valid-p selectors)))
|
|
|
|
(defun tp--selector-valid-p (selector)
|
|
"Return non-nil when SELECTOR is a valid structured selector."
|
|
(pcase (and (consp selector) (car selector))
|
|
((or :type :id :class :state)
|
|
(tp--selector-form-p selector (car selector) 1))
|
|
(:attr (memq (length (cdr selector)) '(1 2)))
|
|
((or :and :is :where :not)
|
|
(tp--validate-selector-list (cdr selector)))
|
|
((or :descendant :child :adjacent :sibling)
|
|
(and (tp--selector-form-p selector (car selector) 2)
|
|
(tp--validate-selector-list (cdr selector))))
|
|
(:universal (null (cdr selector)))
|
|
(_ nil)))
|
|
|
|
(defun tp--validate-selector (selector)
|
|
"Signal an error unless SELECTOR is structurally valid."
|
|
(unless (tp--selector-valid-p selector)
|
|
(signal 'tp-invalid-selector (list selector)))
|
|
selector)
|
|
|
|
(defun tp--selector-match-attribute (selector subject)
|
|
"Return whether attribute SELECTOR matches SUBJECT."
|
|
(let ((cell (tp--subject-attribute-cell subject (nth 1 selector))))
|
|
(and cell
|
|
(or (= (length selector) 2)
|
|
(equal (cdr cell) (nth 2 selector))))))
|
|
|
|
(defun tp--selector-match-descendant (selector subject)
|
|
"Return whether descendant SELECTOR matches SUBJECT."
|
|
(and (tp-selector-match-p (nth 2 selector) subject)
|
|
(cl-loop for parent = (tp-subject-parent subject)
|
|
then (tp-subject-parent parent)
|
|
while parent
|
|
thereis (tp-selector-match-p (nth 1 selector) parent))))
|
|
|
|
(defun tp--selector-match-adjacent (selector subject)
|
|
"Return whether adjacent SELECTOR matches SUBJECT."
|
|
(let ((siblings (tp--subject-previous-siblings subject)))
|
|
(and siblings
|
|
(tp-selector-match-p (nth 1 selector) (car (last siblings)))
|
|
(tp-selector-match-p (nth 2 selector) subject))))
|
|
|
|
(defun tp--selector-match-sibling (selector subject)
|
|
"Return whether sibling SELECTOR matches SUBJECT."
|
|
(and (tp-selector-match-p (nth 2 selector) subject)
|
|
(cl-some (lambda (sibling)
|
|
(tp-selector-match-p (nth 1 selector) sibling))
|
|
(tp--subject-previous-siblings subject))))
|
|
|
|
(defun tp--selector-match-valid (selector subject)
|
|
"Match already validated SELECTOR against SUBJECT."
|
|
(pcase (car selector)
|
|
(:universal t)
|
|
(:type (equal (nth 1 selector) (tp-subject-type subject)))
|
|
(:id (equal (nth 1 selector) (tp-subject-id subject)))
|
|
(:class (memq (nth 1 selector) (tp-subject-classes subject)))
|
|
(:state (memq (nth 1 selector) (tp-subject-state subject)))
|
|
(:attr (tp--selector-match-attribute selector subject))
|
|
(:and (cl-every (lambda (item) (tp-selector-match-p item subject))
|
|
(cdr selector)))
|
|
(:is (cl-some (lambda (item) (tp-selector-match-p item subject))
|
|
(cdr selector)))
|
|
(:where (cl-some (lambda (item) (tp-selector-match-p item subject))
|
|
(cdr selector)))
|
|
(:not (not (cl-some (lambda (item) (tp-selector-match-p item subject))
|
|
(cdr selector))))
|
|
(:descendant (tp--selector-match-descendant selector subject))
|
|
(:child (and (tp-selector-match-p (nth 2 selector) subject)
|
|
(when-let ((parent (tp-subject-parent subject)))
|
|
(tp-selector-match-p (nth 1 selector) parent))))
|
|
(:adjacent (tp--selector-match-adjacent selector subject))
|
|
(:sibling (tp--selector-match-sibling selector subject))))
|
|
|
|
;;;###autoload
|
|
(defun tp-selector-match-p (selector subject)
|
|
"Return non-nil when structured SELECTOR matches SUBJECT."
|
|
(unless (tp-subject-p subject)
|
|
(signal 'wrong-type-argument (list 'tp-subject-p subject)))
|
|
(tp--validate-selector selector)
|
|
(tp--selector-match-valid selector subject))
|
|
|
|
(defun tp--specificity-add (left right)
|
|
"Add specificity triples LEFT and RIGHT."
|
|
(cl-mapcar #'+ left right))
|
|
|
|
(defun tp--specificity-max (values)
|
|
"Return the lexicographically greatest specificity in VALUES."
|
|
(cl-reduce (lambda (left right)
|
|
(if (tp--specificity-greater-p left right) left right))
|
|
values :initial-value '(0 0 0)))
|
|
|
|
(defun tp--specificity-list-sum (selectors)
|
|
"Return the combined specificity of SELECTORS."
|
|
(cl-reduce #'tp--specificity-add selectors
|
|
:key #'tp-selector-specificity
|
|
:initial-value '(0 0 0)))
|
|
|
|
(defun tp-selector-specificity (selector)
|
|
"Return SELECTOR specificity as an (ID CLASS TYPE) list."
|
|
(tp--validate-selector selector)
|
|
(pcase (car selector)
|
|
(:id '(1 0 0))
|
|
((or :class :attr :state) '(0 1 0))
|
|
(:type '(0 0 1))
|
|
((or :universal :where) '(0 0 0))
|
|
(:and (tp--specificity-list-sum (cdr selector)))
|
|
((or :is :not)
|
|
(tp--specificity-max (mapcar #'tp-selector-specificity
|
|
(cdr selector))))
|
|
((or :descendant :child :adjacent :sibling)
|
|
(tp--specificity-list-sum (cdr selector)))))
|
|
|
|
(defun tp--declaration-list-p (declarations)
|
|
"Return non-nil when DECLARATIONS is an even property/value list."
|
|
(and (listp declarations) (zerop (% (length declarations) 2))))
|
|
|
|
(defun tp--validate-declaration-property (property)
|
|
"Return PROPERTY when it names a registered or custom property."
|
|
(unless (or (tp--custom-property-p property)
|
|
(gethash property tp--property-schemas))
|
|
(signal 'tp-invalid-style (list :unknown-property property)))
|
|
property)
|
|
|
|
(defun tp--unwrap-important (value)
|
|
"Return VALUE and whether it carries an important tag."
|
|
(if (tp--important-p value)
|
|
(cons (tp--important-value value) t)
|
|
(cons value nil)))
|
|
|
|
(defun tp--tag-expanded-important (declarations important)
|
|
"Tag expanded DECLARATIONS as IMPORTANT when requested."
|
|
(if (not important)
|
|
declarations
|
|
(cl-loop for (property value) on declarations by #'cddr
|
|
append (list property (tp-important value)))))
|
|
|
|
(defun tp--expand-declaration (property value)
|
|
"Expand one PROPERTY VALUE declaration into canonical longhands."
|
|
(tp--validate-declaration-property property)
|
|
(let ((schema (gethash property tp--property-schemas)))
|
|
(if-let ((expander (and schema (tp-property-schema-shorthand schema))))
|
|
(pcase-let* ((`(,raw . ,important) (tp--unwrap-important value))
|
|
(expanded (funcall expander raw)))
|
|
(unless (tp--declaration-list-p expanded)
|
|
(signal 'tp-invalid-style (list :shorthand property expanded)))
|
|
(cl-loop for (longhand _value) on expanded by #'cddr
|
|
do (tp--validate-declaration-property longhand)
|
|
when (tp-property-schema-shorthand
|
|
(gethash longhand tp--property-schemas))
|
|
do (signal 'tp-invalid-style
|
|
(list :nested-shorthand property longhand)))
|
|
(tp--tag-expanded-important expanded important))
|
|
(list property value))))
|
|
|
|
(defun tp--expand-declarations (declarations)
|
|
"Validate and expand DECLARATIONS into canonical longhands."
|
|
(unless (tp--declaration-list-p declarations)
|
|
(signal 'tp-invalid-style (list :declarations declarations)))
|
|
(cl-loop for (property value) on declarations by #'cddr
|
|
append (tp--expand-declaration property value)))
|
|
|
|
;;;###autoload
|
|
(defun tp-define-style (name declarations)
|
|
"Define named style NAME from DECLARATIONS and return NAME."
|
|
(unless (symbolp name)
|
|
(signal 'tp-invalid-style (list :style-name name)))
|
|
(let ((expanded (tp--expand-declarations declarations)))
|
|
(puthash name (copy-tree expanded) tp--named-styles)
|
|
name))
|
|
|
|
(defun tp-style-declarations (name)
|
|
"Return a defensive copy of named style NAME declarations."
|
|
(when-let ((declarations (gethash name tp--named-styles)))
|
|
(copy-tree declarations)))
|
|
|
|
(defun tp--validate-rule-origin (origin)
|
|
"Return ORIGIN when it is a registered cascade origin."
|
|
(unless (memq origin tp--style-origin-order)
|
|
(signal 'tp-invalid-style (list :origin origin)))
|
|
origin)
|
|
|
|
(defun tp--register-cascade-layer (layer)
|
|
"Register LAYER in first-seen order when non-nil."
|
|
(when (and layer (not (memq layer tp--cascade-layers)))
|
|
(setq tp--cascade-layers (append tp--cascade-layers (list layer)))))
|
|
|
|
;;;###autoload
|
|
(cl-defun tp-stylesheet-add-rule
|
|
(selector declarations &key (origin 'author) layer scope)
|
|
"Add a structured SELECTOR rule with DECLARATIONS.
|
|
ORIGIN defaults to `author'. LAYER is ordered by first appearance. SCOPE,
|
|
when non-nil, is a selector that must match the subject or an ancestor."
|
|
(tp--validate-selector selector)
|
|
(when scope (tp--validate-selector scope))
|
|
(tp--validate-rule-origin origin)
|
|
(let ((expanded (tp--expand-declarations declarations)))
|
|
(tp--register-cascade-layer layer)
|
|
(let ((rule (tp--make-style-rule
|
|
:selector (copy-tree selector)
|
|
:declarations (copy-tree expanded)
|
|
:origin origin :layer layer :scope (copy-tree scope)
|
|
:specificity (tp-selector-specificity selector)
|
|
:source-order (cl-incf tp--style-source-order))))
|
|
(setq tp--stylesheet-rules
|
|
(append tp--stylesheet-rules (list rule)))
|
|
rule)))
|
|
|
|
(defun tp--scope-distance (scope subject)
|
|
"Return distance from SUBJECT to matching SCOPE, or nil."
|
|
(if (null scope)
|
|
most-positive-fixnum
|
|
(cl-loop for current = subject then (tp-subject-parent current)
|
|
for distance from 0
|
|
while current
|
|
when (tp-selector-match-p scope current) return distance)))
|
|
|
|
(defun tp--rule-matches-p (rule subject)
|
|
"Return non-nil if RULE matches SUBJECT."
|
|
(and (tp-selector-match-p (tp--style-rule-selector rule) subject)
|
|
(numberp (tp--scope-distance (tp--style-rule-scope rule) subject))))
|
|
|
|
(defun tp--candidate-from-entry (rule property value subject declaration-order)
|
|
"Create a candidate from RULE PROPERTY VALUE for SUBJECT.
|
|
DECLARATION-ORDER is the property's position within RULE."
|
|
(pcase-let ((`(,raw . ,important) (tp--unwrap-important value)))
|
|
(tp--make-candidate
|
|
:property property :value raw
|
|
:origin (tp--style-rule-origin rule) :important important
|
|
:layer (tp--style-rule-layer rule)
|
|
:specificity (tp--style-rule-specificity rule)
|
|
:scope-distance (tp--scope-distance (tp--style-rule-scope rule) subject)
|
|
:source-order (tp--style-rule-source-order rule)
|
|
:declaration-order declaration-order
|
|
:selector (tp--style-rule-selector rule))))
|
|
|
|
(defun tp--rule-candidates (rule subject)
|
|
"Return all property candidates from matching RULE for SUBJECT."
|
|
(when (tp--rule-matches-p rule subject)
|
|
(cl-loop for (property value) on (tp--style-rule-declarations rule)
|
|
by #'cddr
|
|
for declaration-order from 0
|
|
collect (tp--candidate-from-entry
|
|
rule property value subject declaration-order))))
|
|
|
|
(defun tp--inline-candidates (declarations)
|
|
"Return inline candidates for DECLARATIONS."
|
|
(when declarations
|
|
(cl-loop for (property value) on (tp--expand-declarations declarations)
|
|
by #'cddr
|
|
for declaration-order from 0
|
|
collect
|
|
(pcase-let ((`(,raw . ,important) (tp--unwrap-important value)))
|
|
(tp--make-candidate
|
|
:property property :value raw :origin 'inline
|
|
:important important :layer nil :specificity '(1 0 0)
|
|
:scope-distance most-positive-fixnum
|
|
:source-order (1+ tp--style-source-order)
|
|
:declaration-order declaration-order
|
|
:selector :inline)))))
|
|
|
|
(defun tp--collect-candidates (subject declarations rules)
|
|
"Collect matching candidates for SUBJECT, DECLARATIONS, and RULES."
|
|
(append
|
|
(cl-loop for rule in rules append (tp--rule-candidates rule subject))
|
|
(tp--inline-candidates declarations)))
|
|
|
|
(defun tp--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 tp--origin-rank (origin)
|
|
"Return precedence rank for ORIGIN."
|
|
(or (cl-position origin tp--style-origin-order) -1))
|
|
|
|
(defun tp--layer-rank (candidate)
|
|
"Return cascade layer rank for CANDIDATE."
|
|
(let ((layer (tp--candidate-layer candidate))
|
|
(important (tp--candidate-important candidate)))
|
|
(cond
|
|
((and important (null layer)) -1000000)
|
|
((null layer) 1000000)
|
|
(important (- (or (cl-position layer tp--cascade-layers) 0)))
|
|
(t (or (cl-position layer tp--cascade-layers) 0)))))
|
|
|
|
(defun tp--compare-number (left right)
|
|
"Compare LEFT and RIGHT, returning 1, -1, or 0."
|
|
(cond ((> left right) 1) ((< left right) -1) (t 0)))
|
|
|
|
(defun tp--candidate-ranks (candidate)
|
|
"Return ordered scalar ranks for CANDIDATE."
|
|
(list (if (tp--candidate-important candidate) 1 0)
|
|
(tp--origin-rank (tp--candidate-origin candidate))
|
|
(tp--layer-rank candidate)))
|
|
|
|
(defun tp--rank-list-comparison (left right)
|
|
"Compare numeric rank lists LEFT and RIGHT."
|
|
(catch 'comparison
|
|
(cl-mapc (lambda (a b)
|
|
(let ((value (tp--compare-number a b)))
|
|
(unless (zerop value) (throw 'comparison value))))
|
|
left right)
|
|
0))
|
|
|
|
(defun tp--candidate-higher-p (left right)
|
|
"Return non-nil when candidate LEFT outranks RIGHT."
|
|
(let ((rank (tp--rank-list-comparison
|
|
(tp--candidate-ranks left) (tp--candidate-ranks right))))
|
|
(cond
|
|
((not (zerop rank)) (> rank 0))
|
|
((not (equal (tp--candidate-specificity left)
|
|
(tp--candidate-specificity right)))
|
|
(tp--specificity-greater-p (tp--candidate-specificity left)
|
|
(tp--candidate-specificity right)))
|
|
((/= (tp--candidate-scope-distance left)
|
|
(tp--candidate-scope-distance right))
|
|
(< (tp--candidate-scope-distance left)
|
|
(tp--candidate-scope-distance right)))
|
|
((/= (tp--candidate-source-order left)
|
|
(tp--candidate-source-order right))
|
|
(> (tp--candidate-source-order left)
|
|
(tp--candidate-source-order right)))
|
|
(t (> (tp--candidate-declaration-order left)
|
|
(tp--candidate-declaration-order right))))))
|
|
|
|
(defun tp--group-candidates (candidates)
|
|
"Group CANDIDATES by property in a hash table."
|
|
(let ((table (make-hash-table :test #'eq)))
|
|
(dolist (candidate candidates)
|
|
(let ((property (tp--candidate-property candidate)))
|
|
(puthash property (cons candidate (gethash property table)) table)))
|
|
(maphash (lambda (property values)
|
|
(puthash property
|
|
(sort values #'tp--candidate-higher-p) table))
|
|
table)
|
|
table))
|
|
|
|
(defun tp--skip-reverted-origin (candidates winner)
|
|
"Remove WINNER's origin and importance group from CANDIDATES."
|
|
(seq-remove
|
|
(lambda (candidate)
|
|
(and (eq (tp--candidate-origin candidate)
|
|
(tp--candidate-origin winner))
|
|
(eq (tp--candidate-important candidate)
|
|
(tp--candidate-important winner))))
|
|
candidates))
|
|
|
|
(defun tp--skip-reverted-layer (candidates winner)
|
|
"Remove WINNER's layer group from CANDIDATES."
|
|
(seq-remove
|
|
(lambda (candidate)
|
|
(and (eq (tp--candidate-origin candidate)
|
|
(tp--candidate-origin winner))
|
|
(eq (tp--candidate-important candidate)
|
|
(tp--candidate-important winner))
|
|
(eq (tp--candidate-layer candidate)
|
|
(tp--candidate-layer winner))))
|
|
candidates))
|
|
|
|
(defun tp--evaluate-computed-source (value)
|
|
"Evaluate VALUE only when it is an explicit computed source."
|
|
(if (tp--computed-source-p value)
|
|
(funcall (tp--computed-source-function value))
|
|
value))
|
|
|
|
(defun tp--parent-values (parent-style)
|
|
"Return computed values plist from PARENT-STYLE."
|
|
(cond ((tp-computed-style-p parent-style)
|
|
(tp-computed-style-values parent-style))
|
|
((listp parent-style) parent-style)
|
|
(t nil)))
|
|
|
|
(defun tp--parent-custom-properties (parent-style)
|
|
"Return custom property plist from PARENT-STYLE."
|
|
(when (tp-computed-style-p parent-style)
|
|
(tp-computed-style-custom-properties parent-style)))
|
|
|
|
(defun tp--parent-property-active-p (parent-style property)
|
|
"Return non-nil when PARENT-STYLE actively contributes PROPERTY."
|
|
(cond
|
|
((tp-computed-style-p parent-style)
|
|
(memq property (tp-computed-style-active-properties parent-style)))
|
|
((listp parent-style) (and (plist-member parent-style property) t))))
|
|
|
|
(defun tp--property-default-value (schema parent-style)
|
|
"Return SCHEMA's inherited or initial value using PARENT-STYLE."
|
|
(let* ((property (tp-property-schema-id schema))
|
|
(parent-values (tp--parent-values parent-style)))
|
|
(if (and (tp-property-schema-inherits schema)
|
|
(plist-member parent-values property))
|
|
(plist-get parent-values property)
|
|
(tp-property-schema-initial schema))))
|
|
|
|
(defun tp--wide-default-value (wide schema parent-style)
|
|
"Resolve non-revert WIDE value for SCHEMA using PARENT-STYLE."
|
|
(pcase (tp--wide-kind wide)
|
|
('initial (tp-property-schema-initial schema))
|
|
('inherit
|
|
(let ((values (tp--parent-values parent-style))
|
|
(property (tp-property-schema-id schema)))
|
|
(if (plist-member values property)
|
|
(plist-get values property)
|
|
(tp-property-schema-initial schema))))
|
|
('unset (if (tp-property-schema-inherits schema)
|
|
(tp--wide-default-value (tp-wide-value 'inherit)
|
|
schema parent-style)
|
|
(tp-property-schema-initial schema)))))
|
|
|
|
(defun tp--custom-raw-table (candidate-table parent-style)
|
|
"Build raw custom properties from CANDIDATE-TABLE and PARENT-STYLE."
|
|
(let ((table (make-hash-table :test #'eq)))
|
|
(cl-loop for (property value) on (tp--parent-custom-properties parent-style)
|
|
by #'cddr do (puthash property value table))
|
|
(maphash
|
|
(lambda (property candidates)
|
|
(when (tp--custom-property-p property)
|
|
(let ((selected (tp--select-custom-candidate candidates table)))
|
|
(if (eq selected tp--style-absent)
|
|
(remhash property table)
|
|
(puthash property selected table)))))
|
|
candidate-table)
|
|
table))
|
|
|
|
(defun tp--select-custom-candidate (candidates inherited-table)
|
|
"Select raw custom value from CANDIDATES and INHERITED-TABLE."
|
|
(let ((remaining candidates) selected done)
|
|
(while (and remaining (not done))
|
|
(let* ((candidate (pop remaining))
|
|
(value (tp--evaluate-computed-source
|
|
(tp--candidate-value candidate))))
|
|
(if (not (tp--wide-p value))
|
|
(setq selected value done t)
|
|
(pcase (tp--wide-kind value)
|
|
('revert (setq remaining
|
|
(tp--skip-reverted-origin remaining candidate)))
|
|
('revert-layer (setq remaining
|
|
(tp--skip-reverted-layer remaining candidate)))
|
|
((or 'inherit 'unset)
|
|
(let ((old (gethash (tp--candidate-property candidate)
|
|
inherited-table tp--style-absent)))
|
|
(setq selected old done t)))
|
|
('initial (setq selected tp--style-absent done t))))))
|
|
(if done selected
|
|
(gethash (tp--candidate-property (car candidates))
|
|
inherited-table tp--style-absent))))
|
|
|
|
(defun tp--resolve-var-fallback (reference raw resolved stack)
|
|
"Resolve REFERENCE fallback using RAW, RESOLVED, and STACK."
|
|
(if (tp--var-ref-fallback-present-p reference)
|
|
(tp--resolve-variable-value (tp--var-ref-fallback reference)
|
|
raw resolved stack)
|
|
tp--style-invalid))
|
|
|
|
(defun tp--resolve-custom-property (name raw resolved stack)
|
|
"Resolve custom property NAME using RAW, RESOLVED, and STACK."
|
|
(let ((memo (gethash name resolved tp--style-absent)))
|
|
(cond
|
|
((not (eq memo tp--style-absent)) memo)
|
|
((memq name stack) tp--style-invalid)
|
|
(t
|
|
(let ((value (gethash name raw tp--style-absent)))
|
|
(if (eq value tp--style-absent)
|
|
tp--style-invalid
|
|
(let ((answer (tp--resolve-variable-value
|
|
value raw resolved (cons name stack))))
|
|
(puthash name answer resolved)
|
|
answer)))))))
|
|
|
|
(defun tp--resolve-variable-value (value raw resolved stack)
|
|
"Resolve custom references in VALUE using RAW, RESOLVED, and STACK."
|
|
(if (not (tp--var-ref-p value))
|
|
value
|
|
(let ((answer (tp--resolve-custom-property
|
|
(tp--var-ref-name value) raw resolved stack)))
|
|
(if (eq answer tp--style-invalid)
|
|
(tp--resolve-var-fallback value raw resolved stack)
|
|
answer))))
|
|
|
|
(defun tp--resolved-custom-properties (raw)
|
|
"Return resolved custom properties plist from RAW table."
|
|
(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 (tp--resolve-custom-property name raw resolved nil)))
|
|
(unless (eq value tp--style-invalid)
|
|
(setq result (plist-put result name value)))))
|
|
result))
|
|
|
|
(defun tp--resolve-property-value (value schema parent-style custom)
|
|
"Resolve VALUE for SCHEMA using PARENT-STYLE and CUSTOM properties."
|
|
(setq value (tp--evaluate-computed-source value))
|
|
(cond
|
|
((and (tp--wide-p value)
|
|
(memq (tp--wide-kind value) '(initial inherit unset)))
|
|
(tp--wide-default-value value schema parent-style))
|
|
((tp--var-ref-p value)
|
|
(let ((raw (make-hash-table :test #'eq))
|
|
(resolved (make-hash-table :test #'eq)))
|
|
(cl-loop for (name item) on custom by #'cddr
|
|
do (puthash name item raw))
|
|
(tp--resolve-variable-value value raw resolved nil)))
|
|
(t value)))
|
|
|
|
(defun tp--normalize-property-value (schema value)
|
|
"Normalize and validate VALUE for SCHEMA, or return invalid sentinel."
|
|
(if (eq value tp--style-invalid)
|
|
value
|
|
(let ((normalized (funcall (tp-property-schema-normalizer schema) value)))
|
|
(if (funcall (tp-property-schema-validator schema) normalized)
|
|
normalized
|
|
tp--style-invalid))))
|
|
|
|
(defun tp--property-candidate-value (candidate schema parent-style custom)
|
|
"Resolve CANDIDATE for SCHEMA using PARENT-STYLE and CUSTOM."
|
|
(tp--normalize-property-value
|
|
schema
|
|
(tp--resolve-property-value (tp--candidate-value candidate)
|
|
schema parent-style custom)))
|
|
|
|
(defun tp--candidate-provenance (candidate)
|
|
"Return public provenance plist for CANDIDATE."
|
|
(if (null candidate)
|
|
'(:selector :initial :origin default)
|
|
(list :selector (copy-tree (tp--candidate-selector candidate))
|
|
:origin (tp--candidate-origin candidate)
|
|
:important (and (tp--candidate-important candidate) t)
|
|
:layer (tp--candidate-layer candidate)
|
|
:specificity (copy-sequence (tp--candidate-specificity candidate))
|
|
:scope-distance (tp--candidate-scope-distance candidate)
|
|
:source-order (tp--candidate-source-order candidate)
|
|
:declaration-order (tp--candidate-declaration-order candidate))))
|
|
|
|
(defun tp--resolve-property-candidates (schema candidates parent-style custom)
|
|
"Resolve SCHEMA from ordered CANDIDATES, PARENT-STYLE, and CUSTOM."
|
|
(let ((remaining candidates) winner value)
|
|
(while (and remaining (null winner))
|
|
(let* ((candidate (pop remaining))
|
|
(raw (tp--evaluate-computed-source
|
|
(tp--candidate-value candidate))))
|
|
(cond
|
|
((and (tp--wide-p raw) (eq (tp--wide-kind raw) 'revert))
|
|
(setq remaining (tp--skip-reverted-origin remaining candidate)))
|
|
((and (tp--wide-p raw) (eq (tp--wide-kind raw) 'revert-layer))
|
|
(setq remaining (tp--skip-reverted-layer remaining candidate)))
|
|
(t
|
|
(setf (tp--candidate-value candidate) raw)
|
|
(setq winner candidate
|
|
value (tp--property-candidate-value
|
|
candidate schema parent-style custom))))))
|
|
(unless winner
|
|
(setq value (tp--normalize-property-value
|
|
schema (tp--property-default-value schema parent-style))))
|
|
(when (eq value tp--style-invalid)
|
|
(setq value (tp--normalize-property-value
|
|
schema (tp--property-default-value schema parent-style))))
|
|
(cons value winner)))
|
|
|
|
(defun tp--compute-property-values (candidate-table parent-style custom provenance-p)
|
|
"Compute values from CANDIDATE-TABLE, PARENT-STYLE, and CUSTOM.
|
|
When PROVENANCE-P is non-nil, also retain winning declaration facts."
|
|
(let (values active provenance)
|
|
(dolist (property tp--property-schema-order)
|
|
(let ((schema (gethash property tp--property-schemas)))
|
|
(unless (tp-property-schema-shorthand schema)
|
|
(pcase-let ((`(,value . ,winner)
|
|
(tp--resolve-property-candidates
|
|
schema (gethash property candidate-table)
|
|
parent-style custom)))
|
|
(setq values (plist-put values property value))
|
|
(when (or winner value
|
|
(and (tp-property-schema-inherits schema)
|
|
(tp--parent-property-active-p
|
|
parent-style property)))
|
|
(push property active))
|
|
(when provenance-p
|
|
(setq provenance
|
|
(plist-put provenance property
|
|
(tp--candidate-provenance winner))))))))
|
|
(list values (nreverse active) provenance)))
|
|
|
|
;;;###autoload
|
|
(cl-defun tp-compute-style
|
|
(subject &key declarations (rules tp--style-all-rules)
|
|
parent-style provenance)
|
|
"Compute a deterministic style for SUBJECT.
|
|
DECLARATIONS are inline values. RULES defaults to the registered stylesheet;
|
|
explicit nil disables stylesheet rules. PARENT-STYLE may be a computed style
|
|
or values plist. When PROVENANCE is non-nil, winner metadata is retained."
|
|
(unless (tp-subject-p subject)
|
|
(signal 'wrong-type-argument (list 'tp-subject-p subject)))
|
|
(let* ((active-rules (if (eq rules tp--style-all-rules)
|
|
tp--stylesheet-rules rules))
|
|
(candidate-table
|
|
(tp--group-candidates
|
|
(tp--collect-candidates subject declarations active-rules)))
|
|
(raw-custom (tp--custom-raw-table candidate-table parent-style))
|
|
(custom (tp--resolved-custom-properties raw-custom)))
|
|
(pcase-let ((`(,values ,active ,facts)
|
|
(tp--compute-property-values
|
|
candidate-table parent-style custom provenance)))
|
|
(tp--make-computed-style
|
|
:values values :custom-properties custom
|
|
:active-properties active :provenance facts))))
|
|
|
|
(defun tp--projected-value (schema values active)
|
|
"Project SCHEMA from computed VALUES when its PROPERTY is ACTIVE."
|
|
(when-let ((projector (tp-property-schema-projector schema)))
|
|
(let* ((property (tp-property-schema-id schema))
|
|
(value (plist-get values property)))
|
|
(when (or value (memq property active))
|
|
(funcall projector value)))))
|
|
|
|
;;;###autoload
|
|
(defun tp-project-style (style)
|
|
"Project computed STYLE into final direct Emacs text properties."
|
|
(unless (tp-computed-style-p style)
|
|
(signal 'wrong-type-argument (list 'tp-computed-style-p style)))
|
|
(let ((values (tp-computed-style-values style))
|
|
(active (tp-computed-style-active-properties style))
|
|
result)
|
|
(dolist (property tp--property-schema-order)
|
|
(let* ((schema (gethash property tp--property-schemas))
|
|
(projected (and (not (tp-property-schema-shorthand schema))
|
|
(tp--projected-value schema values active))))
|
|
(when projected
|
|
(unless (tp--declaration-list-p projected)
|
|
(signal 'tp-invalid-style (list :projection property projected)))
|
|
(setq result (tp--deep-merge-plist result projected)))))
|
|
result))
|
|
|
|
(defun tp--project-text-declarations (declarations)
|
|
"Project native text property DECLARATIONS through the style core."
|
|
(tp-project-style
|
|
(tp-compute-style
|
|
(tp-subject-create :type 'text)
|
|
:declarations (tp-text-declarations declarations)
|
|
:rules nil)))
|
|
|
|
(tp--register-default-text-properties)
|
|
|
|
(provide 'tp-style)
|
|
;;; tp-style.el ends here
|