feat(tp): add schema-driven cascade engine
Introduce the pure TP 1.0 property schema, selector, cascade, custom-property, computed-value, provenance, and Emacs projection kernel. Compile static legacy layer definitions into canonical named styles without freezing parameterized or reactive definitions.\n\nVerified with 667 ERT tests, 92 doctests, shuffled seed 20260806, and compile-all with warnings as errors.
This commit is contained in:
Kinneyzhang
parent
ec30126b2d
commit
ef31a67beb
@ -6,6 +6,7 @@ All notable changes to the tp library are documented here.
|
||||
|
||||
### Added
|
||||
|
||||
- The first TP 1.0 runtime slice: `tp-style.el` provides atomic namespaced property schemas, structured subject selectors and combinators, deterministic origin/importance/layer/specificity/scope/source-order cascade, property-specific inheritance, tagged CSS-wide values, custom-property fallback/cycle handling, explicit `tp-computed` value sources, named declarations, provenance, and final Emacs-property projection. Ordinary function values remain literal.
|
||||
- Internal Stage 2 canonical façade records and dataflow:
|
||||
`tp--native-range`, `tp--presence`, `tp--request`, `tp--match`,
|
||||
and `tp--result`. Public entry points and historical return shapes
|
||||
|
||||
2
Makefile
2
Makefile
@ -19,7 +19,7 @@ WERROR ?= nil
|
||||
TEST_DIR = tests
|
||||
LOADPATH = -L . -L $(TEST_DIR) $(LOAD_EXTRA)
|
||||
|
||||
SRC = tp-core.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \
|
||||
SRC = tp-core.el tp-style.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \
|
||||
tp-render.el tp-stack.el tp-query.el tp-palette.el tp-builtins.el tp.el
|
||||
TESTS = $(wildcard $(TEST_DIR)/*-tests.el)
|
||||
TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el
|
||||
|
||||
20
README.md
20
README.md
@ -172,7 +172,9 @@
|
||||
|
||||
**tp.el** is a library that comprehensively enhances Emacs text property manipulation. It is not just a simple wrapper around native text property APIs (like `put-text-property`, `get-text-property`), but provides many **functional extensions that native functions do not have**. tp.el innovates in the following areas:
|
||||
|
||||
Since 0.2.0 the library is organized as a family of layered modules (`tp-core`, `tp-reactive`, `tp-layer`, `tp-ops`, `tp-search`, `tp-render`, `tp-stack`, `tp-palette`, `tp-builtins`) behind the umbrella file `tp.el` — `(require 'tp)` still loads everything, so nothing changes for users. See [Installation](#installation) for the module map.
|
||||
Since 0.2.0 the library is organized as a family of layered modules (`tp-core`, `tp-style`, `tp-reactive`, `tp-layer`, `tp-ops`, `tp-search`, `tp-render`, `tp-stack`, `tp-query`, `tp-palette`, `tp-builtins`) behind the umbrella file `tp.el` — `(require 'tp)` still loads everything, so nothing changes for users. See [Installation](#installation) for the module map.
|
||||
|
||||
The TP 1.0 migration has begun with a pure schema-driven cascade kernel. `tp-style.el` adds namespaced property schemas, structured selectors, origin/importance/layer/specificity/scope/source-order precedence, property-specific inheritance, tagged CSS-wide values, inherited custom properties, explicit `tp-computed` sources, projection to Emacs properties, and read-only winner provenance. It deliberately owns no buffers, markers, mounts, or reactive subscriptions; retained surfaces will build on this kernel in later migration phases.
|
||||
|
||||
### Core Innovations
|
||||
|
||||
@ -429,6 +431,7 @@ The modules and their roles:
|
||||
| Module | Responsibility |
|
||||
|---|---|
|
||||
| `tp-core.el` | Intervals, plist/face merge engine, debug logging, `$var` utilities |
|
||||
| `tp-style.el` | Namespaced property schemas, structured selectors, cascade, custom properties, and explicit computed values |
|
||||
| `tp-reactive.el` | Reactive dependency registry, variable watchers, batching queue |
|
||||
| `tp-layer.el` | `define-tp` / `define-tps`, layer registry and resolution |
|
||||
| `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` |
|
||||
@ -497,6 +500,21 @@ A complete overview of all tp.el functions organized by category:
|
||||
| [`tp-property-not-all`](#tp-property-any--tp-property-not-all) | Wrapper for `text-property-not-all` |
|
||||
| [`tp-with-mutation-policy`](#tp-with-mutation-policy) | Explicit modified/read-only mutation policy wrapper |
|
||||
|
||||
#### Schema-Driven Cascade
|
||||
|
||||
| Function | Description |
|
||||
|----------|-------------|
|
||||
| `tp-define-property` / `tp-property-schema` | Register and inspect an atomic namespaced property schema |
|
||||
| `tp-text-property-id` / `tp-register-text-property` / `tp-text-declarations` | Map native Emacs properties into the canonical `text/` domain |
|
||||
| `tp-subject-create` / `tp-subject-set-children` | Build consumer-independent selector subjects and relations |
|
||||
| `tp-selector-match-p` / `tp-selector-specificity` | Match the structured selector AST and compute its specificity |
|
||||
| `tp-define-style` / `tp-style-declarations` / `tp-undefine-style` | Register, inspect, and remove defensive named declarations |
|
||||
| `tp-stylesheet-add-rule` | Add an origin/layer/scope-aware structured rule |
|
||||
| `tp-wide-value` / `tp-important` / `tp-var` | Construct unambiguous cascade values without reserving ordinary Elisp symbols |
|
||||
| `tp-computed` | Mark the only function values TP should execute |
|
||||
| `tp-compute-style` / `tp-project-style` | Compute canonical values/provenance and project final Emacs text properties |
|
||||
| `tp-style-reset-rules` / `tp-style-reset` | Reset stylesheet-only state or the complete style registry |
|
||||
|
||||
#### Property Layer Definition Functions
|
||||
| Function | Description |
|
||||
|----------|-------------|
|
||||
|
||||
20
README_CN.md
20
README_CN.md
@ -171,7 +171,9 @@
|
||||
|
||||
**tp.el** 是一个全面增强 Emacs 文本属性操作的库。它不仅仅是对原生文本属性 API（如 `put-text-property`、`get-text-property`）的简单封装，更提供了许多**原生函数所不具备的功能拓展**。tp.el 在以下方面进行了创新：
|
||||
|
||||
自 0.2.0 起，本库被组织为一组分层模块（`tp-core`、`tp-reactive`、`tp-layer`、`tp-ops`、`tp-search`、`tp-render`、`tp-stack`、`tp-palette`、`tp-builtins`），由伞形文件 `tp.el` 统一加载 — `(require 'tp)` 仍会加载全部模块，对用户没有任何变化。模块一览见[安装](#安装)。
|
||||
自 0.2.0 起，本库被组织为一组分层模块（`tp-core`、`tp-style`、`tp-reactive`、`tp-layer`、`tp-ops`、`tp-search`、`tp-render`、`tp-stack`、`tp-query`、`tp-palette`、`tp-builtins`），由伞形文件 `tp.el` 统一加载 — `(require 'tp)` 仍会加载全部模块，对用户没有任何变化。模块一览见[安装](#安装)。
|
||||
|
||||
TP 1.0 迁移已经从纯 schema-driven cascade kernel 开始。`tp-style.el` 新增 namespaced property schema、结构化 selector、origin/importance/layer/specificity/scope/source-order 优先级、逐属性继承、带 tag 的 CSS-wide 值、可继承 custom property、显式 `tp-computed` source、Emacs 属性投影和只读 winner provenance。这个模块刻意不拥有 buffer、marker、mount 或响应式订阅；后续 retained surface 会建立在同一个 kernel 上。
|
||||
|
||||
### 核心创新
|
||||
|
||||
@ -425,6 +427,7 @@ OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和
|
||||
| 模块 | 职责 |
|
||||
|---|---|
|
||||
| `tp-core.el` | 区间、plist/face 合并引擎、调试日志、`$var` 工具 |
|
||||
| `tp-style.el` | namespaced property schema、结构化 selector、cascade、custom property 和显式 computed value |
|
||||
| `tp-reactive.el` | 响应式依赖注册表、变量监视器、批量更新队列 |
|
||||
| `tp-layer.el` | `define-tp` / `define-tps`、属性层注册表与解析 |
|
||||
| `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` |
|
||||
@ -492,6 +495,21 @@ tp.el 所有函数按类别组织的完整概览：
|
||||
| [`tp-property-not-all`](#tp-property-any--tp-property-not-all) | `text-property-not-all` 封装 |
|
||||
| [`tp-with-mutation-policy`](#tp-with-mutation-policy) | 显式 modified/read-only 修改策略封装 |
|
||||
|
||||
#### Schema-driven Cascade
|
||||
|
||||
| 函数 | 描述 |
|
||||
|------|------|
|
||||
| `tp-define-property` / `tp-property-schema` | 原子注册并查询 namespaced property schema |
|
||||
| `tp-text-property-id` / `tp-register-text-property` / `tp-text-declarations` | 把原生 Emacs property 映射到 canonical `text/` domain |
|
||||
| `tp-subject-create` / `tp-subject-set-children` | 构造与具体 consumer 无关的 selector subject 和关系 |
|
||||
| `tp-selector-match-p` / `tp-selector-specificity` | 匹配结构化 selector AST 并计算 specificity |
|
||||
| `tp-define-style` / `tp-style-declarations` / `tp-undefine-style` | 注册、查询并移除防御性复制的 named declarations |
|
||||
| `tp-stylesheet-add-rule` | 添加支持 origin/layer/scope 的结构化 rule |
|
||||
| `tp-wide-value` / `tp-important` / `tp-var` | 构造无歧义 cascade 值，不占用普通 Elisp symbol |
|
||||
| `tp-computed` | 标记 TP 唯一应该执行的 function value |
|
||||
| `tp-compute-style` / `tp-project-style` | 计算 canonical values/provenance 并投影最终 Emacs text properties |
|
||||
| `tp-style-reset-rules` / `tp-style-reset` | 仅重置 stylesheet state，或重置完整 style registry |
|
||||
|
||||
#### 属性层定义函数
|
||||
| 函数 | 描述 |
|
||||
|------|------|
|
||||
|
||||
@ -4,6 +4,8 @@
|
||||
|
||||
tp 当前定位是 **Emacs 文本属性的高层操作工具箱，以及一套受管理的命名层、层栈和响应式渲染模型**。它尚不是全部原生文本/字符属性语义的等价替代品；完整范围与路线见 [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。
|
||||
|
||||
TP 1.0 迁移的第一层纯计算合同已经落地在 `tp-style.el`：namespaced property schema、结构化 selector、确定性 cascade、逐属性继承、custom property、显式 `tp-computed` 和 Emacs 属性投影已经是当前 public behavior；retained object/surface/mount/transaction 尚未切换，仍以目标架构文档描述为未来合同。
|
||||
|
||||
Stage 2 canonical façade 已完成为内部模型：`tp--native-range`、`tp--presence`、`tp--request`、`tp--match`、`tp--result` 是模块间传递的规范记录。公开入口和历史返回值保持兼容，不因内部模型收敛而改变。
|
||||
|
||||
Stage 3 text-only 原生语义 façade 已完成：direct/effective/source-aware lookup、property change/any/not-all 与三种 mutation policy 组合均有明确公开边界。
|
||||
@ -169,3 +171,14 @@ tp 不会把外部属性收编成新的匿名层，也不会静默覆盖它。
|
||||
- mutation policy 三种组合之外的统一 read-only、silent modification、undo 策略；
|
||||
- 字符串/缓冲区完全一致的搜索结果结构；
|
||||
- observer 错误的清理、重试与汇总策略。
|
||||
|
||||
## 12. Schema-driven cascade
|
||||
|
||||
- `tp-define-property` 只接受带 namespace 的 symbol id，例如 `text/face` 或 `ebox/width`；schema replacement 在完整验证后一次写入，失败不会破坏旧 definition。
|
||||
- structured selector 原生支持 type/id/class/attribute/state、compound、descendant/child/adjacent/general sibling，以及 `:is`、`:where` 和 `:not`；`tp-selector-specificity` 与 rule matching 使用同一 AST。
|
||||
- cascade 顺序固定为 importance、origin、layer、specificity、scope proximity、source order；normal 与 important declaration 的 layer 顺序按 CSS 规则相反，unlayered normal 高于 layered normal。
|
||||
- `initial`、`inherit`、`unset`、`revert` 和 `revert-layer` 必须由 `tp-wide-value` 显式构造，普通同名 Elisp symbol 保持 literal。
|
||||
- 普通 function value 永远不执行；只有 `tp-computed` 包装的 function 在计算时执行一次，其返回值不二次调用。
|
||||
- `--name` custom property 默认继承；`tp-var` 支持 fallback 和 cycle invalidation。属性 schema 的 normalizer/validator 在变量与 wide value 求值后执行。
|
||||
- `tp-compute-style` 返回 `tp-computed-style`，保存 canonical values、resolved custom properties 和可选 provenance；`tp-project-style` 是把 schema projector 汇总为最终 Emacs text properties 的唯一纯投影入口。
|
||||
- 静态 `define-tp` 和静态 `define-tps` 生成层会同步编译为同名 canonical style；参数化或旧 `$var` 响应式定义不会冻结当前值为 style，待新的 signal/binding runtime 接管其动态 source。
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
|
||||
> 未来主版本目标：TP 将重构为独立 retained/reactive text runtime，并可作为 Ebox 等高级 consumer 的通用底层执行器。TP 自身完整、可独立阅读的已批准目标见 [TP Retained/Reactive Text Runtime 目标架构](retained-runtime-target-architecture.md)（[English](retained-runtime-target-architecture-en.md)）；它不依赖 sibling Ebox checkout。本文在最终切换完成前仍只描述 TP 0.3.x 当前实现。
|
||||
|
||||
本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。
|
||||
本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。TP 1.0 的第一层纯 style/cascade kernel 已在 `tp-style.el` 落地；retained surface 与新 reactive runtime 尚未切换。
|
||||
|
||||
当前 API 的规范契约见 [API-SEMANTICS.md](API-SEMANTICS.md)；Emacs 原生
|
||||
文本属性覆盖范围、已确认问题与演进路线见
|
||||
@ -37,7 +37,7 @@
|
||||
tp 采用严格的线性分层：**每个模块只允许 `require` 并调用排在它前面的模块**，字节编译器强制检查这一依赖顺序。加载顺序即依赖顺序：
|
||||
|
||||
```
|
||||
tp-core → tp-reactive → tp-layer → tp-ops → tp-search
|
||||
tp-core → tp-style → tp-reactive → tp-layer → tp-ops → tp-search
|
||||
→ tp-render → tp-stack → tp-query → tp-palette → tp-builtins
|
||||
```
|
||||
|
||||
@ -46,8 +46,9 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
|
||||
| 模块 | require 的 tp- 模块 |
|
||||
|------|--------------------|
|
||||
| tp-core | —（仅 cl-lib、dash、seq） |
|
||||
| tp-style | tp-core |
|
||||
| tp-reactive | tp-core |
|
||||
| tp-layer | tp-core、tp-reactive |
|
||||
| tp-layer | tp-core、tp-style、tp-reactive |
|
||||
| tp-ops | tp-core、tp-reactive、tp-layer |
|
||||
| tp-search | tp-core、tp-reactive、tp-layer、tp-ops |
|
||||
| tp-render | tp-core、tp-reactive、tp-layer、tp-ops、tp-search |
|
||||
@ -87,6 +88,9 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
|
||||
│ 层→缓冲区注册表 │ │
|
||||
│ ◁╌╌ tp--reactive-update-function ╌╌╌╌╌╌╌╌╌┘ │
|
||||
├────────────────────────────────────────────────────────────────┤
|
||||
│ tp-style.el property schema、structured selector、 │
|
||||
│ cascade、custom property、computed value │
|
||||
├────────────────────────────────────────────────────────────────┤
|
||||
│ tp-core.el 区间遍历、plist/face 合并引擎、 │
|
||||
│ 调试日志、$var 符号工具（无可变状态） │
|
||||
└────────────────────────────────────────────────────────────────┘
|
||||
@ -163,6 +167,14 @@ Stage 2 canonical façade 是内部模型，不改变公开入口和历史返回
|
||||
|
||||
---
|
||||
|
||||
### tp-style.el：纯 schema 与 cascade kernel
|
||||
|
||||
只依赖 tp-core，不接触 buffer、marker、mount 或订阅。它拥有 namespaced property schema、structured subject/selector、origin/importance/layer/specificity/scope/source-order cascade、逐属性继承、tagged CSS-wide values、custom property/`tp-var`、显式 `tp-computed`、named style、provenance 和最终 Emacs property projection。
|
||||
|
||||
普通 function value 保持 literal；只有 `tp-computed` 才会求值一次。schema/rule 注册先完整校验再原子替换。shorthand 在进入候选集前展开一次，计算结果随后经过 variable/wide-value resolution、normalizer 和 validator。该模块提供后续 signal/binding 与 retained surface 共用的唯一 style 语义，不建立第二套 renderer。
|
||||
|
||||
---
|
||||
|
||||
### tp-reactive.el：响应式基础设施
|
||||
|
||||
只依赖 tp-core。维护响应式依赖注册表、变量监听器、批量更新队列与 0.3.0 新增的**层→缓冲区注册表**；**不包含任何渲染逻辑**，重渲染通过钩子变量委托给 tp-render.el。批量更新的队列（`tp--batch-update-pending`、`tp--queue-batch-update`）定义在这里，但 `tp-with-batch-updates` 宏与刷新逻辑自 0.3.0 起位于 tp-render.el。
|
||||
@ -558,6 +570,7 @@ insert/copy/yank/stickiness/narrowing/indirect buffer 均不在 tp-query 中封
|
||||
| 模块 | 状态 | 描述 | 清理 |
|
||||
|------|------|------|------|
|
||||
| tp-core | —— | **无可变状态**（仅 `tp-debug-mode`/`tp-debug-echo` 两个用户选项；调试日志写入 *tp-debug* 缓冲区，由 `tp-debug-clear` 清除） | - |
|
||||
| tp-style | schema、named style、stylesheet rule、cascade layer/source order registries | 纯 style definition 和 rule 状态；不保存 object、buffer 或 mount | `tp-style-reset` / `tp-style-reset-rules` |
|
||||
| tp-reactive | `tp-reactive-deps` | 变量 → 依赖层 注册表 | `tp-reactive-reset` |
|
||||
| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` / `tp-reactive-observer-errors` | `:watch` / `:compute` / `:data` 注册表与结构化 observer 错误 | `tp-reactive-reset` |
|
||||
| tp-reactive | `tp--batch-update-pending` | 批量更新队列（0.3.0 起也被 reset 清空，防止残留条目对新定义的层重放） | `tp-reactive-reset` |
|
||||
|
||||
517
tests/tp-style-tests.el
Normal file
517
tests/tp-style-tests.el
Normal file
@ -0,0 +1,517 @@
|
||||
;;; tp-style-tests.el --- Tests for TP style cascade -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Geekinney
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Contract tests for the TP 1.0 schema-driven cascade kernel.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'tp-style)
|
||||
(require 'tp-layer)
|
||||
|
||||
(defmacro tp-style-test--isolated (&rest body)
|
||||
"Run BODY with empty TP style registries."
|
||||
(declare (indent 0) (debug t))
|
||||
`(let ((tp--property-schemas (make-hash-table :test #'eq))
|
||||
(tp--property-schema-order nil)
|
||||
(tp--named-styles (make-hash-table :test #'eq))
|
||||
(tp--stylesheet-rules nil)
|
||||
(tp--cascade-layers nil)
|
||||
(tp--style-source-order 0))
|
||||
(tp-style-reset)
|
||||
,@body))
|
||||
|
||||
(defun tp-style-test--color-schema (&optional inherits)
|
||||
"Register and return the demo color schema using INHERITS."
|
||||
(tp-define-property
|
||||
'demo/color
|
||||
:initial "black"
|
||||
:inherits inherits
|
||||
:normalizer #'downcase
|
||||
:validator #'stringp
|
||||
:equality #'equal
|
||||
:projector (lambda (value)
|
||||
(list 'face (list :foreground value)))))
|
||||
|
||||
(defun tp-style-test--values (subject &rest args)
|
||||
"Return computed values for SUBJECT using ARGS."
|
||||
(tp-computed-style-values
|
||||
(apply #'tp-compute-style subject args)))
|
||||
|
||||
(ert-deftest tp-style-test-schema-registration-is-atomic-and-defensive ()
|
||||
"Invalid replacement leaves the previous valid schema installed."
|
||||
(tp-style-test--isolated
|
||||
(let ((schema (tp-style-test--color-schema t)))
|
||||
(should (eq schema (tp-property-schema 'demo/color)))
|
||||
(should-error
|
||||
(tp-define-property 'demo/color :normalizer 42)
|
||||
:type 'tp-invalid-property-schema)
|
||||
(should (eq schema (tp-property-schema 'demo/color)))
|
||||
(should-error
|
||||
(tp-define-property 'color :initial "black")
|
||||
:type 'tp-invalid-property-schema))))
|
||||
|
||||
(ert-deftest tp-style-test-shorthand-expands-before-cascade-once ()
|
||||
"A shorthand expands once into registered canonical longhands."
|
||||
(tp-style-test--isolated
|
||||
(let ((calls 0))
|
||||
(tp-define-property 'demo/top :initial 0 :validator #'natnump)
|
||||
(tp-define-property 'demo/right :initial 0 :validator #'natnump)
|
||||
(tp-define-property
|
||||
'demo/inset
|
||||
:shorthand (lambda (value)
|
||||
(cl-incf calls)
|
||||
(list 'demo/top value 'demo/right value)))
|
||||
(let ((values (tp-style-test--values
|
||||
(tp-subject-create :type 'box)
|
||||
:declarations '(demo/inset 7))))
|
||||
(should (= calls 1))
|
||||
(should (= (plist-get values 'demo/top) 7))
|
||||
(should (= (plist-get values 'demo/right) 7))
|
||||
(should-not (plist-member values 'demo/inset))))))
|
||||
|
||||
(ert-deftest tp-style-test-literal-functions-are-never-called ()
|
||||
"Function values remain data unless wrapped by `tp-computed'."
|
||||
(tp-style-test--isolated
|
||||
(let* ((calls 0)
|
||||
(callback (lambda () (cl-incf calls))))
|
||||
(tp-define-property 'text/help :initial nil)
|
||||
(let ((values (tp-style-test--values
|
||||
(tp-subject-create :type 'label)
|
||||
:declarations (list 'text/help callback))))
|
||||
(should (eq (plist-get values 'text/help) callback))
|
||||
(should (= calls 0))))))
|
||||
|
||||
(ert-deftest tp-style-test-computed-runs-once-and-result-stays-literal ()
|
||||
"Tagged computation runs once and never invokes its returned function."
|
||||
(tp-style-test--isolated
|
||||
(let ((compute-calls 0)
|
||||
(result-calls 0)
|
||||
result-function)
|
||||
(setq result-function (lambda () (cl-incf result-calls)))
|
||||
(tp-define-property 'text/help :initial nil)
|
||||
(let ((values
|
||||
(tp-style-test--values
|
||||
(tp-subject-create :type 'label)
|
||||
:declarations
|
||||
(list 'text/help
|
||||
(tp-computed
|
||||
(lambda ()
|
||||
(cl-incf compute-calls)
|
||||
result-function))))))
|
||||
(should (eq (plist-get values 'text/help) result-function))
|
||||
(should (= compute-calls 1))
|
||||
(should (= result-calls 0))))))
|
||||
|
||||
(ert-deftest tp-style-test-inheritance-is-property-specific ()
|
||||
"Only schemas marked inheriting read their parent's computed value."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema t)
|
||||
(tp-define-property 'demo/background :initial "transparent"
|
||||
:validator #'stringp)
|
||||
(let* ((parent (tp-subject-create :type 'panel))
|
||||
(child (tp-subject-create :type 'label :parent parent))
|
||||
(parent-result
|
||||
(tp-compute-style
|
||||
parent :declarations
|
||||
'(demo/color "NAVY" demo/background "white")))
|
||||
(values
|
||||
(tp-style-test--values
|
||||
child :parent-style parent-result)))
|
||||
(should (equal (plist-get values 'demo/color) "navy"))
|
||||
(should (equal (plist-get values 'demo/background) "transparent")))))
|
||||
|
||||
(ert-deftest tp-style-test-explicit-nil-is-not-absence ()
|
||||
"An explicit nil declaration overrides an inherited non-nil value."
|
||||
(tp-style-test--isolated
|
||||
(tp-define-property 'text/keymap :initial 'default-map :inherits t)
|
||||
(let* ((parent (tp-subject-create :type 'panel))
|
||||
(child (tp-subject-create :type 'button :parent parent))
|
||||
(parent-result
|
||||
(tp-compute-style parent :declarations '(text/keymap parent-map)))
|
||||
(values
|
||||
(tp-style-test--values
|
||||
child :parent-style parent-result
|
||||
:declarations '(text/keymap nil))))
|
||||
(should (plist-member values 'text/keymap))
|
||||
(should-not (plist-get values 'text/keymap)))))
|
||||
|
||||
(ert-deftest tp-style-test-structured-selectors-cover-public-combinators ()
|
||||
"Structured selectors match identity, attributes, state, and relations."
|
||||
(tp-style-test--isolated
|
||||
(let* ((root (tp-subject-create :type 'panel :id "root"))
|
||||
(first (tp-subject-create :type 'button :id "cancel"
|
||||
:classes '(secondary)))
|
||||
(second (tp-subject-create
|
||||
:type 'button :id "save" :classes '(primary rounded)
|
||||
:attributes '((role . action)) :state '(active)))
|
||||
(_children (tp-subject-set-children root (list first second))))
|
||||
(should
|
||||
(tp-selector-match-p
|
||||
'(:and (:type button) (:id "save") (:class primary)
|
||||
(:attr role action) (:state active)
|
||||
(:not (:class disabled)))
|
||||
second))
|
||||
(should (tp-selector-match-p
|
||||
'(:child (:id "root") (:class primary)) second))
|
||||
(should (tp-selector-match-p
|
||||
'(:descendant (:type panel) (:id "save")) second))
|
||||
(should (tp-selector-match-p
|
||||
'(:adjacent (:id "cancel") (:id "save")) second))
|
||||
(should (tp-selector-match-p
|
||||
'(:sibling (:class secondary) (:id "save")) second))
|
||||
(should (tp-selector-match-p
|
||||
'(:is (:id "missing") (:class primary)) second))
|
||||
(should (tp-selector-match-p
|
||||
'(:where (:type button) (:class missing)) second)))))
|
||||
|
||||
(ert-deftest tp-style-test-origin-importance-and-specificity-are-ordered ()
|
||||
"Importance, origin, and selector specificity decide the winner in order."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((subject (tp-subject-create :type 'button :id "save"
|
||||
:classes '(primary))))
|
||||
(tp-stylesheet-add-rule '(:id "save") '(demo/color "green")
|
||||
:origin 'theme)
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
|
||||
:origin 'author)
|
||||
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
||||
"red"))
|
||||
(tp-stylesheet-add-rule
|
||||
'(:class primary)
|
||||
(list 'demo/color (tp-important "purple"))
|
||||
:origin 'theme)
|
||||
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
||||
"purple")))))
|
||||
|
||||
(ert-deftest tp-style-test-layer-order-reverses-for-important ()
|
||||
"Normal declarations prefer later layers; important declarations reverse."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((subject (tp-subject-create :type 'button)))
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
|
||||
:layer 'base)
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
|
||||
:layer 'components)
|
||||
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
||||
"red"))
|
||||
(tp-style-reset-rules)
|
||||
(tp-stylesheet-add-rule
|
||||
'(:type button) (list 'demo/color (tp-important "blue"))
|
||||
:layer 'base)
|
||||
(tp-stylesheet-add-rule
|
||||
'(:type button) (list 'demo/color (tp-important "red"))
|
||||
:layer 'components)
|
||||
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
||||
"blue")))))
|
||||
|
||||
(ert-deftest tp-style-test-unlayered-normal-beats-layered-normal ()
|
||||
"An unlayered normal declaration outranks layered declarations."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((subject (tp-subject-create :type 'button)))
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
|
||||
:layer 'components)
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "red"))
|
||||
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
||||
"red")))))
|
||||
|
||||
(ert-deftest tp-style-test-source-order-breaks-complete-ties ()
|
||||
"The last matching rule wins after all stronger dimensions tie."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((subject (tp-subject-create :type 'button)))
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue"))
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "red"))
|
||||
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
||||
"red")))))
|
||||
|
||||
(ert-deftest tp-style-test-later-duplicate-declaration-wins-stably ()
|
||||
"The later declaration wins when one rule repeats a property."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(tp-stylesheet-add-rule
|
||||
'(:type label) '(demo/color "red" demo/color "green"))
|
||||
(let ((values
|
||||
(tp-style-test--values (tp-subject-create :type 'label))))
|
||||
(should (equal (plist-get values 'demo/color) "green")))))
|
||||
|
||||
(ert-deftest tp-style-test-computation-is-deterministic ()
|
||||
"Equivalent calls return structurally equal computed styles."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(tp-stylesheet-add-rule '(:class primary) '(demo/color "purple"))
|
||||
(let ((subject (tp-subject-create :type 'label :classes '(primary))))
|
||||
(should (equal (tp-compute-style subject :provenance t)
|
||||
(tp-compute-style subject :provenance t))))))
|
||||
|
||||
(ert-deftest tp-style-test-custom-properties-have-canonical-order ()
|
||||
"Computed custom properties use deterministic symbol-name order."
|
||||
(tp-style-test--isolated
|
||||
(let* ((result
|
||||
(tp-compute-style
|
||||
(tp-subject-create :type 'label)
|
||||
:declarations '(--zeta 1 --alpha 2 --middle 3)))
|
||||
(custom (tp-computed-style-custom-properties result)))
|
||||
(should (equal custom '(--alpha 2 --middle 3 --zeta 1))))))
|
||||
|
||||
(ert-deftest tp-style-test-computation-does-not-mutate-current-buffer ()
|
||||
"Cascade computation never mutates the current buffer."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(with-temp-buffer
|
||||
(insert "stable")
|
||||
(add-text-properties 1 4 '(face bold marker original))
|
||||
(let ((before-text (buffer-string))
|
||||
(before-properties (text-properties-at 2)))
|
||||
(cl-letf (((symbol-function 'add-text-properties)
|
||||
(lambda (&rest _) (error "buffer mutation")))
|
||||
((symbol-function 'put-text-property)
|
||||
(lambda (&rest _) (error "buffer mutation")))
|
||||
((symbol-function 'remove-text-properties)
|
||||
(lambda (&rest _) (error "buffer mutation")))
|
||||
((symbol-function 'set-text-properties)
|
||||
(lambda (&rest _) (error "buffer mutation")))
|
||||
((symbol-function 'insert)
|
||||
(lambda (&rest _) (error "buffer mutation")))
|
||||
((symbol-function 'delete-region)
|
||||
(lambda (&rest _) (error "buffer mutation")))
|
||||
((symbol-function 'erase-buffer)
|
||||
(lambda (&rest _) (error "buffer mutation"))))
|
||||
(tp-compute-style
|
||||
(tp-subject-create :type 'label)
|
||||
:declarations '(demo/color "red")))
|
||||
(should (equal (buffer-string) before-text))
|
||||
(should (equal (text-properties-at 2) before-properties))))))
|
||||
|
||||
(ert-deftest tp-style-test-compute-error-leaves-cascade-state-unchanged ()
|
||||
"A failing computed source does not mutate registered cascade state."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(tp-stylesheet-add-rule '(:type label) '(demo/color "blue"))
|
||||
(let ((rules-before (copy-tree tp--stylesheet-rules))
|
||||
(order-before tp--style-source-order))
|
||||
(should-error
|
||||
(tp-compute-style
|
||||
(tp-subject-create :type 'label)
|
||||
:declarations
|
||||
(list 'demo/color (tp-computed (lambda () (error "broken"))))))
|
||||
(should (equal tp--stylesheet-rules rules-before))
|
||||
(should (= tp--style-source-order order-before)))))
|
||||
|
||||
(ert-deftest tp-style-test-nearer-scope-wins-after-specificity ()
|
||||
"A rule scoped to the nearest matching ancestor wins a tie."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let* ((root (tp-subject-create :type 'panel :id "root"))
|
||||
(section (tp-subject-create :type 'section :id "section"))
|
||||
(button (tp-subject-create :type 'button)))
|
||||
(tp-subject-set-children root (list section))
|
||||
(tp-subject-set-children section (list button))
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
|
||||
:scope '(:id "root"))
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
|
||||
:scope '(:id "section"))
|
||||
(should (equal (plist-get (tp-style-test--values button) 'demo/color)
|
||||
"red")))))
|
||||
|
||||
(ert-deftest tp-style-test-css-wide-values-are-tagged-not-reserved-symbols ()
|
||||
"Tagged wide values work while an ordinary `inherit' symbol stays literal."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema t)
|
||||
(tp-define-property 'demo/token :initial 'initial-token :validator #'symbolp)
|
||||
(let* ((parent (tp-subject-create :type 'panel))
|
||||
(child (tp-subject-create :type 'label :parent parent))
|
||||
(parent-result
|
||||
(tp-compute-style parent :declarations '(demo/color "red")))
|
||||
(values
|
||||
(tp-style-test--values
|
||||
child :parent-style parent-result
|
||||
:declarations
|
||||
(list 'demo/color (tp-wide-value 'inherit)
|
||||
'demo/token 'inherit))))
|
||||
(should (equal (plist-get values 'demo/color) "red"))
|
||||
(should (eq (plist-get values 'demo/token) 'inherit)))))
|
||||
|
||||
(ert-deftest tp-style-test-revert-and-revert-layer-select-lower-candidates ()
|
||||
"Revert skips an origin and revert-layer skips only the winning layer."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((subject (tp-subject-create :type 'button)))
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "green")
|
||||
:origin 'theme)
|
||||
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
|
||||
:origin 'author :layer 'base)
|
||||
(tp-stylesheet-add-rule
|
||||
'(:type button)
|
||||
(list 'demo/color (tp-wide-value 'revert-layer))
|
||||
:origin 'author :layer 'components)
|
||||
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
||||
"red"))
|
||||
(should
|
||||
(equal
|
||||
(plist-get
|
||||
(tp-style-test--values
|
||||
subject
|
||||
:declarations
|
||||
(list 'demo/color (tp-wide-value 'revert)))
|
||||
'demo/color)
|
||||
"red")))))
|
||||
|
||||
(ert-deftest tp-style-test-custom-properties-inherit-and-support-fallback ()
|
||||
"Custom properties inherit and `tp-var' resolves an explicit fallback."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let* ((parent (tp-subject-create :type 'panel))
|
||||
(child (tp-subject-create :type 'label :parent parent))
|
||||
(parent-result
|
||||
(tp-compute-style parent :declarations '(--accent "NAVY")))
|
||||
(inherited
|
||||
(tp-style-test--values
|
||||
child :parent-style parent-result
|
||||
:declarations (list 'demo/color (tp-var '--accent))))
|
||||
(fallback
|
||||
(tp-style-test--values
|
||||
child :declarations
|
||||
(list 'demo/color (tp-var '--missing "GRAY")))))
|
||||
(should (equal (plist-get inherited 'demo/color) "navy"))
|
||||
(should (equal (plist-get fallback 'demo/color) "gray")))))
|
||||
|
||||
(ert-deftest tp-style-test-custom-property-cycle-uses-outer-fallback ()
|
||||
"A custom-property cycle is invalid and activates the outer fallback."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((values
|
||||
(tp-style-test--values
|
||||
(tp-subject-create :type 'label)
|
||||
:declarations
|
||||
(list '--a (tp-var '--b)
|
||||
'--b (tp-var '--a)
|
||||
'demo/color (tp-var '--a "SAFE")))))
|
||||
(should (equal (plist-get values 'demo/color) "safe")))))
|
||||
|
||||
(ert-deftest tp-style-test-invalid-value-falls-back-to-inherited-or-initial ()
|
||||
"Invalid-at-computed-value declarations use the property's default path."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((values
|
||||
(tp-style-test--values
|
||||
(tp-subject-create :type 'label)
|
||||
:declarations (list 'demo/color (tp-var '--missing)))))
|
||||
(should (equal (plist-get values 'demo/color) "black")))))
|
||||
|
||||
(ert-deftest tp-style-test-invalid-winner-does-not-recascade ()
|
||||
"An invalid winner uses its default instead of a lower declaration."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(tp-stylesheet-add-rule '(:type label) '(demo/color "blue"))
|
||||
(tp-stylesheet-add-rule
|
||||
'(:type label) (list 'demo/color (tp-var '--missing)))
|
||||
(let ((values
|
||||
(tp-style-test--values (tp-subject-create :type 'label))))
|
||||
(should (equal (plist-get values 'demo/color) "black")))))
|
||||
|
||||
(ert-deftest tp-style-test-provenance-identifies-winning-declaration ()
|
||||
"The optional read-only provenance records the winning rule facts."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(tp-stylesheet-add-rule '(:class primary) '(demo/color "purple")
|
||||
:origin 'author :layer 'components)
|
||||
(let* ((result
|
||||
(tp-compute-style
|
||||
(tp-subject-create :type 'button :classes '(primary))
|
||||
:provenance t))
|
||||
(entry (plist-get (tp-computed-style-provenance result)
|
||||
'demo/color)))
|
||||
(should (equal (plist-get entry :selector) '(:class primary)))
|
||||
(should (eq (plist-get entry :origin) 'author))
|
||||
(should (eq (plist-get entry :layer) 'components)))))
|
||||
|
||||
(ert-deftest tp-style-test-projector-produces-final-emacs-properties ()
|
||||
"Projection converts canonical computed values to Emacs properties."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((result
|
||||
(tp-compute-style
|
||||
(tp-subject-create :type 'label)
|
||||
:declarations '(demo/color "RED"))))
|
||||
(should (equal (tp-project-style result)
|
||||
'(face (:foreground "red")))))))
|
||||
|
||||
(ert-deftest tp-style-test-native-text-schemas-preserve-functions-and-nil ()
|
||||
"Native projectors keep callback functions literal and explicit nil present."
|
||||
(tp-style-test--isolated
|
||||
(let* ((callback (lambda (_window _object _position) "help"))
|
||||
(declarations
|
||||
(tp-text-declarations
|
||||
(list 'help-echo callback 'keymap nil 'display '(space :width 4))))
|
||||
(result
|
||||
(tp-compute-style (tp-subject-create :type 'label)
|
||||
:declarations declarations))
|
||||
(projected (tp-project-style result)))
|
||||
(should (eq (plist-get projected 'help-echo) callback))
|
||||
(should (plist-member projected 'keymap))
|
||||
(should-not (plist-get projected 'keymap))
|
||||
(should (equal (plist-get projected 'display) '(space :width 4))))))
|
||||
|
||||
(ert-deftest tp-style-test-inactive-nil-native-properties-do-not-project ()
|
||||
"Default nil schemas do not create absent Emacs properties."
|
||||
(tp-style-test--isolated
|
||||
(let ((result (tp-compute-style (tp-subject-create :type 'label))))
|
||||
(should-not (tp-project-style result)))))
|
||||
|
||||
(ert-deftest tp-style-test-define-tp-compiles-static-layer-declarations ()
|
||||
"A static `define-tp' layer also becomes a canonical named style."
|
||||
(tp-style-test--isolated
|
||||
(unwind-protect
|
||||
(progn
|
||||
(define-tp tp-style-test-layer ()
|
||||
'(face (:weight bold) help-echo "Demo" tp-text "content"))
|
||||
(should
|
||||
(equal (tp-style-declarations 'tp-style-test-layer)
|
||||
'(text/face (:weight bold) text/help-echo "Demo"))))
|
||||
(tp-undefine-layer 'tp-style-test-layer))))
|
||||
|
||||
(ert-deftest tp-style-test-parameterized-redefinition-removes-static-style ()
|
||||
"A parameterized redefinition cannot leave a frozen static style behind."
|
||||
(tp-style-test--isolated
|
||||
(unwind-protect
|
||||
(progn
|
||||
(define-tp tp-style-test-layer () '(face bold))
|
||||
(should (tp-style-declarations 'tp-style-test-layer))
|
||||
(define-tp tp-style-test-layer (weight)
|
||||
`(face (:weight ,weight)))
|
||||
(should-not (tp-style-declarations 'tp-style-test-layer)))
|
||||
(tp-undefine-layer 'tp-style-test-layer))))
|
||||
|
||||
(ert-deftest tp-style-test-static-group-element-compiles-style ()
|
||||
"A generated static group layer becomes a canonical named style."
|
||||
(tp-style-test--isolated
|
||||
(unwind-protect
|
||||
(progn
|
||||
(define-tps tp-style-test-group ()
|
||||
'("label" . (face italic mouse-face highlight)))
|
||||
(should
|
||||
(equal (tp-style-declarations 'tp-style-test-group-label)
|
||||
'(text/face italic text/mouse-face highlight))))
|
||||
(tp-undefine-group 'tp-style-test-group))))
|
||||
|
||||
(ert-deftest tp-style-test-named-style-definitions-are-defensive ()
|
||||
"Named styles own their declarations instead of caller mutable plists."
|
||||
(tp-style-test--isolated
|
||||
(tp-style-test--color-schema)
|
||||
(let ((declarations (list 'demo/color "red")))
|
||||
(tp-define-style 'demo/button declarations)
|
||||
(setcar (cdr declarations) "blue")
|
||||
(should (equal (tp-style-declarations 'demo/button)
|
||||
'(demo/color "red")))
|
||||
(let ((copy (tp-style-declarations 'demo/button)))
|
||||
(setcar (cdr copy) "green")
|
||||
(should (equal (tp-style-declarations 'demo/button)
|
||||
'(demo/color "red")))))))
|
||||
|
||||
(provide 'tp-style-tests)
|
||||
;;; tp-style-tests.el ends here
|
||||
32
tp-layer.el
32
tp-layer.el
@ -20,6 +20,7 @@
|
||||
(require 'cl-lib)
|
||||
(require 'dash)
|
||||
(require 'tp-core)
|
||||
(require 'tp-style)
|
||||
(require 'tp-reactive)
|
||||
|
||||
(define-error 'tp-unresolved-layer "Unresolved tp layer or group")
|
||||
@ -50,6 +51,20 @@ only updates the registry.")
|
||||
(defvar tp--managed-entry-counter 0
|
||||
"Monotonic counter used for managed stack entry ids.")
|
||||
|
||||
(defvar tp--compiled-style-layers nil
|
||||
"Layer names whose static declarations were compiled into TP styles.")
|
||||
|
||||
(defun tp--compile-layer-style (name properties)
|
||||
"Compile layer NAME and raw PROPERTIES into the TP style registry."
|
||||
(tp-define-style name (tp-text-declarations properties))
|
||||
(cl-pushnew name tp--compiled-style-layers)
|
||||
name)
|
||||
|
||||
(defun tp--uncompile-layer-style (name)
|
||||
"Remove layer NAME from the TP style registry."
|
||||
(tp-undefine-style name)
|
||||
(setq tp--compiled-style-layers (delq name tp--compiled-style-layers)))
|
||||
|
||||
(defun tp--layer-definition-version (layer-name)
|
||||
"Return LAYER-NAME's current definition version, or 0."
|
||||
(or (cdr (assq layer-name tp--layer-definition-versions)) 0))
|
||||
@ -320,6 +335,7 @@ The layer is stored in `tp-layer-alist'."
|
||||
(if (or all-reactive-syms data compute)
|
||||
;; Has reactive features - register dependencies and resolve at runtime
|
||||
(progn
|
||||
(tp--uncompile-layer-style name)
|
||||
;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
|
||||
(tp--unregister-reactive-deps name)
|
||||
;; Ensure all reactive variables are defined
|
||||
@ -350,6 +366,7 @@ The layer is stored in `tp-layer-alist'."
|
||||
;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
|
||||
(tp--unregister-reactive-deps name)
|
||||
(tp--set-layer-props name properties)
|
||||
(tp--compile-layer-style name properties)
|
||||
(tp--bump-layer-definition-version name)
|
||||
;; Update any text regions that already have this layer applied
|
||||
(tp--layer-refresh name old-props)
|
||||
@ -467,6 +484,7 @@ delegates to `tp--define-layer-internal' for proper reactive handling."
|
||||
(if arglist
|
||||
;; Parameterized - store for later evaluation
|
||||
(let ((entry (list arglist body)))
|
||||
(tp--uncompile-layer-style name)
|
||||
(tp--store-layer-entry name entry t)
|
||||
(tp--layer-refresh name nil)
|
||||
(assoc name tp-layer-alist))
|
||||
@ -482,6 +500,7 @@ delegates to `tp--define-layer-internal' for proper reactive handling."
|
||||
(tp--unregister-reactive-deps name)
|
||||
(let ((entry (list nil `',body)))
|
||||
(tp--store-layer-entry name entry t)
|
||||
(tp--compile-layer-style name body)
|
||||
(tp--layer-refresh name old-props)
|
||||
(assoc name tp-layer-alist))))))
|
||||
|
||||
@ -603,6 +622,7 @@ removed (mirroring `tp--define-layer-internal')."
|
||||
(delete-dups (append data props-vars computed-vars))))
|
||||
(if (or all-reactive-syms data compute)
|
||||
(progn
|
||||
(tp--uncompile-layer-style layer-name)
|
||||
(tp--unregister-reactive-deps layer-name)
|
||||
(tp--ensure-reactive-variables all-vars-to-define)
|
||||
(when data
|
||||
@ -619,6 +639,7 @@ removed (mirroring `tp--define-layer-internal')."
|
||||
(tp--layer-refresh layer-name old-props))
|
||||
(tp--unregister-reactive-deps layer-name)
|
||||
(tp--set-layer-props layer-name props)
|
||||
(tp--compile-layer-style layer-name props)
|
||||
(tp--bump-layer-definition-version layer-name)
|
||||
(tp--layer-refresh layer-name old-props))
|
||||
layer-name)))
|
||||
@ -804,7 +825,7 @@ If the layer already exists, updates its properties; otherwise creates it.
|
||||
Stores as (LAYER-NAME . PROPERTIES) for backward compatibility with
|
||||
reactive layers.
|
||||
This is an internal function used by layer definition macros and
|
||||
reactive updates."
|
||||
reactive updates."
|
||||
(tp--store-layer-entry layer-name properties))
|
||||
|
||||
(defun tp--set-group-layers (group-name layer-names)
|
||||
@ -1341,6 +1362,7 @@ with the full layer stack."
|
||||
;; Resolve reactive symbols in expanded props
|
||||
(resolved-props (tp--resolve-reactive-symbols expanded-props)))
|
||||
;; Register reactive dependencies
|
||||
(tp--uncompile-layer-style layer-name)
|
||||
(tp--set-layer-props layer-name resolved-props)
|
||||
(tp--register-reactive-deps layer-name reactive-syms props)
|
||||
(append resolved-props (list 'tp-name layer-name)))
|
||||
@ -1373,6 +1395,7 @@ with the full layer stack."
|
||||
;; Resolve reactive symbols in expanded props
|
||||
(resolved-props (tp--resolve-reactive-symbols expanded-props)))
|
||||
;; Register reactive dependencies
|
||||
(tp--uncompile-layer-style layer-name)
|
||||
(tp--set-layer-props layer-name resolved-props)
|
||||
(tp--register-reactive-deps layer-name reactive-syms props)
|
||||
(append resolved-props (list 'tp-name layer-name)))
|
||||
@ -1390,6 +1413,7 @@ with the full layer stack."
|
||||
;; Resolve reactive symbols to get current values
|
||||
(resolved-props (tp--resolve-reactive-symbols props)))
|
||||
;; Register this anonymous layer in tp-layer-alist with resolved props
|
||||
(tp--uncompile-layer-style layer-name)
|
||||
(tp--set-layer-props layer-name resolved-props)
|
||||
;; Register reactive dependencies with the original props
|
||||
(tp--register-reactive-deps layer-name reactive-syms props)
|
||||
@ -1440,6 +1464,9 @@ Also resets all reactive text property watchers, dependencies, and transforms."
|
||||
(setq tp--layer-definition-counter 0)
|
||||
(setq tp--layer-definition-versions nil)
|
||||
(setq tp--managed-entry-counter 0)
|
||||
(dolist (name tp--compiled-style-layers)
|
||||
(tp-undefine-style name))
|
||||
(setq tp--compiled-style-layers nil)
|
||||
(setq tp-layer-transforms nil)
|
||||
(setq tp--group-generated-layers nil)
|
||||
(setq tp--anonymous-layer-registry nil))
|
||||
@ -1455,7 +1482,8 @@ and drops any anonymous-layer registry entries interned for it."
|
||||
(setq tp-layer-transforms (assq-delete-all name tp-layer-transforms))
|
||||
(setq tp--anonymous-layer-registry
|
||||
(cl-remove-if (lambda (cell) (eq (cdr cell) name))
|
||||
tp--anonymous-layer-registry)))
|
||||
tp--anonymous-layer-registry))
|
||||
(tp--uncompile-layer-style name))
|
||||
|
||||
(defun tp-undefine-group (name)
|
||||
"Remove layer group NAME from `tp-layer-groups'.
|
||||
|
||||
918
tp-style.el
Normal file
918
tp-style.el
Normal file
@ -0,0 +1,918 @@
|
||||
;;; 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))
|
||||
|
||||
(tp--register-default-text-properties)
|
||||
|
||||
(provide 'tp-style)
|
||||
;;; tp-style.el ends here
|
||||
3
tp.el
3
tp.el
@ -22,6 +22,8 @@
|
||||
;;
|
||||
;; tp-core.el Foundation: intervals, plist/face merge engine,
|
||||
;; debug logging, pure $var utilities.
|
||||
;; tp-style.el Property schemas, structured selectors, cascade,
|
||||
;; custom properties, and explicit computed values.
|
||||
;; tp-reactive.el Reactive state: dependency registry, variable
|
||||
;; watchers, batching queue.
|
||||
;; tp-layer.el Layer registry: `define-tp', `define-tps',
|
||||
@ -50,6 +52,7 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'tp-core)
|
||||
(require 'tp-style)
|
||||
(require 'tp-reactive)
|
||||
(require 'tp-layer)
|
||||
(require 'tp-ops)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user