geekinney/tp
1
0
Fork 0
Code Issues Pull Requests Actions 2 Packages Projects Releases Wiki Activity

refactor(tp)!: implement retained reactive runtime

Browse Source 
Replace the legacy managed layer renderer with one independent retained/reactive text runtime. TP now owns exact dependencies, stable objects, marker-backed mounts, property contribution composition, atomic publication, rollback, and direct text-property facades without ECSS or Ebox dependencies.\n\nBREAKING CHANGE: remove tp-render, tp-stack, scan-driven managed layers, inline runtime metadata, TP-owned CSS cascade APIs, and dollar-variable declarations.\n\nVerified: 290/290 ERT, shuffled 290/290 (seed 20260806), 8/8 doctests, WERROR compile-all, checkdoc, package-lint, diff-check, and isolated TP-only load.
This commit is contained in:
Kinneyzhang 2026-08-07 00:39:50 +08:00
parent 9d4047daf2
commit 0d35358e05
47 changed files with 4290 additions and 25516 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
.github/workflows/ci.yml vendored
View File

@ -20,32 +20,30 @@ jobs:
with:
version: ${{ matrix.emacs_version }}
- name: Install dash from GNU ELPA
- name: Install package-lint from MELPA
run: |
emacs -Q --batch --eval "(progn \
(require 'package) \
(setq package-user-dir (expand-file-name \".elpa\")) \
(add-to-list 'package-archives '(\"gnu\" . \"https://elpa.gnu.org/packages/\")) \
(add-to-list 'package-archives '(\"melpa\" . \"https://melpa.org/packages/\")) \
(package-initialize) \
(package-refresh-contents) \
(package-install 'dash))"
# Trailing slash: match only the package directory, not the
# adjacent dash-N.N.N.signed marker GNU ELPA leaves behind.
echo "LOAD_EXTRA=-L $(ls -d "$PWD"/.elpa/dash-*/ | head -1)" >> "$GITHUB_ENV"
(package-install 'package-lint))"
echo "PACKAGE_LINT_LOAD=-L $(ls -d "$PWD"/.elpa/package-lint-*/ | head -1)" >> "$GITHUB_ENV"
- name: Byte-compile (warnings are errors)
run: make compile-all WERROR=t LOAD_EXTRA="$LOAD_EXTRA"
run: make compile-all WERROR=t
- name: ERT suite
run: make test LOAD_EXTRA="$LOAD_EXTRA"
run: make test
- name: ERT suite (shuffled order)
run: make test-shuffled LOAD_EXTRA="$LOAD_EXTRA"
run: make test-shuffled SHUFFLE_SEED=20260806
- name: README doctests
run: |
set -o pipefail
make doctest LOAD_EXTRA="$LOAD_EXTRA" 2>&1 | tee doctest.log || {
make doctest 2>&1 | tee doctest.log || {
# Surface failing assertions as annotations (job logs are
# not readable anonymously; annotations are).
grep -E '^(FAIL| expected:| got:)' doctest.log | head -30 \
@ -54,3 +52,12 @@ jobs:
| while IFS= read -r l; do echo "::error::${l}"; done
exit 1
}
- name: Check documentation
run: make checkdoc
- name: Check package metadata
run: make package-lint LOAD_EXTRA="$PACKAGE_LINT_LOAD"
- name: Check diff whitespace
run: make diff-check

98
CHANGELOG.md
View File

@ -2,88 +2,34 @@
All notable changes to the tp library are documented here.
## Unreleased
## 1.0.0 (Unreleased)
### Added
- Retained content surfaces now support explicitly retained logical objects and `tp-object-attach-fragment`, so one stable object can own several disjoint marker-backed output fragments without putting runtime handles or positions into the pure plan. `tp-object-mounts` exposes defensive numeric range/tag snapshots through an object-keyed side index.
- `tp-transaction-participate` lets a client promote rollback-capable opaque side state after all affected surfaces publish but before source values commit. Participant keys are unique per outer transaction, failure rolls participants back in reverse publication order, and observers still run only after the transaction exits.
- `tp-propertize`, `tp-apply`, and `tp-watch` now provide simple one-shot string, one-shot buffer-range, and reactive existing-text entry points over the same schema/cascade/projector and retained properties-surface core.
- TP 1.0 retained surfaces now provide defensive pure plans, prepare-scoped object identity, keyed/positional reconciliation, `content` and `properties` capabilities, marker-backed range anchors, same-surface overlapping property contributions, compare-before-write conflicts and explicit rebase, common-prefix/suffix text edits, property-run diffs, side indexes, opaque client state, generic reports, lifecycle cleanup, and atomic multi-buffer publication with exact rollback. Pure materialization uses the same plan semantics without leaving live handles or subscriptions.
- TP 1.0 signals and bindings now form an exact source→binding and binding→binding dependency graph with conditional rewiring, memoized equality cutoffs, transaction-local candidate signal values, deduplicated topological flushing, nested-write stabilization, rollback, cycle paths, owner disposal, buffer-scoped sources, variable adapters, and public scheduler counters. The legacy layer scanner remains isolated only until the retained-surface cutover.
- 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
remain compatible.
- Stage 3 text-only native façade in `tp-query.el`:
`tp-lookup-result`, `tp-lookup`, `tp-property-change`,
`tp-property-any`, `tp-property-not-all`, and
`tp-with-mutation-policy`.
- Stage 4 managed lifecycle APIs: `tp-attach-managed-layers`,
`tp-detach-managed-layers`, `tp-managed-layer-diagnostics`,
`tp-managed-buffer-diagnostics`, `tp-managed-diagnostics`, and
`tp-layer-transaction`.
- Stage 5 overlay-aware lookup modes for `tp-lookup`: `:char` and
`:char-source` report Emacs character-property values and the
winning overlay identity when an overlay wins.
- `docs/API-SEMANTICS.md` centralizes the current object/coordinate,
mutation, presence/nil, search-result, layer-ownership, `tp-text`,
error, and hidden-stack conflict contracts.
- `tp-any-value`, a unique public sentinel for property-search wildcard
matching when later positional arguments also need to be supplied.
- `tp-unresolved-layer` and `tp-layer-conflict` error types.
- `tp-reactive-observer-errors`, a newest-first structured record of
isolated watcher callback failures.
### Fixed
- Initial `tp-text` rendering now preserves every embedded property
interval for strings and buffers instead of spreading position-zero
properties across the replacement.
- `tp-text` application preserves the caller's `tp-set`, `tp-reset`,
or `tp-add` write semantics even when replacement text is unchanged.
- Explicit nil properties override embedded `tp-text` values.
- Non-parameterized layer redefinition refreshes managed regions with
old/new ownership reconciliation: removed keys disappear, new keys
replace them, and unrelated or externally changed values survive.
- Search APIs distinguish omitted VALUE (any directly present value)
from explicit nil (a present nil value), with one presence-aware run
scanner shared by strings and buffers.
- Removing the last nested sub-property removes the empty parent key
consistently for strings and buffers.
- Stack NOERROR catches only unresolved layer specifications; errors
from layer bodies and internal operations propagate.
- When hidden-layer full-stack storage detects an external direct
property edit, stack decoding now signals `tp-layer-conflict` before
any managed write instead of silently discarding the external value.
- Buffer transaction rollback tracks its live range with markers, so
insertions and deletions inside the range are removed or restored
together with the original text-property snapshot.
- A standalone retained surface runtime with pure defensive plans, prepare-scoped stable objects, keyed/positional reconciliation, content and properties capabilities, marker-backed range anchors, object/mount indexes, scoped updates, opaque client state, generic reports, and lifecycle cleanup.
- Exact signal-to-binding and binding-to-binding dependency tracking with conditional rewiring, equality cutoffs, batched transactions, nested-write stabilization, owner disposal, buffer-scoped sources, variable adapters, cycle paths, and public structural counters.
- Atomic single- and multi-surface publication with candidate source values, prepare-all/publish-all ordering, explicit property journals, rollback-capable transaction participants, observer isolation, and authoritative kill-buffer cleanup.
- Native property policies and contribution composition with explicit nil/absence, normalization, validation, equality, merge, projection, named direct styles, and explicit `tp-computed` value sources.
- `tp-propertize`, `tp-apply`, and `tp-watch` as the one-shot string, one-shot buffer-range, and reactive existing-text conveniences over the same direct property/surface core.
- Retained logical objects with `tp-object-retain` and `tp-object-attach-fragment`, allowing one object to own multiple disjoint physical fragments without placing handles or positions in plans.
- Standalone examples for static properties, reactive status decoration, retained dashboards, and editable diagnostics.
### Changed
- Transform and compute failures now propagate as business-output
errors. A transform returning a non-string also signals. Watcher
failures remain isolated observers, but are recorded structurally
while the managed update continues.
- Managed layer entries now store `tp-meta` in authoritative
`tp-layers` storage, including parameterized args and definition
versions. Direct rendered properties and public stack queries strip
`tp-meta`; historical returns remain unchanged.
- Parameterized mounted layer entries refresh from stored args after
redefinition.
- Insert/copy/yank/stickiness/narrowing/indirect-buffer behavior is
now documented as direct Emacs delegation with no tp wrapper.
- Overlay creation, movement, deletion, priority management, and
lifecycle remain native Emacs responsibilities; tp only reports
overlay-aware lookup results.
- `tp-with-mutation-policy` accepts only ordinary+respect,
ordinary+inhibit, and silent+inhibit; silent+respect is rejected.
- Theme enable/disable events now increment theme generation and expose
conservative refresh diagnostics. Reproducible benchmark evidence is
recorded in `docs/BENCHMARKS.md`; timings are advisory baseline data,
not release thresholds.
- `define-tp` and `define-tps` now define static or parameterized direct declaration recipes. Applying a recipe produces ordinary properties and never publishes runtime identity metadata.
- TP is no longer a CSS engine. Selector, stylesheet, specificity, origin/importance, cascade layer, CSS-wide value, custom property, winner, and provenance behavior belongs to the independent ECSS package.
- Function-valued properties are always literal. Only values wrapped by `tp-computed` execute and participate in dependency collection.
- Runtime identity and provenance live exclusively in side state. Normal updates follow source to binding to object to marker-backed mount without scanning buffers or displayed text.
- Package documentation, API semantics, architecture, doctests, and tests now describe the single TP 1.0 runtime rather than the transitional 0.3 managed model.
### Removed
- `tp-render.el`, `tp-stack.el`, the scan-driven renderer, layer-to-buffer registry, and duplicate managed transaction path.
- Managed stack mutation, attach/detach, diagnostics, and lifecycle APIs that depended on inline stack storage.
- `tp-text`, `$variable` declaration syntax, automatic layer refresh, and character-level `tp-name`/`tp-layers`/`tp-meta` runtime storage.
- TP-owned CSS selector/stylesheet/cascade APIs and compatibility aliases.
- The unused Dash runtime dependency.
- Unused global theme lifecycle advice and managed-refresh bookkeeping from the deleted renderer.
## 0.3.0 (2026-07-27)

26
Makefile
View File

@ -7,25 +7,28 @@
# make benchmark # run reproducible correctness-first benchmarks
# make compile # byte-compile the library modules
# make compile-all # byte-compile modules + tests + dev scripts
# make checkdoc # validate source docstrings
# make package-lint # validate package metadata and public surface
# make diff-check # validate whitespace in the current diff
# make clean # remove compiled files
#
# WERROR=t turns byte-compile warnings into errors (used in CI).
# If dash.el is not on the default load-path, point LOAD_EXTRA at it:
# make test LOAD_EXTRA="-L ~/.emacs.d/elpa/dash-20240510.1327"
# LOAD_EXTRA can add optional development-tool load paths such as package-lint.
EMACS ?= emacs
LOAD_EXTRA ?=
WERROR ?= nil
TEST_DIR = tests
LOADPATH = -L . -L $(TEST_DIR) $(LOAD_EXTRA)
LOADPATH = -L . -L $(TEST_DIR) -L examples $(LOAD_EXTRA)
SRC = tp-core.el tp-style.el tp-reactive.el tp-surface.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
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
DEV = $(TEST_SUPPORT) tp-benchmark.el
EXAMPLES = $(wildcard examples/*.el)
DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el
.PHONY: test test-shuffled doctest benchmark compile compile-all clean
.PHONY: test test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean
test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
@ -51,5 +54,14 @@ compile-all: clean
--eval "(setq byte-compile-error-on-warn $(WERROR))" \
-f batch-byte-compile $(SRC) $(TESTS) $(DEV)
checkdoc:
$(EMACS) -Q --batch $(LOADPATH) --eval '(progn (require (quote cl-lib)) (require (quote checkdoc)) (let (warnings) (cl-letf (((symbol-function (quote display-warning)) (lambda (type message &optional _level _buffer-name) (push (format "%s: %s" type message) warnings)))) (dolist (directory (list "." "examples")) (dolist (file (directory-files directory t "\\.el$$")) (checkdoc-file file)))) (when warnings (dolist (warning (nreverse warnings)) (princ warning) (terpri)) (kill-emacs 1))))'
package-lint:
$(EMACS) -Q --batch $(LOADPATH) --eval '(progn (require (quote package-lint)) (let ((package-lint-main-file (expand-file-name "tp.el")) (command-line-args-left (mapcar (lambda (file) (expand-file-name (symbol-name file))) (quote ($(SRC)))))) (package-lint-batch-and-exit)))'
diff-check:
git diff --check
clean:
rm -f *.elc $(TEST_DIR)/*.elc
rm -f *.elc $(TEST_DIR)/*.elc examples/*.elc

4480
README.md
View File

File diff suppressed because it is too large Load Diff

4414
README_CN.md
View File

File diff suppressed because it is too large Load Diff

300
docs/API-SEMANTICS.md
View File

@ -1,215 +1,227 @@
# tp API 语义规范
# TP 1.0 API Semantics
本文档是 tp 核心 API 的当前行为契约。代码、测试、README 与 docstring 若与本文冲突，应以经过测试的代码为准并同步修正文档。
本文记录 TP 1.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为；目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
tp 当前定位是 **Emacs 文本属性的高层操作工具箱，以及一套受管理的命名层、层栈和响应式渲染模型**。它尚不是全部原生文本/字符属性语义的等价替代品；完整范围与路线见 [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。
## 1. 产品边界
TP 1.0 迁移的第一层纯计算合同已经落地在 `tp-style.el`：namespaced property schema、结构化 selector、确定性 cascade、逐属性继承、custom property、显式 `tp-computed` 和 Emacs 属性投影已经是当前 public behavior；retained object/surface/mount/transaction 尚未切换，仍以目标架构文档描述为未来合同。
TP 负责最终 Emacs text property policy/contribution、signals/bindings、stable objects、marker-backed mounts、surface diff、transaction、rollback 和 Buffer publication。
Stage 2 canonical façade 已完成为内部模型：`tp--native-range`、`tp--presence`、`tp--request`、`tp--match`、`tp--result` 是模块间传递的规范记录。公开入口和历史返回值保持兼容，不因内部模型收敛而改变。
TP 不实现 selector、stylesheet、specificity、origin/importance、CSS cascade layers、CSS-wide values、custom properties 或 Box/Flex/Grid。需要 CSS cascade 的调用者先通过独立 ECSS 获得 final declarations，再交给 TP。
Stage 3 text-only 原生语义 façade 已完成：direct/effective/source-aware lookup、property change/any/not-all 与三种 mutation policy 组合均有明确公开边界。
## 2. 普通值、显式 nil 与 computed source
Stage 4 managed lifecycle 已完成：managed metadata、attach/detach、diagnostics、transaction、参数化 mounted layer args/version refresh 与 theme generation diagnostics 均有公开边界。
普通 Elisp value 始终是 literal，包括 function object、keymap command、`help-echo` callback 和 list。TP 不会因为一个值可调用就执行它。
Stage 5 overlay-aware 字符属性查询已完成：`tp-lookup :char` / `:char-source` 报告 Emacs 选出的字符属性值、overlay 来源和获胜 overlay 身份。overlay 创建、移动、删除、priority 管理和生命周期不属于 tp 契约。
需要求值的 declaration 必须显式使用：
## 1. 对象、范围与坐标
```elisp
(tp-computed (lambda () ...))
```
- 所有范围均采用半开区间 `[START, END)`。
- 字符串使用 Emacs 原生的 0-based 坐标，合法边界为 `0` 到 `(length STRING)`。
- 缓冲区使用 Emacs 原生位置，通常从 `point-min` 开始；显式 BUFFER 和 nil（当前缓冲区）具有相同语义。
- 范围结果原则上使用目标对象的原生坐标。当前公开兼容例外是 `tp-intervals` / `tp-intervals-map`：缓冲区默认返回相对 START 的 offset，传入 `ABSOLUTE` 才返回可直接回传给写 API 的原生坐标。内部 canonical range 使用原生坐标，但该 relative 默认作为历史兼容例外保留。
`tp-resolve-value` 只执行这种 tagged source。compute result 只 normalize/project 一次，不会被隐式二次调用。compute error 直接终止 candidate transaction。
## 2. 修改策略
TP 严格区分：
| 调用族 | 字符串 | 缓冲区 |
| --- | --- | --- |
| `tp-set` / `tp-reset` / `tp-add` / `tp-remove` 整串形式 | 复制后返回新字符串 | 不适用 |
| 上述函数的 START/END 形式 | 原地修改显式字符串 OBJECT | 原地修改 |
| `tp-match-*` / `tp-regexp-*` | 返回新字符串 | 原地修改，返回匹配范围 |
| 层栈修改函数 | 原地修改字符串 | 原地修改 |
| `tp-forward-do` / `tp-backward-do` / `tp-search-map` | 原地修改；替换文本必须等长 | 原地修改；替换文本可增减长度 |
- absent：property plist 中没有该 key；
- present nil：property key 存在，value 为 `nil`。
普通缓冲区写入使用 Emacs 的属性修改原语，因此遵循 Emacs 的 modified、undo 和 read-only 行为；tp 不把所有修改默认包装为 silent modification。响应式重渲染和 `tp-text` 文本替换为了恢复受管理输出会在内部允许修改 read-only 文本，这是当前实现边界，不代表公开 API 已提供统一的 read-only 策略。相同值刷新会尽量避免无意义地翻转 buffer-modified 状态。
`tp-member` 和底层 contribution ledger 使用 presence-aware 语义。properties mount 的显式 nil contribution 可以覆盖 baseline，但 unmount 仍只撤销 TP 自己拥有的 contribution。
## 3. presence、nil 与 wildcard
## 3. Property policy 与 direct declarations
以下三种状态必须区分：
`tp-define-property-policy` 为一个 canonical native property id 注册：
1. 属性键不存在；
2. 属性键存在，值为 nil；
3. 属性键存在，值为非 nil。
- normalizer；
- validator；
- equality；
- merge；
- projector。
`tp-member` 用于判断直接属性键是否存在；`tp-at` / `plist-get` 单独使用时不能区分前两种状态。删除最后一个子属性会移除空的父属性键，不会偶然留下 `(PROPERTY nil)`。
注册是原子的：无效 options 或 function 会报 `tp-invalid-property-policy`，旧 definition 保持不变。
搜索 API 的规则是：
`tp-register-text-property` 为原生 Emacs property 建立默认 policy，并返回 policy record。`tp-text-property-id` 把原生 property 映射到 canonical `text/PROPERTY` id；`tp-text-declarations` 把普通 property plist 转换为 canonical declarations。
- 省略 VALUE：匹配该直接属性的任意已存在值；
- 显式传入 nil：只匹配“键存在且值为 nil”；
- 需要继续提供 OBJECT、次数或范围等后续位置参数时，传入公共唯一哨兵 `tp-any-value` 表示任意值；
- 自定义 PREDICATE 总是优先执行，并接收请求 VALUE（可能是 `tp-any-value`）和实际属性值。
`tp-merge-declarations` 按输入顺序合并 direct declaration groups，并防御性复制 caller-owned value。它只做 TP contribution composition，不实现 CSS winner selection。
属性缺失的范围不属于搜索结果，即使搜索值是 nil。
`tp-define-style`、`tp-style-declarations` 和 `tp-undefine-style` 管理 named direct declarations。registry getter 返回防御性副本。
## 4. 搜索结果
## 4. Declaration recipes
- `tp-search` 对字符串和缓冲区范围都返回 `(START END VALUE)` 列表。
- `tp-forward` / `tp-backward` 的字符串路径返回前/后 N 个 `(START END VALUE)`；缓冲区路径移动 point，并返回第 N 次搜索的 `prop-match`。
- `tp-forward-do` / `tp-backward-do` 只在第 N 个匹配上调用函数；匹配不足 N 个时不调用函数，返回实际找到的数量。
- `tp-search-map` 处理全部匹配并返回处理数量。
`define-tp` 定义一个返回 native property plist 的 recipe；`define-tps` 定义一组有序 recipe elements。`tp-define-layer`、`define-tp-group` 与 `tp-define-group` 是同一静态 declaration workflow 的命名入口。
`tp-forward` / `tp-backward` 的对象相关结果差异是现存公开兼容契约。内部搜索路径已收敛到 canonical match/result 记录；公开返回结构暂不改变。
Recipe 可以是静态或参数化的，可以组合其他 recipes。展开结果经过同一 direct property policy/projector。Recipe application 不建立 live identity，不写 `tp-name`、`tp-layers` 或 `tp-meta`。
## 5. 原生文本查询与修改策略
旧 `$variable` syntax 会报 `tp-invalid-layer-definition`。响应式值必须使用 `tp-computed` 加 signal/binding，不能建立第二套 watcher runtime。
Stage 3/5 查询 façade 已完成：text modes 保持 text-only，char modes 委托 Emacs 的 overlay-aware 字符属性查询。
Recipe/group definition 与 redefinition 是原子的：definition body、generated named elements 或 compiled style 任一步失败时，不留下半个新 definition，已有 definition 保持可用。
`tp-lookup` 返回 `tp-lookup-result` 记录，字段为 property、value、present-p、source、mode、object、position、overlay。text modes 中 overlay 始终为 nil；`:char` / `:char-source` 中 overlay 为 Emacs 选出的获胜 overlay，若文本 fallback 获胜则为 nil。
## 5. 一次性 façade
| MODE | 语义 |
### 5.1 `tp-propertize`
```elisp
(tp-propertize STRING DECLARATIONS)
```
返回新的 propertized string，不修改输入 STRING，不创建 object、binding、anchor、mount 或 surface。
### 5.2 `tp-apply`
```elisp
(tp-apply BUFFER START END DECLARATIONS)
```
只修改 BUFFER 的 `[START, END)` 文本属性，不替换文字，成功返回 `(START . END)`。无效 buffer 不会退回 current buffer；无效 range 直接报错。
### 5.3 Direct operations
`tp-set`、`tp-reset`、`tp-add`、`tp-remove`、`tp-clear`、`tp-get`、`tp-at` 与 `tp-member` 保留既有 string/buffer 调用形状，但统一经过 direct property resolution。
- whole-string `tp-set`/`tp-reset`/`tp-add` 返回新 string；
- 带 range 的 string 操作按各函数 docstring 的 mutation contract 执行；
- buffer 坐标使用 Emacs 原生 1-based position；
- string 坐标使用 0-based index；
- direct buffer write 遵循 Emacs read-only、undo 和 modified semantics。
Search/match/regexp/navigation/query API 继续委托 Emacs 原生 text-property interval 语义，不创建 retained runtime。
## 6. Signals 与 bindings
`tp-signal-create` 返回 global 或 buffer-scoped signal。`tp-signal-read` 在当前 binding computation 中登记依赖；`tp-signal-peek` 只读值而不登记依赖；`tp-signal-set` 在 transaction 中设置 candidate value。
相等写入按 signal equality 返回 no-op，不 invalidates subscribers。buffer-scoped signal 随 buffer kill 自动 dispose；global signal 使用 `tp-signal-dispose` 显式释放。
`tp-bind` 的 identity 是 owner 加 caller-namespaced key。相同 owner/key 幂等复用 binding。binding 保存 last successful value、dynamic dependencies、dirty/revision state 和 lifecycle policy。
`tp-binding-read` 读取 memoized binding value并登记 binding-to-binding dependency。每次 recompute 成功后，本次实际读取集合替换旧 dependencies；条件分支因此自动断开旧 source。cycle 报 `tp-binding-cycle` 并包含 dependency path。
删除 owner 会释放 bindings、subscriptions 和下游 edges。`tp-reactive-counters` 只读报告 invalidated、recomputed、skipped、subscription-added 和 subscription-removed，用于结构性性能验收，不暴露内部 hash tables。
## 7. Surface plan 与 object identity
`tp-surface-plan-create` 的公共字段是：
| Field | Contract |
| --- | --- |
| `:text-direct` | 只读取直接文本属性；显式 nil 与缺失通过 present-p/source 区分 |
| `:text-effective` | 值使用 `get-text-property`；source 使用 text-only 来源解释 |
| `:text-source` | 返回 direct/category/alias/default/absent 来源和值，不查看 overlay |
| `:char` | 使用 `get-char-property-and-overlay` 的值，按 Emacs overlay/text 优先级解析 |
| `:char-source` | 同 `:char`，并在 overlay 获胜时把 source 设为 `:overlay`、overlay 设为获胜 overlay |
| `key` | sibling-local stable key；同一 parent 下不可重复 |
| `kind` | opaque comparable discriminator |
| `text` | optional plain/propertized string leaf |
| `props` | final direct Emacs properties |
| `children` | ordered child plans |
| `tags` | opaque indexed metadata，TP 不解释其业务含义 |
| `capability` | `content` 或 `properties` |
source 取值为 `:text-direct`、`:category`、`:alias`、`:default`、`:overlay` 或 `:absent`。direct 显式 nil 的结果是 present-p 为 t、value 为 nil、source 为 `:text-direct`；alias nil 与 Emacs 原生语义一致，会继续寻找后续 alias/default；缺失属性的结果是 present-p 为 nil、value 为 nil、source 为 `:absent`。
Plan 不允许 marker、buffer position、patch op、producer closure 或 binding closure。Constructor 防御性复制 string、props、children 与 tags，使 caller 后续 mutation 不改变 committed plan。
`tp-property-change` 是 Emacs property change 原语的显式封装：`:direction :next` / `:previous` 选择 next/previous，传入 `:property` 时使用 single-property change，省略时使用 all-property change。
producer 在 prepare 阶段接收 context，并在产生 plan 前调用：
`tp-property-any` / `tp-property-not-all` 是 `text-property-any` / `text-property-not-all` 的薄封装，保留 Emacs 对显式 nil、边界和对象的行为。
```elisp
(tp-object-ensure CONTEXT PARENT KEY KIND)
```
`tp-with-mutation-policy` 只接受三种有效组合：
Object identity 只在所属 surface 中有效。显式 key 按 parent/key/kind reconcile；unkeyed object 按 position/kind reconcile。duplicate sibling key、stale parent、orphan object 或 cross-surface handle 在 prepare 中失败。
| POLICY | 语义 |
| --- | --- |
| `(:modified :ordinary :read-only :respect)` | 普通修改，尊重 read-only |
| `(:modified :ordinary :read-only :inhibit)` | 绑定 `inhibit-read-only`，普通 modified/undo 行为 |
| `(:modified :silent :read-only :inhibit)` | 绑定 `inhibit-read-only` 并使用 `with-silent-modifications` |
Candidate object 只有成功 publication 后才变为 live。失败 candidate handle 必须不可解析。`tp-object-resolve` 按 surface/key path 查询 live handle，不创建 identity。
`(:modified :silent :read-only :respect)` 明确拒绝，因为 silent modification 与尊重 read-only 不能同时满足。
无可见字符但需要保留的 logical object 使用 `tp-object-retain`。一个 logical object 可以通过 `tp-object-attach-fragment` 关联多个离散 plan fragments；attachment 保存在 prepare side state，不进入 plan。
insert、copy、yank、stickiness、narrowing 和 indirect buffer 行为直接委托 Emacs；tp 不为这些原生操作提供 wrapper。
## 8. Surface lifecycle
## 6. 直接模板展开与 managed mount
### 8.1 Materialize
层名有两种不同用途：
```elisp
(tp-surface-materialize-string PLAN-OR-PRODUCER)
```
### 6.1 直接模板展开
以 ephemeral prepare context 生成 propertized string，不建立 live surface。函数返回前释放 candidate objects、bindings、subscriptions 和 anchors。
把非响应式层名传给 `tp-set`、`tp-reset`、`tp-add`、`tp-match-*` 或 `tp-regexp-*` 时，层定义展开为普通属性，通常不保留 `tp-name`。结果不能依赖层名进行后续移动、隐藏、按名删除或静态重定义刷新。
### 8.2 Mount/update
匿名响应式属性和响应式层需要保留 `tp-name` 才能登记与刷新，这是直接路径中的受管理例外。
```elisp
(tp-surface-mount BUFFER PLAN-OR-PRODUCER OPTIONS)
(tp-surface-update SURFACE PLAN-OR-PRODUCER)
(tp-surface-update-scoped SURFACE OBJECTS PLAN-OR-PRODUCER OPTIONS)
```
### 6.2 managed mount
Mount options 支持 `:capability`、`:start`、`:end`、`:inhibit-read-only`、`:client-state` 和 `:observers`。
`tp-push-layer` / `tp-put-layer` 明确保留 `tp-name` 和必要的 `tp-layers` 状态。mounted layer 可以被查询、移动、隐藏、显示、删除和响应式刷新。
`content` surface 拥有其 span 的 text 和 properties，可以插入、删除、替换或移动输出。`properties` surface 只能贡献声明的 properties，不能替换 host text。
非参数化层重新定义后，已挂载区域按 old/new 所有权协调：
`tp-surface-update-scoped` 仍接收完整 candidate。TP 从 object-to-mount index 得到授权范围，验证 candidate 没有改变范围外输出，再在同一 transaction 发布。默认 mismatch 报 `tp-scope-mismatch`；`(:on-mismatch root)` 显式允许 full-root fallback。
- 新定义写入其拥有的键；
- 旧定义拥有、但新定义不再拥有的键，仅在当前值仍等于旧值时移除；
- 外部已经改写的值不会被当作旧层残留删除。
相等 candidate 不产生 publication，surface revision 和 buffer modified state 保持不变。
所有 managed mount 都携带 lifecycle metadata。即使只有单个 managed layer，只要存在 `tp-meta`，权威存储也使用 `tp-layers`；直接渲染属性和 `tp-layer-stack-at` 等 public stack query 不暴露 `tp-meta`。
### 8.3 Unmount
参数化层的已挂载 entry 保存调用实参、形参表和 definition version；重新定义参数化层后，既有 managed entry 会按保存的 args 刷新。历史无 metadata 的 entry 按 legacy entry 保守处理。
`tp-surface-unmount` 释放 surface、objects、bindings、mounts、markers、subscriptions、indexes 和 opaque client state，并返回 generic report。content surface 删除自己拥有的 span；properties surface 只撤销仍由 TP 拥有的 contributions。
`tp-attach-managed-layers` 扫描已经进入缓冲区的 managed storage，补齐/规范化 metadata，登记发现的层，并返回层名列表。`tp-detach-managed-layers` 移除 managed storage；KEEP-RENDERED 非 nil 时保留当前可见渲染属性为普通文本属性。
kill-buffer cleanup 以 buffer 死亡为权威结果，释放 runtime state，不尝试复活 buffer。
`tp-managed-layer-diagnostics`、`tp-managed-buffer-diagnostics` 和 `tp-managed-diagnostics` 是只读诊断入口，报告 entries、args、registry、errors 与 theme diagnostics。`tp-managed-diagnostics` 的 theme 部分报告 generation、last hook source、refresh mode、refreshed ranges 和 errors；这是 lifecycle 诊断，不是性能基准。
## 9. Range anchors 与 property conflicts
`tp-layer-transaction` 在给定范围内执行 managed stack 修改。成功返回结构化 plist，其中 `:status` 为 `ok`、`:ok` 为 t，`:result` 保留 FUNCTION 的返回值；失败时恢复事务前文本/属性快照并默认发出 `tp-layer-transaction-error`，NOERROR 非 nil 时返回结构化失败 plist。
`tp-range-anchor-create` 接受 buffer、start/end、marker insertion policy 与 `stale`/`shorten`/`remove` boundary policy，返回 opaque handle。raw marker 和 position 不进入 surface plan。
## 7. `tp-text` 替换
producer 使用 `tp-object-attach-range` 把 object 绑定到 anchor。一个 properties surface 的重叠 mounts 通过 property policy 合成 contributions。
- 初次应用和响应式更新都按内嵌字符串的真实属性 interval 处理，不从位置 0 采样后扩散到整段。
- 调用者显式属性覆盖内嵌属性；显式 nil 也是有效覆盖值。
- 未被调用者覆盖的内嵌属性按各自 interval 保留。
- 每个 interval 算出待写属性后，`tp-set` 只覆盖这些键并保留其他目标属性，`tp-reset` 替换目标的完整属性集合，`tp-add` 则对目标已有的 face-family 与嵌套 plist 继续合并；文本内容相同和发生替换时遵守同一规则。
- 字符串和缓冲区路径遵守相同的 per-interval 属性计算；对象的复制/原地策略仍按第 2 节执行。
TP 为每个 interval 保存：
## 8. 错误边界
- host baseline presence/value；
- ordered TP contributions；
- last published presence/value。
- 未定义或无法解析的层使用 `tp-unresolved-layer` 表达。
- 栈 API 的 NOERROR 只抑制 `tp-unresolved-layer`；参数化层 body、计算、属性结构和其他内部错误必须传播。
- 隐藏层存储发生所有权冲突时使用 `tp-layer-conflict`。
- transform 失败或返回非字符串、compute 失败都属于业务输出失败，必须传播。
- watcher 属于 observer：单个 watcher 失败不会阻断 managed update；失败会记录到 `tp-reactive-observer-errors`（newest first）并输出消息。
- 公开边界不应把内部失败转换为默认值后继续写入。
如果当前 host value 与 TP last published value 不同，update 报 `tp-property-conflict`，不会覆盖外部值。`tp-range-rebase` 显式把当前 host state 接受为新 baseline。Unmount 只在当前值仍等于 last published value 时恢复 baseline，否则保留 host value并在 report 中列出 conflict。
## 9. 隐藏层与外部直接修改
## 10. `tp-watch`
存在隐藏层时，`tp-layers` 保存完整 managed stack，其他直接属性是第一个可见层的渲染缓存。两类调用采用不同但明确的策略：
```elisp
(tp-watch BUFFER START END COMPUTE)
```
- definition/reactive refresh 知道正在刷新哪个定义，也知道直接属性对应哪个可见 entry；它先把原生直接编辑协调进该可见 entry，再执行 old/new 所有权刷新，因此外部改写值不会被当作旧定义残留删除；
- 普通 stack decode/write 缺少这次 definition refresh 的所有权上下文，缓存不一致时会在写入前发出 `tp-layer-conflict`，且不修改层栈；
- 所有层都隐藏时没有可接收直接属性的可见 entry，此时出现直接属性始终发出 `tp-layer-conflict`。
`COMPUTE` 返回 native direct declarations。`tp-watch` 组合 range anchor、properties surface、stable object 和 binding，返回 underlying surface handle。COMPUTE 中读取的 signals/bindings进入正常 dependency graph；更新与 unmount 使用同一 conflict和rollback合同。
tp 不会把外部属性收编成新的匿名层，也不会静默覆盖它。
## 11. Transactions
## 10. 返回值现状
`tp-with-transaction` 的顺序是：
核心写 API 的返回值仍保留历史差异：
1. 保存 candidate signal writes 并去重 dirty bindings；
2. 为所有实际受影响 surfaces 建立 prepare contexts；
3. 运行 binding graph 与 producers；
4. 校验 object、plan、capability、range、conflict 与 lifecycle；
5. 为所有 surfaces 准备 text/property operations 与 inverse journals；
6. 按稳定 surface id publish；
7. 原子切换 signals、bindings、plans、mount/index、client state 和 revisions；
8. 全部成功后运行 observers。
- buffer/region `tp-set` / `tp-reset` / `tp-add`：`(START . END)`；
- 整串复制式写入：新字符串；
- buffer `tp-remove` / `tp-clear`：nil；
- stack mutator：修改的 property-run 数量；
- `tp-put-layer` / `tp-push-layer`：显式 OBJECT 或 `(START . END)`。
嵌套 transaction 加入最外层。一个 global signal 可以原子触达多个 buffers；任一 surface 失败时，已发布 surfaces 和 source/binding state 全部回滚。
这些返回值是当前兼容契约。property-run 数量会受无关 interval 边界影响，不应被当成稳定业务标识。内部 request/result 模型已建立，但不会改变这些历史 public returns。
`tp-transaction-participate` 允许 client side state 在 surfaces 发布后、source commit 前加入同一 rollback boundary。participant key 在一个 outer transaction 中必须唯一。它不是 observer；失败会回滚 transaction。Observer failure 只记录，不回滚已提交结果。
## 11. 明确不在当前完整契约内
## 12. Diagnostics 与 reports
以下能力仍需设计或补齐，不能据现有 API 推断：
`tp-surface-report` 返回最近一次成功 publication 的防御性 report；equal/no-op update 不替换 report。字段包括 transaction/surface/revision、candidate source writes、binding counters、object reconcile counts、text/property operation counts、touched characters、scope/full-root 和 failure-related slots。
- overlay lifecycle（创建、移动、删除、priority 管理）；
- insert/copy/yank/stickiness 的 tp wrapper 或 managed workflow；
- mutation policy 三种组合之外的统一 read-only、silent modification、undo 策略；
- 字符串/缓冲区完全一致的搜索结果结构；
- observer 错误的清理、重试与汇总策略。
`tp-surface-inspect` 返回 surface id、buffer、capability、revision、object/mount count、opaque client state 与 report。`tp-surface-at-point` 从 side index 返回 mounted objects；它不扫描显示文本寻找 identity。`tp-object-mounts` 返回 defensive numeric range/tag snapshots，不暴露 live markers。
## 12. Schema-driven cascade
## 13. Error ownership
- `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。
- `tp-stylesheet-create` 建立相互隔离的 rule、layer order 与 source order domain；`tp-stylesheet-add-rule :stylesheet SHEET` 只写入该实例，`tp-compute-style :rules SHEET` 只读取该实例，避免不同 consumer 通过默认全局 stylesheet 相互污染。
- 独立 stylesheet 的生命周期归创建者所有；`tp-style-reset` 只清理 TP 的全局 schema、named style 与 default stylesheet，调用方必须用 `tp-style-reset-rules SHEET` 显式清理自己的实例。
- `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。
主要错误类型：
## 13. Signals、bindings 与 transaction
- property/declaration：`tp-property-error`、`tp-invalid-property-policy`、`tp-invalid-declaration`、`tp-invalid-layer-definition`、`tp-unresolved-layer`；
- reactive：`tp-reactive-error`、`tp-invalid-signal-scope`、`tp-disposed-signal`、`tp-disposed-binding`、`tp-binding-cycle`；
- retained surface：`tp-invalid-surface-plan`、`tp-duplicate-object-key`、`tp-invalid-prepare-context`、`tp-stale-object`、`tp-cross-surface-object`、`tp-orphan-object`、`tp-capability-error`、`tp-stale-mount`、`tp-property-conflict`、`tp-dead-surface`、`tp-invalid-range-anchor`、`tp-scope-mismatch`。
- `tp-signal-create` 创建 global 或 buffer-scoped source；`tp-signal-read` 仅在 binding compute context 中登记依赖，`tp-signal-peek` 永不登记依赖。buffer kill 会 dispose scoped signal；global signal 可用 `tp-signal-dispose` 显式结束 lifecycle，两者都会移除 subscriptions。
- `tp-bind` 的 identity 是 owner object identity 加 caller-namespaced key；重复安装复用同一 binding，compute definition 变化才使它 dirty。`tp-binding-read` 读取 memoized value 并建立 binding→binding edge。
- 每次成功 compute 以本次实际读取的依赖替换旧依赖；条件分支切换后旧 signal 不再触发。binding value 经其 equality comparator 判等，相等结果不 invalidates downstream。
- signal write 先写入 transaction-local candidate state。最外层 `tp-with-transaction` 只遍历 exact dirty closure，去重并按 binding dependency 拓扑惰性求值；compute 内嵌 write 排队稳定，不递归执行。
- `tp-transaction-participate KEY PUBLISH ROLLBACK` 只允许在 outer transaction 内登记。所有 surface candidate 发布并切换 client state 后，participant 按登记顺序执行 `PUBLISH`；任一后续步骤失败时，已经进入 publication 的 participant 按逆序执行 `ROLLBACK`。KEY 在同一 transaction 内唯一，两个函数均不得接收参数，rollback 必须能够撤销 publish 已经开始后的部分副作用。
- 任一 compute 或 cycle 失败会恢复 committed signal values、last successful binding values、dependencies、dirty state、owner registry 和 scheduler counters。cycle condition 携带 namespaced binding-key path。
- `tp-variable-signal` 是 global/buffer-local Elisp variable（包括后续 `$var` compiler）的 source adapter；它只转发精确 scope 的 write，不调用 legacy layer renderer。
- `tp-reactive-counters` 只公开 invalidated、recomputed、skipped、subscription-added、subscription-removed 五个工作量计数，不暴露 internal hash shape。
内部 computation 不吞错或返回貌似合理的 fallback。只有用户入口和 batch test runner等外层边界负责把错误转换为展示信息。
## 14. Retained surface、range ownership 与 publication
## 14. 1.0 删除项
- `tp-surface-plan-create` 只接受 key/kind/text/props/children/tags/capability 纯数据；text 与 children 互斥，同一 parent 的显式 key 不可重复，constructor 与每次 prepare 都做 defensive copy。普通 function property value 保持 literal identity，plan 不携带 marker、position、binding 或 producer closure。
- producer 在 active prepare context 中先用 `tp-object-ensure` 取得 candidate handle，再返回 plan 或 `tp-surface-result-create`。成功 publication 才使新 handle live；失败、materialize 返回或 orphan/cross-surface validation 失败都会释放 candidate bindings、anchors 与 subscriptions。`tp-object-resolve` 只读 live key path，不创建 identity。
- `tp-object-retain` 显式声明一个没有可见字符也应随 candidate 晋升的 logical object；未进入 plan、未 retain、也未 attachment 的 touched object 仍以 `tp-orphan-object` 拒绝。content producer 可用 `tp-object-attach-fragment` 把同一 logical object 挂到多个 plan fragment；attachment 只存在 prepare/side state，不进入 pure plan。`tp-object-mounts` 通过 object-keyed index 返回当前数值 start/end 与 opaque tags 的防御性快照，不暴露 live marker。
- `content` capability 拥有一个 disjoint text span，使用 character common-prefix/suffix 与 direct-property run diff；外部字符编辑使其 stale。`properties` capability 不能携带 text，只能通过 `tp-object-attach-range` 写 attached anchor。host edit 位于 anchor 前方时 marker 正常移动；跨入 owned range 时按 boundary policy shorten/remove/stale。
- `tp-surface-update-scoped` 接受同 surface 的 live object handles 和一个完整 candidate。scope 只在当前 transaction 内有效；TP 通过 object→mount index 得到授权范围，支持一个 logical object 的多个离散 mounts，并在 prepare 阶段证明 candidate 没有改变范围外输出。默认 mismatch 发出 `tp-scope-mismatch` 且零发布；只有显式 `(:on-mismatch root)` 才允许 full-root fallback。后续普通 reactive recompute 或 `tp-surface-update` 不继承这次 scope。
- properties ledger 保存 baseline、last-published value 与 contribution anchors。prepare compare-before-write；外部 property override 触发 `tp-property-conflict` 且保持旧 revision。`tp-range-rebase` 显式接受当前 host runs 为新 baseline；unmount 只恢复仍等于 TP last-published value 的子区间，冲突子区间保持外部值并进入 report。
- 同一 surface 的 overlapping properties contributions 按 plan order 和 native property schema merge；独立 surfaces 当前不得重叠字符 ownership。这个限制把 journal owner 保持为唯一 surface，避免两套 baseline 静默覆盖。
- 最外层 transaction 先完成所有 producer/plan/conflict validation，再按 surface id publish，随后执行 transaction participants，最后提交 source values。multi-buffer change group 负责 text rollback，TP 的精确 property journal 覆盖 `with-silent-modifications`；失败先逆序撤销已经进入 publication 的 participants，再恢复 buffer direct properties、markers/index、objects、plan、client state、revision、bindings 与 signal values。publish 中 killed buffer 不复活，其他 surfaces 与 sources 回滚。
- `tp-surface-report` 的字段只使用 transaction/surface/source/binding/object/text/property/conflict/observer/timing 通用词汇。observer 在成功 commit 且 publishing transaction 的动态范围退出后执行，因此 observer 中的 signal write 会开启新 transaction；observer error 只写入 report，不回滚。
TP 1.0 删除了不能诚实映射到统一 retained runtime 的 0.3 managed behavior：
## 15. 简单与响应式便利入口
- `tp-render.el` 和 `tp-stack.el`；
- stack push/pop/move/hide/show/merge/flatten workflow；
- `tp-text` 双向内容替换；
- `$variable` declaration syntax；
- layer-to-buffer registry、buffer-list/identity scan refresh；
- managed attach/detach/diagnostics/transaction；
- 以 `tp-name`、`tp-layers`、`tp-meta` 作为字符上权威 runtime database 的机制。
- `tp-propertize STRING DECLARATIONS` 接受 Emacs 原生 property plist，把它转换为 canonical `text/` declarations，经 schema/cascade/projector 后应用到 STRING 的防御性副本；它不建立 object、binding、anchor 或 surface。
- `tp-apply BUFFER START END DECLARATIONS` 使用同一 projection 与现有 range mutation primitive，只修改声明过的 direct properties，保留文本和未声明 property，并返回 `(START . END)`。
- `tp-watch BUFFER START END COMPUTE` 创建一个 properties-only surface。COMPUTE 是返回原生 property plist 的零参数函数；其 signal/binding dependencies 由 exact graph 收集。返回值就是可传给 `tp-surface-inspect`、`tp-surface-report` 和 `tp-surface-unmount` 的 opaque surface。首次 publication 失败会释放 convenience 层创建的 anchor。
TP 不提供 hidden compatibility engine，也不根据文本是否含旧 metadata 自动切换执行语义。静态 recipe、`tp-watch` 和 retained surface 分别承担复用声明、已有文本响应式属性与 retained content 的清晰职责。

889
docs/ARCHITECTURE.md
View File

@ -1,723 +1,230 @@
# tp 代码架构文档
# TP 1.0 Current Architecture
> 未来主版本目标：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。本文描述当前已经落地的实现，并明确标出仍处于迁移期的旧 runtime 与 TP 1.0 功能切片。
本文描述 TP 1.0 当前实现的模块边界、权威状态、数据流和事务模型。公共行为合同见 [API semantics](API-SEMANTICS.md)，设计背景见 [retained runtime architecture](retained-runtime-target-architecture.md)。
本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。TP 1.0 的纯 style/cascade kernel、exact signal/binding graph 与 retained surface publication 已分别在 `tp-style.el`、`tp-reactive.el`、`tp-surface.el` 落地；旧 managed façade 尚未切换。
## 1. 定位
当前 API 的规范契约见 [API-SEMANTICS.md](API-SEMANTICS.md)；Emacs 原生
文本属性覆盖范围、已确认问题与演进路线见
[REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。
TP 是通用 retained/reactive text runtime：
自 0.2.0 起，原来的单文件 tp.el 已拆分为分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。0.3.0 进一步收紧了模块边界：`tp-text` 处理链下沉至 tp-ops、批量更新上收至 tp-render、层栈存储编解码与匿名层机制归位 tp-layer，钩子变量从四个减少到两个。Stage 3 新增 tp-query，承载原生文本查询/change 封装与修改策略。各变更的缘由见 [CHANGELOG.md](../CHANGELOG.md)。
## 目录
- [架构概述](#架构概述)
- [模块分层](#模块分层)
- [Canonical records 与 dataflow](#canonical-records-与-dataflow)
- [tp-core.el：基础工具](#tp-coreel基础工具)
- [tp-reactive.el：响应式基础设施](#tp-reactiveel响应式基础设施)
- [tp-layer.el：层定义、解析与层栈存储](#tp-layerel层定义解析与层栈存储)
- [tp-ops.el：核心属性操作与 tp-text 处理链](#tp-opsel核心属性操作与-tp-text-处理链)
- [tp-search.el：模式匹配与搜索](#tp-searchel模式匹配与搜索)
- [tp-render.el：响应式渲染引擎](#tp-renderel响应式渲染引擎)
- [tp-stack.el：属性层栈操作](#tp-stackel属性层栈操作)
- [tp-query.el：原生文本查询与修改策略](#tp-queryel原生文本查询与修改策略)
- [tp-palette.el：调色板数据](#tp-paletteel调色板数据)
- [tp-builtins.el：内置层与辅助工具](#tp-builtinsel内置层与辅助工具)
- [钩子变量：唯一许可的反向调用](#钩子变量唯一许可的反向调用)
- [可变状态清单](#可变状态清单)
- [函数调用关系图](#函数调用关系图)
- [设计原则](#设计原则)
---
## 架构概述
tp 采用严格的线性分层：**每个模块只允许 `require` 并调用排在它前面的模块**，字节编译器强制检查这一依赖顺序。加载顺序即依赖顺序：
```
tp-core → tp-style → tp-reactive → tp-layer → tp-ops → tp-search
→ tp-render → tp-stack → tp-query → tp-palette → tp-builtins
```text
application state
→ signals/bindings
→ prepare context + stable objects
→ pure surface plan
→ reconcile/diff
→ atomic Buffer publication
```
注意加载顺序是依赖顺序的**上界**：并非每个模块都依赖它前面的全部模块。各模块实际 `require` 的 tp- 模块如下（逐一核对自源码头部）：
TP 负责文本属性 contribution、响应式依赖、身份、位置、变化和提交。调用者负责业务含义以及期望显示结果。
| 模块 | require 的 tp- 模块 |
|------|--------------------|
| tp-core | —（仅 cl-lib、dash、seq） |
| tp-style | tp-core |
| tp-reactive | tp-core |
| 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 |
| tp-stack | tp-core、tp-reactive、tp-layer（**不依赖 tp-ops / tp-search / tp-render**） |
| tp-query | tp-core |
| tp-palette | —（不依赖任何 tp- 模块，仅 subr-x） |
| tp-builtins | tp-core、tp-layer、tp-ops、tp-palette |
TP 不依赖 Ebox 或 ECSS，不包含 selector、stylesheet、CSS cascade、Box/Flex/Grid、measurement、layout owner 或 viewport dirty semantics。
```
┌────────────────────────────────────────────────────────────────┐
│ tp.el —— 总入口，按序 require 全部模块 │
└────────────────────────────────────────────────────────────────┘
┌────────────────────────────────────────────────────────────────┐
│ tp-builtins.el 内置层（tp-link, tp-space, tp-headline …）、 │
│ tp-palette-show、显示缓冲辅助宏 │
├────────────────────────────────────────────────────────────────┤
│ tp-palette.el 明/暗主题调色板数据、tp-parse-color │
│ （独立叶模块，不依赖任何 tp- 模块） │
├────────────────────────────────────────────────────────────────┤
│ tp-query.el 原生文本 lookup/change 封装、mutation policy │
├────────────────────────────────────────────────────────────────┤
│ tp-stack.el 层栈操作（push/pop/move/hide/show/merge …） │
├────────────────────────────────────────────────────────────────┤
│ tp-render.el 响应式重渲染引擎、最小差异 tp-text 编辑、 │
│ 批量更新（tp-with-batch-updates + flush）──┐ │
├─────────────────────────────────────────────────────────── │ ──┤
│ tp-search.el tp-match-*/tp-regexp-*、tp-search、导航 │ │
├─────────────────────────────────────────────────────────── │ ──┤
│ tp-ops.el tp-set/reset/add/get/at/remove/clear、 │ │
│ tp-text 处理链（0.3.0 起在此，直接调用） │ │
├─────────────────────────────────────────────────────────── │ ──┤
│ tp-layer.el define-tp/define-tps、层注册表与解析、 │ │
│ 层栈存储编解码、匿名层机制与 GC │ │
│ ◁╌╌ tp--layer-refresh-function ╌╌╌╌╌╌╌╌╌╌┤ │
├─────────────────────────────────────────────────────────── │ ──┤
│ tp-reactive.el 响应式依赖注册表、变量监听、批量队列、 │ │
│ 层→缓冲区注册表 │ │
│ ◁╌╌ tp--reactive-update-function ╌╌╌╌╌╌╌╌╌┘ │
├────────────────────────────────────────────────────────────────┤
│ tp-style.el property schema、structured selector、 │
│ cascade、custom property、computed value │
├────────────────────────────────────────────────────────────────┤
│ tp-core.el 区间遍历、plist/face 合并引擎、 │
│ 调试日志、$var 符号工具（无可变状态） │
└────────────────────────────────────────────────────────────────┘
## 2. 模块图
实线层级：上层模块调用下层模块（require 依赖）。
虚线（◁╌╌）：钩子变量 —— 下层模块预留的函数变量，
由 tp-render.el 在加载时安装实现（见下文）。
```text
tp-core
├─ tp-style
│ └─ tp-reactive
│ └─ tp-surface
├─ tp-layer
├─ tp-ops
├─ tp-search
├─ tp-query
├─ tp-palette
└─ tp-builtins
tp.el loads the public package surface
```
需要"向上调用"的逻辑全部收拢在 `tp-render.el`（位于 `tp-search.el` 之上，可以直接调用它）。0.2.0 时这类反向调用靠四个钩子变量实现；0.3.0 把其中两个消除在了代码层面——`tp-text` 处理链整体下沉进 tp-ops（`tp-set` 等直接调用，不再需要 `tp--tp-text-handler-function`；只加载到 tp-ops 的部分加载也能得到可用的 `tp-text` 文本替换），批量刷新整体上收进 tp-render（`tp--flush-batch-updates` 直接调用 `tp--reactive-flush-entry`，不再需要 `tp--reactive-flush-function`）。剩下的两个钩子对应真正源自下层的事件：变量监听器触发（tp-reactive）与层重定义触发（tp-layer）。
---
## 模块分层
### Canonical records 与 dataflow
Stage 2 canonical façade 是内部模型，不改变公开入口和历史返回值。五个记录承担模块间的规范数据边界：
| 记录 | 所有者 | 用途 |
|------|--------|------|
| `tp--native-range` | tp-core | 目标对象的原生 `[START, END)` 范围；字符串使用 0-based，缓冲区使用原生 buffer position |
| `tp--presence` | tp-core | 区分属性缺失、present nil、present non-nil |
| `tp--request` | tp-ops | 公开重载参数解析后的规范请求：对象、范围、操作、属性/值/谓词、修改策略 |
| `tp--match` | tp-search | 搜索内部匹配结果，统一字符串与缓冲区路径 |
| `tp--result` | tp-search | 搜索内部结果载体；最终按公开 API 的历史契约适配返回 |
数据流为：公开入口解析成 `tp--request`，tp-core 提供对象、native range、presence 与 adapter，tp-ops/tp-search/tp-stack 只在 I/O 边界按对象类型分支。内部搜索先产生 canonical `tp--match` / `tp--result`，再由公开入口保留旧返回结构；`tp-intervals` / `tp-intervals-map` 的缓冲区 relative 默认是显式保留的兼容例外。
### tp-core.el：基础工具
最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。0.3.0 起 tp-core **不再持有任何可变状态**（匿名层计数器已迁至 tp-layer；仅剩 `tp-debug-mode` / `tp-debug-echo` 两个 defcustom 用户选项）。
#### 区间操作
| 函数 | 描述 | 主要调用者 |
|------|------|--------|
| `tp-intervals` | 获取区域内文本属性区间列表（裁剪到 [START, END)；可选 ABSOLUTE 参数返回缓冲区原生坐标，默认仍为相对坐标） | tp-intervals-map, tp-get |
| `tp-intervals-map` | 对区间应用函数（同样支持 ABSOLUTE） | 多个属性/层操作函数 |
| `tp--map-intervals` | 共享的裁剪式区间遍历引擎 | tp-intervals-map, tp-ops/tp-stack 的区域操作, tp-reactive 的缓冲区扫描 |
| `tp-plist` | 获取区域中合并后的所有属性 | 用户 API |
| `tp-empty-p` | 检查对象是否没有文本属性 | 用户 API |
#### plist / face 合并引擎
| 函数 | 描述 | 主要调用者 |
|------|------|--------|
| `tp--deep-merge-plist` | 深度合并两个 plist | tp-add, tp--prepend-face 等 |
| `tp--prepend-face` | face 家族属性的合并逻辑 | tp-add, tp-match-add |
| `tp--merge-face-values` | 合并两个 face 值 | 合并引擎内部 |
| `tp--merge-duplicate-keys` | 合并 plist 中的重复键 | tp--parse-args |
| `tp--parse-face-list` | 解析 face 列表 | 合并引擎内部 |
| `tp--get-nested` | 按路径获取嵌套属性值 | tp-get, tp-at |
`tp-face-properties`（常量，`'(face font-lock-face mouse-face)`）定义参与 face 感知合并的属性家族。
#### `$var` 符号工具
| 函数 | 描述 |
|------|------|
| `tp--reactive-symbol-p` | 检查是否为 `$var` 响应式符号 |
| `tp--reactive-var-symbol` | `$var` 符号转变量符号 |
| `tp--collect-reactive-symbols` | 收集表达式中所有 `$var` 符号 |
| `tp--resolve-reactive-symbols` | 将 `$var` 解析为当前值（支持覆盖表） |
| `tp--extract-reactive-props` | 提取引用特定变量的属性 |
#### 调试工具
| 变量/函数 | 描述 |
|-----------|------|
| `tp-debug-mode` | 启用/禁用调试模式 |
| `tp-debug-echo` | 是否在 minibuffer 显示调试信息 |
| `tp-debug-log` | 记录调试信息 |
| `tp-debug-show` | 显示 *tp-debug* 缓冲区 |
| `tp-debug-clear` | 清除调试日志 |
另有辅助宏 `tp-with-current-buffer`。
---
### 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。默认 stylesheet 只服务便利入口；独立 consumer 使用 `tp-stylesheet-create` 持有隔离的 rule、layer 与 source-order domain。
普通 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。文件上半部是 TP 1.0 的唯一新响应式执行语义：global/buffer-scoped signal、owner+key binding identity、dynamic dependency collection、binding→binding graph、transaction-local candidate signal values、dirty dedupe/topological lazy flush、nested write stabilization、rollback-capable transaction participant、cycle path、owner disposal、variable adapter 和 public counters。participant 在全部 surface side state 发布后、source commit 前晋升 client-owned opaque state，失败时按逆序撤销；它不解释 client state。正常新热路径只从 source subscriber set 到 dirty binding，不读取 `buffer-list`、文本上的 `tp-name`/`tp-layers` 或 layer→buffer registry。
文件下半部仍暂存 0.3 façade 所需的变量→layer watcher、batch queue 和 layer→buffer registry，以保持旧测试在 retained surface 建成前可运行；它们没有被新 graph 调用，并将在最终 cutover phase 与 `tp-render.el` 扫描路径一起删除。这个暂存区不是第二套长期 public runtime。
### tp-surface.el：retained publication owner
该模块拥有 surface/object identity、marker-backed mount index、range anchor、properties ledger、buffer diff、publication journal 与 revision。`tp-surface-update-scoped` 复用同一完整 candidate prepare 和同一事务发布器，只把 live object handles 解析成当前事务的授权范围；它不是子树 renderer，也不接受 Ebox owner、dirty kind、layout patch 或 raw marker。范围外输出变化在 prepare 阶段拒绝，显式 root fallback 除外。
只依赖 `tp-core`、`tp-style` 与 `tp-reactive`。它集中拥有 prepare context、candidate/live object identity、pure surface plan、content/properties capability、range anchor、logical object→多个 marker-backed mounts、object-keyed mount index、position→object side index、properties contribution ledger、text/property diff、multi-buffer change group、silent-property inverse journal、opaque client state、revision、generic report 和 buffer-kill lifecycle。没有可见字符的 logical object 必须显式 retain；不连续输出通过 prepare-only object→plan-fragment attachment 建立，plan 本身仍没有 handle 或 position。normal update 从 binding owner 直接取得 prepared surface，再从 object 直接取得 mounts；不读取 `buffer-list`，也不按 `tp-name`、`tp-layers` 或显示文本反查 identity。
`content` mount 可以替换其拥有的 disjoint span；外部字符编辑会使 mount stale。`properties` mount 只能修改 attached anchor 上声明的 direct properties；同一 surface 内重叠 contribution 通过 native property schema 合成。外部值与 TP last-published value 不同时，prepare 报 `tp-property-conflict`，调用者必须 `tp-range-rebase` 或 unmount。独立 surfaces 的字符范围当前必须不重叠，以保持单一、可证明的 ownership journal。
`tp-propertize` 与 `tp-apply` 是 `tp-style` projection 加 `tp-ops` mutation primitive 的 one-shot 组合，不创建 runtime state。`tp-watch` 只把 range anchor、object binding 和 properties surface 组合成普通用户入口；它没有独立 scheduler、diff 或 publication path。
#### 依赖注册与管理
| 函数/变量 | 描述 |
|------|------|
| `tp-reactive-deps` | 变量 → 依赖它的层及属性 的注册表 |
| `tp--register-reactive-deps` | 注册响应式依赖 |
| `tp--unregister-reactive-deps` | 取消注册依赖（含 watchers/computed/data，并移除该层的缓冲区注册表条目） |
| `tp--layer-has-reactive-deps-p` | 层是否有响应式依赖 |
| `tp--register-layer-watchers` / `tp--unregister-layer-watchers` | 注册/清除 `:watch` 回调 |
| `tp--register-layer-computed` / `tp--unregister-layer-computed` | 注册/清除 `:compute` 计算属性 |
| `tp--register-layer-data` / `tp--unregister-layer-data` | 注册/清除 `:data` 变量 |
| `tp--apply-initial-computed` | 计算 `:compute` 的初始值 |
| `tp--ensure-reactive-variables` | 确保 `$var` 对应的变量已定义 |
| `tp-reactive-reset` | 重置全部响应式注册表（含批量队列与层→缓冲区注册表） |
#### 层→缓冲区注册表（0.3.0）
响应式更新不再全量扫描 `(buffer-list)`：每条会写入 `tp-name` 的缓冲区路径（tp-set 家族、栈变更函数、match/regexp 应用器）都把目标缓冲区登记到注册表，更新时只访问登记过的缓冲区。
| 函数/变量 | 描述 |
|------|------|
| `tp--layer-buffers` | 哈希表（`:test equal`）：层名 → 展示该层的缓冲区列表。键存在但值为空表示"已知：无缓冲区展示该层"，与键不存在（`unknown`）严格区分 |
| `tp-reactive--register-layer-buffer` | 幂等登记（公开写入口，tp-ops/tp-search/tp-stack 各自的注册助手最终都调用它）；首次使用时安装 `kill-buffer-hook` 清理器 |
| `tp-reactive-layer-buffers` | 查询某层的已登记存活缓冲区，或返回符号 `unknown`；惰性剔除已死缓冲区 |
| `tp-reactive--buffer-layer-names` | 栈感知的缓冲区扫描：直接 `tp-name` 与 `tp-layers` 栈存储内的层（被覆盖或被隐藏）都算在场。`tp-reactive-track-buffer` 与匿名层 GC 的存活检查共用它 |
| `tp-reactive-track-buffer` | 交互命令：扫描缓冲区并登记其中的全部层。用于弥补"插入已带属性的字符串"绕过登记路径的已知缺口 |
| `tp-reactive--prune-killed-buffer` / `tp-reactive--install-kill-buffer-hook` | kill-buffer 时从注册表剔除死缓冲区（条目保留为空列表，即"已知：无"） |
对 `unknown` 层，tp-render 的更新走一次**学习性**全扫描并登记实际找到的缓冲区；一处都没找到的层刻意保持 `unknown`，以便之后经非登记路径（如字符串插入）出现时仍能被下次扫描发现。
#### 变量监听与批量队列
| 函数 | 描述 |
|------|------|
| `tp--reactive-variable-watcher` | `add-variable-watcher` 回调；调用 `:watch` 后经 `tp--reactive-update-function` 委托重渲染 |
| `tp--invoke-layer-watchers` | 调用层的 `:watch` 回调 |
| `tp--queue-batch-update` | 将更新加入待处理队列 `tp--batch-update-pending`（刷新在 tp-render） |
钩子变量：`tp--reactive-update-function`（定义于此，由 tp-render.el 安装）。
---
### tp-layer.el：层定义、解析与层栈存储
依赖 tp-core、tp-reactive。提供 `define-tp` / `define-tps` 宏、层注册表、层名解析，以及 0.3.0 归位至此的**层栈存储编解码**与**匿名层完整生命周期**（铸造、驻留、注销、GC）。
#### 层定义
| 函数/宏 | 描述 | 依赖 |
|---------|------|------|
| `define-tp` | 定义单个自定义文本属性（层）；别名 `tp-define-layer` | tp--define-layer-internal |
| `define-tps` | 定义自定义文本属性组（层组）；别名 `define-tp-group`、`tp-define-group` | tp--define-layer-group-internal |
| `tp--define-layer-internal` | 层定义的运行时实现 | tp--parse-define-layer-args, tp--collect-reactive-symbols, tp--ensure-reactive-variables, tp--register-*, tp--layer-refresh |
| `tp--parse-define-layer-args` | 解析 `:props` / `:data` / `:compute` / `:watch` / `:transform` | - |
| `tp--parse-layer-group-element` | 解析层组元素 | tp--layer-group-element-format |
| `tp--define-layer-from-parsed` | 从解析结果定义层 | （与 define-tp 类似的依赖） |
| `tp--check-layer-cycle` | 检测循环层引用并报错 | tp--layer-expansion-stack |
0.3.0 起参数化层/层组的 ARGLIST 可以声明**任意个**参数（此前仅限一个）；`(LAYER ARG1 ... ARGN)` 与包裹形式 `(LAYER (ARG1 ... ARGN))` 在 `tp-set` 与 `tp-put-layer` 规格中均可用，实参数量不匹配会报出点名该层与两个数量的清晰错误。
#### 注册表与查询
| 函数/变量 | 描述 |
|------|------|
| `tp-layer-alist` / `tp-layer-groups` / `tp-layer-transforms` | 层、层组、转换函数注册表 |
| `tp--group-generated-layers` | 层组 → 其定义生成的层 的注册表（组重定义/注销时随之清理） |
| `tp--set-layer-props` / `tp--set-group-layers` | 写入注册表 |
| `tp-layer-props` / `tp-group-props` | 获取层/层组属性（`&optional INCLUDE-TP-NAME`，默认不含 `tp-name`；返回副本） |
| `tp-layer-props-with-arg` / `tp-group-props-with-arg` | 单参数形式（0.3.0 起是 -with-args 的薄封装） |
| `tp-layer-props-with-args` / `tp-group-props-with-args` | 多参数形式：ARGS 按位置绑定到层参数 |
| `tp-layer-arglist` | 返回参数化层的形参表副本（非参数化层返回 nil） |
| `tp-layer-parameterized-p` / `tp-group-parameterized-p` | 是否参数化 |
| `tp-describe-layer` | 交互命令：在 help 缓冲区展示层的存储格式、形参表、原始定义体、展开属性、响应式依赖、transform 与所属层组（数据采集在 `tp--describe-layer-data`） |
| `tp-layer-reset` | 重置层系统（连带调用 `tp-reactive-reset`；见[可变状态清单](#可变状态清单)） |
| `tp-undefine-layer` / `tp-undefine-group` | 删除层/层组（含其响应式依赖、转换与匿名层注册表条目） |
#### 属性解析
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--resolve-props` | 解析属性（展开层名、多参数规格、`$var`、注册依赖、驻留匿名层） | tp-layer-props(-with-args), tp--collect-reactive-symbols, tp--resolve-reactive-symbols, tp--anonymous-layer-name-for, tp--register-reactive-deps |
| `tp--expand-layer-in-plist` | 展开 plist 中的层名键 | tp--is-layer-name-p |
#### 匿名层机制与 GC（0.3.0 归位/新增）
| 函数/变量 | 描述 |
|------|------|
| `tp--anonymous-layer-counter` | 匿名层名计数器。**刻意不被任何 reset 清零**：脱离缓冲区的字符串可能仍携带旧的 `tp-anon-N` 属性值，计数器单调递增保证新铸名字永不与之混淆 |
| `tp--generate-anonymous-layer-name` | 生成唯一的 `tp-anon-N` 符号 |
| `tp--anonymous-layer-registry` | 匿名响应式层驻留表：`equal` 的 props 规格复用既有注册项 |
| `tp--anonymous-layer-name-for` | 驻留查询/铸造入口 |
| `tp--buffer-has-layer-region-p` | 栈感知的存活检查：直接 `tp-name` 或 `tp-layers` 内（被覆盖/被隐藏）皆算存活 |
| `tp-gc-anonymous-layers` | 交互命令：回收已无任何已登记存活缓冲区展示的匿名层；注册表状态为 `unknown` 的层（可能仅被游离字符串引用）保守保留 |
#### 层栈存储编解码
层栈在原始文本属性上的编码/解码知识集中在这里，tp-stack（栈操作）与 tp-render（响应式写穿）都向下调用它，互不 require。
| 函数 | 描述 |
|------|------|
| `tp--normalize-layer-spec` | 规范化层规格（含多参数 `(LAYER ARG1 ... ARGN)`） |
| `tp--build-layer-props` / `tp--layer-stack-to-list` | 旧式编解码原语（无隐藏层语义） |
| `tp--stack-hidden-p` | 层 plist 是否带 `tp-hidden` 标志 |
| `tp--plist-equivalent-p` / `tp--assert-hidden-render-cache` | 普通栈解码时验证完整存储的直接渲染缓存；无刷新上下文的不一致在改写前发出 `tp-layer-conflict` |
| `tp--stack-props-to-list` | 原始属性 → 有序层列表（顶层在前，含隐藏层）。完整存储模式下 `tp-layers` 持有完整栈，直接属性只是最顶可见层的渲染缓存，并在普通解码时执行冲突检查；definition/reactive refresh 由 tp-render 在明确可见 entry 上协调外部编辑 |
| `tp--stack-build-props` | 有序层列表 → 原始属性。单层栈不携带 `tp-layers`；含隐藏层时切换为"完整栈 + 渲染缓存"存储模式（全部隐藏时不渲染任何层属性） |
| `tp--get-layer-by-idx-or-name` | 通过索引或名称查找层 |
钩子变量：`tp--layer-refresh-function`（定义于此，由 tp-render.el 安装为
`tp--update-layer-regions`）；`tp--layer-refresh` 是它的调用入口，非参数化
层重定义后把 old props 一并传给渲染层，触发已挂载区域的 old/new 所有权协调。
---
### tp-ops.el：核心属性操作与 tp-text 处理链
依赖 tp-core、tp-reactive、tp-layer。面向用户的核心属性读写函数，直接调用 Emacs 原生文本属性 API。0.3.0 起 `tp-text` 处理链从 tp-render 下沉至此，`tp-set` 等**同模块直接调用**它（不再经钩子变量）——因此只加载到 tp-ops 的部分加载也能得到可用的 `tp-text` 文本替换。
#### 参数解析
| 函数 | 描述 | 调用者 |
|------|------|--------|
| `tp--parse-args` | 解析灵活的调用格式（整串/区域/层名/多参数层） | tp-set, tp-reset, tp-add |
| `tp--apply-props-to-string` | 字符串路径的属性应用 | tp-set, tp-reset, tp-add |
| `tp--ops-register-layer-buffer` | 应用带 `tp-name` 的属性到缓冲区后，登记到层→缓冲区注册表 | tp-set, tp-reset, tp-add |
#### tp-text 处理链（0.3.0 自 tp-render 迁入）
| 函数 | 描述 |
|------|------|
| `tp--handle-tp-text-property` | `tp-text` 属性的总入口：初始化/替换文本、双向同步响应式变量 |
| `tp--tp-text-replace` | 执行文本替换（缓冲区与字符串两条路径） |
| `tp--tp-text-transform` | 应用层的 `:transform`（首次渲染同样生效） |
| `tp--find-tp-text-reactive-var` | 找到层 `tp-text` 绑定的响应式变量 |
| `tp--merge-embedded-props` | 合并 tp-text 字符串内嵌属性与外部属性 |
| `tp--apply-reactive-text-props` | 把结果属性应用到替换文本（值未变的区段跳过写入，保持 buffer-modified 状态） |
| `tp--put-text-property-unless-equal` | 仅在值确实变化时写属性 |
#### 设置属性
| 函数 | 描述 | 依赖 | 被依赖 |
|------|------|------|--------|
| `tp-set` | 设置文本属性（保留其他属性） | tp--parse-args, tp--handle-tp-text-property, tp--ops-register-layer-buffer | tp-match-set, 层操作 |
| `tp-reset` | 完全替换所有文本属性 | 同上 | tp-match-reset |
| `tp-add` | 深度合并属性 | 同上 + tp--deep-merge-plist, tp--prepend-face | tp-match-add |
#### 获取属性
| 函数 | 描述 | 依赖 | 被依赖 |
|------|------|------|--------|
| `tp-get` | 获取范围内的属性值（返回区间列表） | tp--get-nested | 搜索函数 |
| `tp-at` | 获取单个位置的属性值 | tp--get-nested | 大多数高层函数 |
| `tp-member` | 区分"属性值为 nil"与"属性不存在"（plist-member 风格） | - | 用户 API |
#### 删除属性
| 函数 | 描述 | 依赖 | 被依赖 |
|------|------|------|--------|
| `tp-remove` | 移除属性或子属性 | tp--remove-property, tp--remove-sub, tp--remove-*-from-string | 用户 API |
| `tp-clear` | 清除所有属性（显式返回 nil） | - | 用户 API |
---
### tp-search.el：模式匹配与搜索
依赖 tp-core、tp-reactive、tp-layer、tp-ops（0.3.0 新增 tp-reactive 依赖：应用器写入缓冲区后经 `tp--search-register-layer-buffer` 登记层→缓冲区注册表）。提供模式匹配式属性应用、属性搜索与导航。
#### 模式匹配
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-match-set` / `tp-match-reset` / `tp-match-add` | 在字符串匹配处设置/重置/合并属性；0.3.0 起接受 START/END 界限（视同只存在该部分；颠倒的界限自动交换） | tp--match-apply |
| `tp-regexp-set` / `tp-regexp-reset` / `tp-regexp-add` | 在正则匹配处设置/重置/合并属性；0.3.0 起额外接受 SUBEXP（属性作用于每个匹配的该捕获组；超出组数报清晰错误） | tp--regexp-apply |
| `tp--match-apply` / `tp--regexp-apply` | 字面/正则匹配的入口（含多模式支持） | tp--pattern-apply |
| `tp--pattern-apply` / `tp--pattern-apply-single` | 共享的模式匹配引擎（空模式/零宽模式安全；承载 START/END/SUBEXP） | tp-set/tp-reset/tp-add 风格的 apply-fn |
| `tp--deep-merge-apply` / `tp--reset-apply` | 传给引擎的合并/重置回调（缓冲区路径顺带登记注册表） | tp--deep-merge-plist, tp--search-register-layer-buffer |
| `tp--search-register-layer-buffer` | 登记助手，转发到 `tp-reactive--register-layer-buffer` | tp-reactive |
#### 搜索和导航
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-forward` | 向前搜索 N 次并移动点；省略 VALUE 匹配任意直接存在值，显式 nil 精确匹配 present-nil | tp--property-search-forward |
| `tp-backward` | 向后搜索 N 次并移动点（与向前语义对称，同样新增 PREDICATE/NOT-CURRENT） | tp--property-search-backward |
| `tp--property-search-forward` / `tp--property-search-backward` | 基于统一直接属性 run 的单步搜索引擎 | tp--property-matches |
| `tp--property-match-p` | 谓词归一化（函数优先；否则 `tp-any-value` 通配，其他值用 `equal`） | - |
| `tp--property-matches` | 字符串/缓冲区共用、presence-aware 的直接属性 run 收集器 | text-properties-at, next-property-change |
| `tp-search` | 收集所有 `(START END VALUE)` 匹配区间 | tp--property-matches |
| `tp-search-forward` / `tp-search-backward` | **已废弃（0.3.0，make-obsolete）**：裸封装原语，nil-PREDICATE 默认语义与库内 `equal` 匹配相悖；请改用 `tp-forward` / `tp-backward`，或直接用 Emacs 原语 | text-property-search-* |
#### 遍历与替换
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-forward-do` / `tp-backward-do` | 向前/向后搜索并在第 TIMES 个匹配处执行函数（同样透传 PREDICATE/NOT-CURRENT） | tp--forward-do / tp--backward-do |
| `tp--forward-do` / `tp--backward-do` | 单方向遍历的内部实现 | tp--replace-match-text |
| `tp-search-map` | 对所有匹配应用函数（FUNCTION 接收 TEXT &optional START END IDX） | tp--search-do |
| `tp--search-do` | 搜索遍历的内部实现 | tp--replace-match-text |
| `tp--replace-match-text` | 共享的匹配文本替换助手（缓冲区支持变长替换；字符串变长时报错） | - |
---
### tp-render.el：响应式渲染引擎
依赖 tp-core、tp-reactive、tp-layer、tp-ops、tp-search。这是唯一"知道"渲染如何进行的模块：它直接调用 `tp-search-map`、`tp--tp-text-transform`、`tp--apply-reactive-text-props`（后两者位于 tp-ops——这条 require 是真实的下行调用，不只是加载顺序），并在加载末尾把自己的入口函数**安装**进下层模块预留的两个钩子变量。0.3.0 起批量更新宏与刷新逻辑也位于此。
#### 缓冲区遍历（0.3.0：注册表驱动）
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--render-visit-buffer` | 单缓冲区访问接缝（测试可包裹它统计访问次数） | tp-with-current-buffer |
| `tp--map-layer-buffers` | 在可能展示该层的缓冲区中执行更新：WHERE 为缓冲区（setq-local）时只走它；否则查注册表只访问已登记缓冲区；`unknown` 层回退为一次学习性 `(buffer-list)` 全扫描并登记实际命中的缓冲区 | tp-reactive-layer-buffers, tp--buffer-has-layer-region-p |
#### 重渲染
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--update-layer-regions` | 用 old/new 所有权协调重渲染已挂载区域，并**写穿**到 `tp-layers` 栈存储 | tp--layer-render-props, tp-search-map, tp--write-layer-through-stack-storage |
| `tp--write-layer-through-stack-storage` | 先按旧定义移除仍由该层拥有的键，再写入新定义；被覆盖或隐藏的副本也保持最新 | tp--stack-props-to-list, tp--stack-build-props [tp-layer] |
| `tp--reconcile-layer-props` / `tp--reconcile-layer-region` | 计算和写入 old/new 属性协调；保留不属于旧层或已被外部改写的值 | - |
| `tp--update-layer-computed` | 更新 `:compute` 计算属性（nil 可传播；错误向上抛出） | tp--store-computed-value |
| `tp--layer-render-props` / `tp--layer-reactive-props` | 求取层的渲染属性 | tp-layer-props |
#### 响应式文本（tp-text）
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--update-reactive-text` | 变量变化后更新响应式文本 | tp--replace-reactive-text-in-buffer, tp--map-layer-buffers |
| `tp--replace-reactive-text-in-buffer` | 在缓冲区中替换响应式文本（0.3.0：**最小差异编辑**——修剪公共前后缀只编辑差异区段，且先插入后删除，未变文本内的点位与标记不动；文本相同的更新完全不触碰缓冲区） | tp--edit-region-minimal-diff |
| `tp--edit-region-minimal-diff` | 最小差异编辑原语 | - |
| `tp--pos-holds-layer-in-storage-only-p` | 某位置的层是否只存在于栈存储（隐藏/被覆盖，跳过可见文本替换） | - |
#### 批量更新（0.3.0 自 tp-reactive 迁入）
| 函数/宏 | 描述 |
|------|------|
| `tp-with-batch-updates` | 批量更新宏：BODY 内的多次变量修改合并为一次刷新（队列变量仍在 tp-reactive，宏向下 let 绑定它们） |
| `tp--flush-batch-updates` | 刷新队列，按层去重后**直接调用** `tp--reactive-flush-entry`（不再经钩子） |
| `tp--reactive-flush-entry` | 单条刷新的工作函数（属性更新或 tp-text 替换） |
#### 引擎入口与钩子安装
| 函数 | 描述 |
|------|------|
| `tp--reactive-apply-update` | 变量变化的完整处理：更新 computed、合并层定义、重渲染或入批量队列（嵌套写入经队列而非递归）。尾部刷新置于 `unwind-protect` 清理段中，重渲染抛错也不会把队列条目困死。安装为 `tp--reactive-update-function` |
加载末尾执行安装（与源码逐字一致）：
```elisp
(setq tp--reactive-update-function #'tp--reactive-apply-update)
(setq tp--layer-refresh-function #'tp--update-layer-regions)
真实 require 关系按源码为准；上图表达责任层次，不要求每个 consumer 经过所有中间模块。
| Module | Owns | Must not own |
| --- | --- | --- |
| `tp-core.el` | canonical ranges/requests/results、interval traversal、plist/face merge、native property facts | runtime identity、reactivity、publication |
| `tp-style.el` | native property policies、direct declarations、explicit computed source、projection | selector、stylesheet、specificity、CSS winner |
| `tp-reactive.el` | signals、bindings、dynamic dependency graph、scheduler、candidate source state、transaction participants | buffer scans、mount positions、layout impact |
| `tp-surface.el` | prepare context、objects、plans、anchors、mount/index、contribution ledger、diff、publication、rollback、reports | stylesheet/cascade、consumer layout decisions |
| `tp-layer.el` | `define-tp`/`define-tps` declaration recipes and registry | live layer stack、inline runtime metadata、watcher engine |
| `tp-ops.el` | direct set/reset/add/get/at/remove/clear plus one-shot `tp-propertize`/`tp-apply` | retained identity、scan refresh |
| `tp-search.el` | match/regexp application、property search/navigation | runtime identity |
| `tp-query.el` | native lookup/change wrappers and mutation policy | retained publication |
| `tp-palette.el` | theme-aware palette data | runtime scheduling |
| `tp-builtins.el` | built-in direct recipes and display helpers | managed refresh hooks |
| `tp.el` | package metadata and public module loading | business logic |
There is no `tp-render.el` or `tp-stack.el`. The 0.3 scan renderer and managed stack runtime were deleted rather than wrapped.
## 3. Property data flow
Direct declarations are native property/value pairs. `tp-style.el` resolves them through one policy pipeline:
```text
native declarations
→ canonical text/PROPERTY ids
→ explicit computed-source resolution
→ normalize
→ validate
→ merge contributions
→ project to final Emacs properties
```
---
Ordinary functions are literal. Only a tagged `tp-computed` source runs. Explicit nil remains distinguishable from absence throughout projection and retained contribution ownership.
### tp-stack.el：属性层栈操作
The policy registry is generic. It knows how final Emacs properties compose; it does not decide which stylesheet declaration wins. CSS selection belongs to ECSS outside TP.
依赖 tp-core、tp-reactive、tp-layer——**不依赖 tp-ops**（0.2.0 的幻影依赖已在 0.3.0 移除，独立字节编译无警告）。所有栈变更函数建立在共享的裁剪式区域遍历之上，区域操作不会影响 [START, END) 之外的文本；栈的存储编解码在 tp-layer（向下调用）。0.3.0 起所有栈变更函数**返回实际修改的属性段数量**（0 表示无匹配；`tp-put-layer`/`tp-push-layer` 例外，仍返回 OBJECT 或 `(START . END)`），每次改写后经 `tp--stack-register-layers` 登记层→缓冲区注册表。字符串形式**原地修改**字符串（与 `tp-set` 的复制语义不同，各函数 docstring 均有警示）。
## 4. Static façade and declaration recipes
#### 内部助手
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--parse-layer-args` | 解析层操作的灵活参数 | - |
| `tp--plist-remove` | 返回去掉某键的 plist 副本 | - |
| `tp--stack-map-region` | 按区间遍历区域内层栈的共享引擎（解码经 tp--stack-props-to-list，含隐藏层） | tp--map-intervals [tp-core], tp--stack-props-to-list [tp-layer] |
| `tp--stack-register-layers` | 把新栈中每个带 `tp-name` 的层（含被覆盖与隐藏的）登记到缓冲区注册表 | tp-reactive--register-layer-buffer [tp-reactive] |
| `tp--put-layer-specs` | 展开层规格（层名/内联 plist/层名列表/参数化/层组） | tp--normalize-layer-spec, tp-group-props(-with-arg) [tp-layer] |
| `tp--move-layer-in-stack` | 在栈中移动层 | tp--get-layer-by-idx-or-name |
| `tp--raise-layer-in-stack` | 在栈中上下移动层 | tp--move-layer-in-stack |
| `tp--switch-layers-in-stack` | 交换两个层的位置 | tp--get-layer-by-idx-or-name |
`tp-propertize` and `tp-apply` use the same direct projection core but do not create live state. `tp-set/reset/add/remove` and the search/query families share canonical range, presence, and mutation primitives from `tp-core.el`.
#### 层操作（公开 API）
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-put-layer` | 在指定索引放置层（区域局部；0.3.0 新增尾参 NOERROR：未定义层名返回 nil 而非报错） | tp--put-layer-specs, tp--stack-map-region |
| `tp-push-layer` | 将层推到顶部（同样支持 NOERROR） | tp-put-layer |
| `tp-delete-layer` | 删除层 | tp--stack-map-region |
| `tp-pop-layer` | 弹出顶层 | tp-delete-layer |
| `tp-move-layer` | 移动层到指定位置 | tp--move-layer-in-stack, tp--stack-map-region |
| `tp-raise-layer` | 上移层 | tp--raise-layer-in-stack, tp--stack-map-region |
| `tp-lower-layer` | 下移层（0.3.0 新增，tp-raise-layer 的镜像） | tp--raise-layer-in-stack, tp--stack-map-region |
| `tp-rotate-layer` | 轮换层（0.3.0：规范顺序 `(START END DIRECTION [COUNT] [OBJECT])`，凭 `up`/`down` 符号无歧义分派；旧顺序永久兼容；单趟栈旋转实现） | tp--stack-map-region |
| `tp-pin-layer` | 将层一次性移到栈顶（不阻止后续 push 覆盖） | tp-move-layer |
| `tp-switch-layer` | 交换两个层 | tp--switch-layers-in-stack, tp--stack-map-region |
| `tp-hide-layer` | 隐藏层（0.3.0 新增）：层留在栈中、继续接收响应式更新但不渲染；隐藏可见顶层则显露下一可见层；全部隐藏时文本仅剩 `tp-layers` 记账属性 | tp--stack-map-region, tp--stack-build-props [tp-layer] |
| `tp-show-layer` | 取消隐藏（0.3.0 新增） | 同上 |
| `tp-merge-layers` | 合并多个层（显式 nil 值保留；隐藏的匹配层不贡献属性，全部匹配层均隐藏时合并结果保持隐藏） | tp--merge-layer-props, tp--stack-map-region |
| `tp-flatten-layers` | 扁平化所有层（只合并可见层；全部隐藏时得到裸文本） | tp--merge-layer-props, tp--stack-map-region |
`define-tp` and `define-tps` store recipe arglists and body forms. Application expands a recipe into ordinary direct properties. Static recipes are also compiled into the named style registry. Parameterized recipes stay evaluable recipes rather than frozen declarations.
#### 层查询
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-layer-list` | 列出所有层名称（含隐藏层） | tp--stack-map-region |
| `tp-layer-count` | 计算层数量（含隐藏层） | tp--stack-map-region |
| `tp-layer-exists-p` | 检查层是否存在 | tp-layer-list |
| `tp-layer-top` | 获取顶层名称（覆盖整个请求区域；按栈序报告最顶层，即使它被隐藏） | tp--stack-map-region |
| `tp-layer-stack-at` | 单个位置的完整有序层栈：`(NAME . PROPS)` 列表，顶层在前，隐藏层以 PROPS 中的 `tp-hidden t` 标识（0.3.0 新增） | tp--stack-props-to-list [tp-layer] |
| `tp-region-layer-props` | 获取区域中特定层的属性 | tp--stack-map-region |
Recipe and group redefinition uses candidate registry state and commits only after body expansion, generated element creation, and named-style compilation succeed. Failure restores the previous registry state.
#### 层属性操作
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-add-to-layers` | 向特定层添加属性 | tp--deep-merge-plist, tp--stack-map-region |
| `tp-add-to-all-layers` | 向所有层添加属性 | tp-add-to-layers |
No recipe application writes `tp-name`, `tp-layers`, or `tp-meta` to text. No `$variable` parser remains.
#### Managed lifecycle（Stage 4）
| 函数/状态 | 描述 | 依赖 |
|------|------|------|
| `tp-meta` | lifecycle metadata，保存在 `tp-layers` 权威存储中；直接渲染属性和 public stack query 会剥离它 | tp--managed-render-props, tp--managed-public-layer-props |
| `tp--managed-operation-counter` | transaction/entry id 的单调计数器 | tp--managed-next-operation-id |
| `tp-attach-managed-layers` | 扫描已有 managed storage、规范化 metadata、登记发现的层并返回层名 | tp--managed-normalize-stack, tp-reactive--register-layer-buffer |
| `tp-detach-managed-layers` | 移除 managed storage；KEEP-RENDERED 时保留当前可见渲染属性 | tp--managed-detached-props |
| `tp-managed-layer-diagnostics` | 只读层诊断：entries、args、registry、buffers、errors | tp--managed-buffer-diagnostic-data |
| `tp-managed-buffer-diagnostics` | 只读缓冲区诊断 | tp--managed-buffer-diagnostic-data |
| `tp-managed-diagnostics` | 全局只读诊断，含 theme diagnostics | tp--managed-theme-diagnostics |
| `tp-layer-transaction` | managed transaction；失败恢复原文本/属性快照，默认发出 `tp-layer-transaction-error` | tp--transaction-* |
## 5. Reactive graph
只要 layer stack entry 携带 `tp-meta`，即使只有一个 managed layer，也使用 `tp-layers` 保存权威 stack storage。参数化 mounted entry 保存 args、arglist 与 definition-version；层重定义后通过保存的 args 刷新既有 entry。历史无 metadata entry 作为 legacy entry 保守处理。
The authoritative graph lives in `tp-reactive.el`:
---
### tp-query.el：原生文本查询与修改策略
只依赖 tp-core。提供 Stage 3/5 原生 façade：直接/effective/source-aware text lookup、overlay-aware char lookup、property change/any/not-all 封装，以及显式 modified/read-only 修改策略。overlay lifecycle（创建、移动、删除、priority 管理）不属于 tp-query。
#### 查询记录与 lookup
| 函数/记录 | 描述 | 依赖 |
|------|------|------|
| `tp-lookup-result` | `cl-defstruct` 结果记录：property、value、present-p、source、mode、object、position、overlay | - |
| `tp-lookup` | 按 MODE 查询属性；支持 `:text-direct`、`:text-effective`、`:text-source`、`:char`、`:char-source` | tp--lookup-direct, tp--lookup-effective, tp--lookup-char, tp--lookup-source-cell |
| `tp--lookup-direct` | 只检查 `text-properties-at` 的直接 plist，区分 explicit nil 与 absent | plist-member |
| `tp--lookup-effective` | 值使用 `get-text-property`，source 使用 text-only 解释 | tp--lookup-source-cell |
| `tp--lookup-char` | 使用 `get-char-property-and-overlay`，overlay 获胜时 source 为 `:overlay` 且记录 overlay 对象 | get-char-property-and-overlay |
| `tp--lookup-source-cell` | 按 direct → category → alias → default → absent 解释来源 | text-properties-at, symbol-plist, char-property-alias-alist, default-text-properties |
| `tp--lookup-alias-cell` | 查找 `char-property-alias-alist` 中第一个直接存在的 alias 属性 | plist-member |
#### property change 与区域谓词
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-property-change` | `:direction :next` / `:previous`；传入 PROPERTY 时走 single-property change，省略时走 all-property change | next/previous-property-change, next/previous-single-property-change |
| `tp-property-any` | `text-property-any` 薄封装 | text-property-any |
| `tp-property-not-all` | `text-property-not-all` 薄封装 | text-property-not-all |
#### 修改策略
| 函数/宏 | 描述 |
|------|------|
| `tp--mutation-policy-modes` | 校验并归一化 `:modified` 与 `:read-only`；拒绝 `(:modified :silent :read-only :respect)` |
| `tp-with-mutation-policy` | 三种有效组合：ordinary+respect、ordinary+inhibit、silent+inhibit |
insert/copy/yank/stickiness/narrowing/indirect buffer 均不在 tp-query 中封装，行为直接委托 Emacs 原生操作。
---
### tp-palette.el：调色板数据
**不依赖任何 tp- 模块**（仅 subr-x），是独立的叶模块。明/暗主题双值调色板系统，`tp-palette-alist` 是唯一数据源。
| 函数/宏/变量 | 描述 |
|------|------|
| `define-tp-palette` | 定义调色板（重定义立即生效）；别名 `tp-define-palette` |
| `tp-palette-alist` | 调色板注册表（唯一数据源） |
| `tp-theme-generation` / `tp-theme-last-*` | theme lifecycle diagnostics：generation、last hook source、refresh mode、refreshed ranges、errors |
| `tp-theme-change-hook` | `enable-theme` / `disable-theme` 后运行的 hook；palette 只负责事件检测，managed renderer 可订阅 |
| `tp--palette-after-enable-theme` / `tp--palette-after-disable-theme` | theme lifecycle advice，递增 generation 并记录来源 |
| `tp-parse-color` | 解析颜色规格（支持 `("light" . "dark")` 及单边 cons） |
| `tp-theme-dark-p` / `tp-theme-light-p` | 当前主题判断 |
| `tp-palette-color` | 通用的主题解析取色器（0.3.0 新增的首选查询入口） |
| `tp-palette-has-p` | 谓词整合入口：KIND 取 `:fg`/`:bg`/`:border`/nil（0.3.0 新增） |
| `tp-palette-fg-color` / `tp-palette-bg-color` / `tp-palette-border-color` | 取前景/背景/边框色（兼容便捷函数） |
| `tp-palette-p` / `tp-palette-fg-p` / `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p` | 调色板谓词（兼容便捷函数） |
| `tp-palette-pure` | 取纯色值 |
---
### tp-builtins.el：内置层与辅助工具
最上层模块，依赖 tp-core、tp-layer、tp-ops、tp-palette。提供开箱即用的内置层与展示/缓冲辅助。
| 定义 | 描述 |
|------|------|
| 内置层 | `tp-palette`、`tp-fg`、`tp-bg`、`tp-button`、`tp-underline`、`tp-delete`、`tp-link`、`tp-space`、`tp-headline`、`tp-action` 等（`define-tp` 定义；`tp-link` 的颜色在应用时解析，主题切换即时生效） |
| `tp-pop-to-buffer` / `tp-switch-to-buffer` | 显示带属性文本的缓冲辅助宏（q 绑定在缓冲区局部 minor-mode keymap 中） |
| `tp-palette-show` | 展示所有调色板 |
| `tp--suffix-symbol` | 符号加后缀助手（0.3.0 起转为私有；`tp-suffix-symbol` 保留为废弃兼容别名） |
---
## 钩子变量：唯一许可的反向调用
分层规则的唯一例外是两个**钩子变量**：下层模块声明变量并在需要时 `funcall`，实现由 tp-render.el 在加载时安装。这样下层模块不必 `require` 上层模块，依赖图保持严格单向；而在未加载 tp-render 时，下层模块依然可用（钩子为 nil 时优雅降级：层可以定义与应用，只是没有自动重渲染）。
| 钩子变量 | 声明于 | 安装的实现（tp-render.el） | 用途 |
|----------|--------|---------------------------|------|
| `tp--reactive-update-function` | tp-reactive.el | `tp--reactive-apply-update` | 变量监听器触发的重计算与重渲染 |
| `tp--layer-refresh-function` | tp-layer.el | `tp--update-layer-regions` | 层重定义后刷新已应用区域 |
0.2.0 时钩子有四个；0.3.0 删掉了其中两个，代之以真实的模块内/下行调用：
- `tp--tp-text-handler-function`（原声明于 tp-ops）：整条 `tp-text` 处理链移入 tp-ops，`tp-set` 等直接调用 `tp--handle-tp-text-property`。副产品：只加载 tp-ops 的部分加载也能完成 `tp-text` 文本替换。
- `tp--reactive-flush-function`（原声明于 tp-reactive）：`tp-with-batch-updates` 与 `tp--flush-batch-updates` 移入 tp-render，刷新直接调用 `tp--reactive-flush-entry`。副产品：部分加载下批量刷新不再被静默丢弃，而是诚实地报 void-function。
留下的两个钩子对应真正**源自下层的事件**（变量被 set、层被重定义），无法在不打破分层的前提下改写为下行调用。
---
## 可变状态清单
各模块持有的可变运行时状态及其清理入口（0.3.0 全面核对）：
| 模块 | 状态 | 描述 | 清理 |
|------|------|------|------|
| tp-core | —— | **无可变状态**（仅 `tp-debug-mode`/`tp-debug-echo` 两个用户选项；调试日志写入 *tp-debug* 缓冲区，由 `tp-debug-clear` 清除） | - |
| tp-style | schema、named style、default stylesheet 与调用方持有的独立 stylesheet instances | 纯 style definition 和 rule/layer/source-order 状态；不保存 object、buffer 或 mount；独立实例不被全局 reset 暗中清理 | `tp-style-reset` / `tp-style-reset-rules` |
| tp-reactive | signals、owner bindings、dependency subscriber sets、variable adapters、transaction-local scheduler state、public counters | TP 1.0 exact reactive graph；normal update 不扫描 buffer | `tp-reactive-reset`；buffer-scoped signal 随 buffer kill |
| tp-surface | buffer-local surfaces、object/mount/index、range anchors、property ledgers、root/scoped publication、plan/client-state/revision/report | TP 1.0 retained publication；global registry 仅 weak-reference | `tp-surface-unmount`；buffer kill authoritative teardown |
| 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` |
| tp-reactive | `tp--layer-buffers` | 层→缓冲区注册表（哈希表，0.3.0 新增） | `tp-reactive-reset`（clrhash）；单层条目随 `tp-undefine-layer`/层重定义移除；死缓冲区经 kill-buffer-hook 与惰性访问剔除 |
| tp-reactive | `tp--batch-update-active` / `tp--reactive-updating` | 动态标志（let 绑定，非持久状态） | 随作用域退出 |
| tp-layer | `tp-layer-alist` / `tp-layer-groups` / `tp-layer-transforms` | 层、层组、转换注册表 | `tp-layer-reset` |
| tp-layer | `tp--group-generated-layers` | 层组生成的层 | `tp-layer-reset` |
| tp-layer | `tp--anonymous-layer-registry` | 匿名层驻留表 | `tp-layer-reset`；单条随 `tp-undefine-layer` / `tp-gc-anonymous-layers` |
| tp-layer | `tp--anonymous-layer-counter` | 匿名层名计数器——**刻意不清零**（任何 reset 都不动它）：游离字符串上残留的 `tp-anon-N` 名字永远不能与新铸层重名 | 从不 |
`tp-reactive-reset` 移除全部变量监听器并清空上表 tp-reactive 各行；`tp-layer-reset` 先调用 `tp-reactive-reset`，再清空 tp-layer 各注册表（计数器除外）。
---
## 函数调用关系图
（标注 `[模块]` 表示函数所在文件；`╌╌▷` 表示经钩子变量的间接调用。）
### tp-set 调用链
```
tp-set [tp-ops]
├── tp--parse-args [tp-ops]
│ ├── tp--merge-duplicate-keys [tp-core]
│ └── tp--resolve-props [tp-layer]
│ ├── tp-layer-props / tp-layer-props-with-args [tp-layer]
│ ├── tp--collect-reactive-symbols [tp-core]
│ ├── tp--resolve-reactive-symbols [tp-core]
│ ├── tp--anonymous-layer-name-for [tp-layer]（$var 匿名层驻留）
│ └── tp--register-reactive-deps [tp-reactive]
├── tp--handle-tp-text-property [tp-ops]（0.3.0 起同模块直接调用，不再经钩子）
│ └── tp--tp-text-transform / tp--tp-text-replace [tp-ops]
├── tp--apply-props-to-string [tp-ops]（整串形式，返回新字符串）
├── set-text-properties / put-text-property（Emacs 原生，区域形式）
└── tp--ops-register-layer-buffer [tp-ops]（缓冲区目标）
└── tp-reactive--register-layer-buffer [tp-reactive]
```text
signal ──subscribers──> binding ──subscribers──> binding
│
└── owner object/surface
```
### tp-add 调用链
```
tp-add [tp-ops]
├── tp--parse-args [tp-ops]
├── tp--handle-tp-text-property [tp-ops]（直接调用）
├── text-properties-at（Emacs 原生）
├── tp--prepend-face [tp-core]（face 家族属性）
│ └── tp--deep-merge-plist [tp-core]
├── tp--deep-merge-plist [tp-core]（其他嵌套属性）
├── put-text-property（Emacs 原生）
└── tp--ops-register-layer-buffer [tp-ops]
└── tp-reactive--register-layer-buffer [tp-reactive]
A binding is identified by owner plus caller-namespaced key. While its compute function runs, `tp-signal-read` and `tp-binding-read` record the exact dependencies used in that execution. On success, the new dependency set replaces the old set. A conditional branch therefore removes obsolete subscriptions automatically.
Signal writes enter transaction-local candidate state. Dirty bindings are deduplicated and evaluated by dependency order. Equal signal writes and equal binding results stop propagation. Nested writes queue another stabilization pass rather than recursively mutating output. Cycle detection reports the path.
The graph contains no layer-to-buffer registry. A source reaches surfaces through binding owners, not by scanning `buffer-list` or searching text properties.
## 6. Prepare context and identity
Every materialize/mount/update creates a short-lived prepare context. A producer calls `tp-object-ensure` before producing the corresponding plan node.
Object identity is scoped to one surface and derived from:
- parent object identity;
- sibling-local explicit key, or unkeyed position;
- opaque kind.
Candidate objects exist only inside the context. Successful publication promotes them to live objects; failed contexts dispose them and their bindings/anchors. `tp-object-resolve` queries live identity by key path without creating state.
The context records touched objects/bindings. Omitted objects are removed. Omitted bindings default to deletion unless an explicit lifecycle says retain. A logical object with no direct plan node must call `tp-object-retain`; disjoint physical output is attached through `tp-object-attach-fragment`.
## 7. Pure surface plans
A plan is a defensive immutable-semantics tree of key/kind/text/props/children/tags/capability. It contains desired output only.
It deliberately excludes:
- buffer/position/marker;
- patch operation or inverse journal;
- producer/binding closure;
- client continuation;
- consumer-specific layout identity.
TP validates sibling keys, legal text/children combinations, property shape, and capability before publication. Tags remain opaque; they are indexed for callers but never interpreted by TP.
`tp-surface-materialize-string` creates an ephemeral surface/context, renders the plan, then releases all candidate runtime state. `tp-surface-mount` creates a live surface and stores the producer or plan for later reactive preparation.
## 8. Mounts and side indexes
Every live surface owns:
- key path to live object table;
- object to bindings;
- object to marker-backed mounts;
- position/tag query index;
- retained plan and producer;
- properties contribution ledger;
- opaque client state;
- revision and last report.
The displayed text contains only properties needed by Emacs display or interaction. Identity, provenance, dependencies, marker metadata, revisions, and client state stay in side state.
`content` mounts own their text and properties. `properties` mounts attach objects to opaque range anchors and can only contribute properties to host-owned text.
One object may have multiple disjoint mounts. Public queries expose numeric range/tag snapshots, never live markers.
## 9. Properties contribution ledger
For every relevant anchor/property interval, the surface keeps:
- host baseline presence/value;
- ordered TP contributions;
- last published presence/value;
- contributing anchors.
Candidate preparation collects interval boundaries from old ledger entries, current mounts, and current host property runs. It verifies that a previously published value has not been replaced externally, composes the baseline with current contributions through the property policy, and emits an operation only when the resulting presence/value changes.
An external mismatch raises `tp-property-conflict`. `tp-range-rebase` replaces the baseline with current host state. Unmount restores a baseline only when the current value is still TP's last published value; otherwise it preserves the host edit and reports the conflict.
## 10. Reconcile and diff
TP reconciles object identity by the prepare tree and compares old/new plans for:
- created, removed, retained, and moved keyed objects;
- minimal character replacement using common prefix/suffix;
- exact property-run differences;
- mount/index changes;
- scoped output authorization.
`tp-surface-update-scoped` maps requested objects directly through the object-to-mount index. For content surfaces it proves old/new changes stay within those mounted ranges; properties surfaces perform the equivalent contribution-range proof. A mismatch is an error unless root fallback is explicitly selected.
An equal candidate produces no prepared publication. It preserves revision, report, buffer modified state, markers, and client state.
## 11. Transaction and publication
The outer transaction owns candidate source values, dirty bindings, prepared surfaces, participants, inverse journals, view state, and final observer scheduling.
```text
freeze candidate writes
→ recompute exact dependency closure
→ prepare every affected surface
→ validate all candidates
→ capture inverse journals
→ publish surfaces in stable id order
→ publish transaction participants
→ commit signals/bindings/surface state/revisions
→ run observers
```
### define-tp 调用链
```
define-tp [tp-layer]（宏）
└── tp--define-layer-internal [tp-layer]
├── tp--parse-define-layer-args [tp-layer]
├── tp--collect-reactive-symbols [tp-core]
├── tp--unregister-reactive-deps [tp-reactive]（连带移除旧的缓冲区注册表条目）
├── tp--ensure-reactive-variables [tp-reactive]
├── tp--register-layer-data [tp-reactive]
│ └── add-variable-watcher（Emacs 原生）
├── tp--register-layer-computed [tp-reactive]
├── tp--apply-initial-computed [tp-reactive]
├── tp--register-reactive-deps [tp-reactive]
├── tp--register-layer-watchers [tp-reactive]
├── tp--resolve-reactive-symbols [tp-core]
├── tp--set-layer-props [tp-layer]
└── tp--layer-refresh [tp-layer]
╌╌▷ tp--update-layer-regions [tp-render]（经钩子）
└── tp-search-map [tp-search]
└── put-text-property
```
Content publication edits the minimal text span and then exact property runs. Properties publication writes only prepared contribution operations. Marker mounts, indexes, plans, producer, bindings, opaque client state and report switch with the same revision.
### tp-push-layer 调用链
```
tp-push-layer [tp-stack]
├── tp--parse-layer-args [tp-stack]
└── tp-put-layer [tp-stack]
├── tp--put-layer-specs [tp-stack]
│ ├── tp--normalize-layer-spec [tp-layer]
│ │ └── tp-layer-props [tp-layer]
│ └── tp-group-props / tp-group-props-with-arg [tp-layer]
└── tp--stack-map-region [tp-stack]（裁剪到 [START, END)）
├── tp--stack-props-to-list [tp-layer]（解码既有栈，含隐藏层）
├── tp--stack-build-props [tp-layer]（编码新栈/渲染缓存）
├── set-text-properties（Emacs 原生）
└── tp--stack-register-layers [tp-stack]
└── tp-reactive--register-layer-buffer [tp-reactive]
```
Rollback restores text, properties, marker/index state, plans, producer, client state, signal values, binding values/dependencies, dirty queues, revisions and reports. Property journals are explicit because `atomic-change-group` alone does not cover every silent property mutation path.
### 响应式更新调用链
```
(setq some-reactive-var new-value)
└── tp--reactive-variable-watcher [tp-reactive]
├── tp--invoke-layer-watchers [tp-reactive]（:watch 回调）
└── ╌╌▷ tp--reactive-apply-update [tp-render]（经钩子）
├── tp--update-layer-computed [tp-render]
│ ├── tp--resolve-reactive-symbols [tp-core]
│ └── tp--set-layer-props [tp-layer]
├── tp--set-layer-props [tp-layer]（深合并回层定义；setq-local 不写全局）
├── tp--update-layer-regions [tp-render]（属性更新）
│ └── tp--map-layer-buffers [tp-render]
│ │（只访问注册表登记的缓冲区；unknown 层回退为
│ │ 一次学习性全扫描并登记命中缓冲区）
│ ├── tp-reactive-layer-buffers [tp-reactive]
│ ├── tp--buffer-has-layer-region-p [tp-layer]（回退路径）
│ └── 每缓冲区：
│ ├── tp-search-map [tp-search] → put-text-property
│ └── tp--write-layer-through-stack-storage [tp-render]
│ └── tp--stack-props-to-list /
│ tp--stack-build-props [tp-layer]
│ （隐藏/被覆盖的层副本同步刷新）
└── tp--update-reactive-text [tp-render]（tp-text 文本替换）
└── tp--replace-reactive-text-in-buffer [tp-render]
└── tp--edit-region-minimal-diff [tp-render]
（最小差异、先插入后删除；文本相同则完全不动缓冲区）
`tp-transaction-participate` lets a consumer promote rollback-capable opaque state inside this boundary. Observers are different: they run only after the transaction commits, and observer failure is recorded rather than rolled back.
批量模式（tp-with-batch-updates [tp-render]）/ 更新中的嵌套写入：
└── tp--queue-batch-update [tp-reactive]（入队，不递归）
└── tp--flush-batch-updates [tp-render]（退出批量/最外层更新结束时；
置于 unwind-protect 清理段，重渲染抛错也会排空队列）
└── tp--reactive-flush-entry [tp-render]（0.3.0 起同模块直接调用，不再经钩子）
├── tp--update-layer-regions
└── tp--update-reactive-text
```
If publication kills a target buffer, kill teardown is authoritative. Other surfaces and source state roll back; TP never recreates the killed buffer.
---
## 12. Lifecycle
## 设计原则
Surfaces are buffer-local lifecycle owners. A weak global registry supports lookup without keeping dead buffers alive. Mount installs local change/kill hooks; unmount and kill remove hooks, markers, ledger entries, objects, bindings, subscriptions, indexes, client state and weak registrations.
1. **严格分层**：模块只允许 `require` 并调用排在它前面的模块，字节编译器强制检查依赖顺序；且只声明真实存在的依赖（0.3.0 移除了 tp-stack→tp-ops 的幻影依赖，tp-palette 不依赖任何 tp- 模块）
2. **钩子反转**：唯一许可的"向上调用"是两个钩子变量（`tp--reactive-update-function`、`tp--layer-refresh-function`），由 tp-render.el 统一安装实现；能改写为下行调用的反转（tp-text 链、批量刷新）已在 0.3.0 改写掉
3. **单一职责**：每个模块（和函数）只负责一件事；一个子系统的完整生命周期住在一个模块里（匿名层的铸造/驻留/注销/GC 全在 tp-layer，层栈存储格式知识全在 tp-layer 的编解码器）
4. **复用优先**：共享引擎（`tp--map-intervals`、`tp--stack-map-region`、`tp--pattern-apply`、`tp--replace-match-text`、`tp-reactive--buffer-layer-names`）承载重复逻辑，高层函数复用而非复制
5. **统一接口**：所有核心属性函数支持相同的调用约定（整串/区域形式、层名、`$var`、多参数层）
6. **响应式解耦**：tp-reactive/tp-layer/tp-ops 不依赖渲染引擎；不加载 tp-render 时钩子为 nil，各模块优雅降级（`tp-text` 替换自 0.3.0 起随 tp-ops 即可用）；重渲染只访问层→缓冲区注册表登记的缓冲区，未知层才回退全扫描
Global signals are explicitly disposable. Buffer-scoped signals are disposed by their buffer kill hook. Owner disposal detaches both dependency directions so no downstream subscriber keeps a dead object alive.
## 13. Diagnostics
Public diagnostics are defensive snapshots:
- `tp-reactive-counters` reports graph work;
- `tp-surface-report` reports the last publication;
- `tp-surface-inspect` reports surface lifecycle/state counts;
- `tp-surface-at-point` queries side indexes;
- `tp-object-mounts` returns numeric range/tag snapshots.
Reports use generic terms such as bindings, objects, text/property operations, touched characters, scope and rollback. They contain no Ebox paint/layout vocabulary.
## 14. Architectural invariants
- TP source/tests/examples/package metadata do not require or name Ebox/ECSS runtime APIs.
- TP contains no CSS selector/stylesheet/specificity/origin/winner engine.
- There is one signal/binding/surface/mount/diff/transaction runtime; no embedded mode exists.
- TP is the only writer for live TP surfaces.
- Normal source-to-output flow is signal to binding to object to mount; it does not scan buffers or displayed text for identity.
- `tp-name`, `tp-layers`, and `tp-meta` are not runtime storage.
- Plans contain no raw positions or lifecycle closures.
- Ordinary functions are literal; only `tp-computed` executes.
- Candidate failure leaks no object, binding, anchor, subscription or revision.
- Every successful publication advances Buffer state and side state together; every failure preserves the previous committed revision.

2
docs/BENCHMARKS.md
View File

@ -1,5 +1,7 @@
# Reproducible benchmark evidence
> **Historical TP 0.3 benchmark snapshot; obsolete for TP 1.0.** These results measure the removed managed stack, `tp-text`, layer registry, scan-driven renderer, and 0.3 benchmark runner. They are preserved as historical evidence only and are neither TP 1.0 performance baselines nor current release gates. Current runtime structure and verification expectations are documented in the [README](../README.md), [current architecture](ARCHITECTURE.md), and [API contract](API-SEMANTICS.md).
## Command and environment
```sh

10
docs/CODE-ANALYSIS.md
View File

@ -1,14 +1,6 @@
# tp.el 代码分析报告
> **历史文档说明（2026-07 更新）**：本报告分析的是拆分前的单文件 tp.el（0.1.0）。
> 自 0.2.0 起，代码库已模块化为九个分层模块（tp-core.el → tp-reactive.el → tp-layer.el →
> tp-ops.el → tp-search.el → tp-render.el → tp-stack.el → tp-palette.el → tp-builtins.el，
> tp.el 仅作总入口），并修复了大量已确认的 bug。当前架构请以
> [ARCHITECTURE.md](ARCHITECTURE.md) 为准，本次变更明细见 [CHANGELOG.md](../CHANGELOG.md)。
> 下文的调用堆栈与问题分析保留为历史分析；"文件结构"与"关键代码位置"表已更新为当前模块位置。
> 当前 0.3.0 的 API 语义、原生兼容能力、已确认缺陷与扩展路线，请参阅
> [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)；修复后的规范契约见
> [API-SEMANTICS.md](API-SEMANTICS.md)。
> **历史 TP 0.1/0.3 分析，TP 1.0 已废弃。** 本报告混合记录拆分前的单文件 TP 0.1 与后续 TP 0.3 模块状态，其中的 `tp-render.el`、`tp-stack.el`、`tp-text`、inline `tp-name`/`tp-layers` 和扫描式响应更新均已从 TP 1.0 删除。下文的文件结构、调用堆栈、代码位置、API 与“当前”状态只属于历史快照，不适用于现行实现；正文保持原样作为设计证据。当前事实见 [README](../README_CN.md)、[当前架构](ARCHITECTURE.md)、[API 合同](API-SEMANTICS.md) 与 [1.0 变更记录](../CHANGELOG.md)。
本报告旨在帮助想要参与 tp.el 开发的开发者快速了解项目结构、核心功能实现、以及潜在的优化方向。

20
docs/REPOSITORY-AUDIT.md
View File

@ -1,5 +1,7 @@
# tp 仓库系统审计与“文本属性操作替代层”能力评估
> **历史 TP 0.3 审计，TP 1.0 已废弃。** 本文固定记录提交 `a65d799` 的审计证据和当时完成的 0.3 路线，不描述 TP 1.0 当前架构。下文的 managed layer/stack、`tp-render.el`、`tp-stack.el`、`tp-text`、inline `tp-name`/`tp-layers`/`tp-meta`、扫描刷新、阶段状态和代码链接均应按历史快照阅读，不应作为现行 API 或实现依据；正文语义保持原样。当前事实见 [README](../README_CN.md)、[当前架构](ARCHITECTURE.md)、[API 合同](API-SEMANTICS.md) 与 [1.0 变更记录](../CHANGELOG.md)。
> 审计日期：2026-07-28
> 审计快照：`a65d799`（tp 0.3.0）
> 结论置信度：高
@ -446,10 +448,10 @@ FINAL-TEXT:
- 缓冲区初次应用把 `bold` 扩散到整个替换范围。
而后续响应式更新已有按 interval 保留属性的专门路径
([`tp-render.el`](../tp-render.el#L339-L427))。这说明当前同一功能的“初次应用”
([`tp-render.el`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-render.el#L339-L427))。这说明当前同一功能的“初次应用”
和“更新应用”使用了两套不完全一致的合并引擎。
现有 [`tp-render-tests.el`](../tests/tp-render-tests.el#L318-L334) 覆盖了后续响应式更新，
现有 [`tp-render-tests.el`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-render-tests.el#L318-L334) 覆盖了后续响应式更新，
没有覆盖初次应用的这个状态。
**根因：**
@ -504,9 +506,9 @@ stack=((audit-static face italic help-echo "new"))
#### B. 已触发 refresh 时，只更新新键，不删除旧键
响应式层重定义会触发 refresh，但
[`tp--merge-props-into-stack-entry`](../tp-render.el#L142-L152)
[`tp--merge-props-into-stack-entry`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-render.el#L142-L152)
只复制旧 entry 后写入新 plist 出现的键；
[`tp--update-layer-regions`](../tp-render.el#L190-L233)
[`tp--update-layer-regions`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-render.el#L190-L233)
也只遍历新 props 做 `put-text-property`。
复现把响应式层从：
@ -636,7 +638,7 @@ stack=((audit-reactive face (:background "blue") help-echo "old"))
**状态：已确认。**
[`tp-put-layer`](../tp-stack.el#L279-L342) 的 `NOERROR` 路径使用宽泛的
[`tp-put-layer`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L279-L342) 的 `NOERROR` 路径使用宽泛的
`condition-case nil ... (error ...)`。本次定义一个解析成功但求值时主动报错的
参数化层后，`NOERROR=t` 返回 nil，内部的真实错误也被吞掉。
@ -711,7 +713,7 @@ stack=((audit-reactive face (:background "blue") help-echo "old"))
- 缓冲区原地修改。
层栈的大多数字符串形式又是原地修改
([`tp-stack.el`](../tp-stack.el#L494-L524))。
([`tp-stack.el`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L494-L524))。
这意味着仅从函数名或 OBJECT 类型无法判断是否修改原对象，还必须记住调用形式。
@ -971,9 +973,9 @@ tp 内部体系是自洽的，但熟悉 Emacs 的用户看到 `set` 往往会联
### 7.5 区域查询的标量返回值存在信息损失
[`tp-layer-list`](../tp-stack.el#L117-L126) 返回区域中出现过的层名 union；
[`tp-layer-count`](../tp-stack.el#L128-L136) 返回所有 run 的最大深度；
[`tp-layer-top`](../tp-stack.el#L143-L157) 返回第一个带名字的 top。
[`tp-layer-list`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L117-L126) 返回区域中出现过的层名 union；
[`tp-layer-count`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L128-L136) 返回所有 run 的最大深度；
[`tp-layer-top`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L143-L157) 返回第一个带名字的 top。
这些定义不是错误，但函数名看起来像在描述“整个区域的统一状态”。当区域内部
异质时，调用者无法从标量结果判断：

2
docs/reactive-optimization-en.md
View File

@ -1,5 +1,7 @@
# tp.el Reactive System Optimization Documentation
> **Historical TP 0.3 document; obsolete for TP 1.0.** This document evaluates the removed `$variable`, `tp-text`, inline `tp-name`, `tp-render.el`, and scan-driven batching model and remains only as design history. None of the implementation-status claims, function names, or examples below describe TP 1.0. The current optimization model uses an exact signal/binding dependency graph, transaction batching, and retained-surface diffing; see the [README](../README.md), [current architecture](ARCHITECTURE.md), and [API contract](API-SEMANTICS.md).
This document describes the optimizations and enhancements made to the tp.el reactive system based on practical experience from the [twidget](https://github.com/Kinneyzhang/twidget.git) project.
## Optimization Suggestions Evaluation

2
docs/reactive-optimization.md
View File

@ -1,5 +1,7 @@
# tp.el 响应式系统优化文档
> **历史 TP 0.3 文档，TP 1.0 已废弃。** 本文评估的是已经删除的 `$variable`、`tp-text`、inline `tp-name`、`tp-render.el` 与扫描式批处理模型，仅作为设计历史保留；下文的实现状态、函数名和示例均不适用于 TP 1.0。当前优化模型建立在精确 signal/binding 依赖图、事务批处理和 retained surface diff 上，详见 [README](../README_CN.md)、[当前架构](ARCHITECTURE.md) 和 [API 合同](API-SEMANTICS.md)。
本文档基于 [twidget](https://github.com/Kinneyzhang/twidget.git) 项目的实践经验，对 tp.el 的响应式系统进行了优化和增强。
## 优化建议评估

2
docs/reactive-text-properties-en.md
View File

@ -1,5 +1,7 @@
# tp.el Complete Guide to Reactive Text Properties
> **Historical TP 0.3 document; obsolete for TP 1.0.** This document records the removed `$variable`, `tp-text`, inline `tp-name`, and scan-driven reactive-update model and remains only as migration and design history. None of the APIs, examples, or “current behavior” claims below describe TP 1.0. The current reactive model uses signals, bindings, `tp-computed`, `tp-watch`, and retained surfaces; see the [README](../README.md), [current architecture](ARCHITECTURE.md), and [API contract](API-SEMANTICS.md).
> Bringing modern frontend framework reactive programming paradigms to the Emacs text properties world
## Introduction

2
docs/reactive-text-properties.md
View File

@ -1,5 +1,7 @@
# tp.el 响应式文本属性完全指南
> **历史 TP 0.3 文档，TP 1.0 已废弃。** 本文记录已经删除的 `$variable`、`tp-text`、inline `tp-name` 和扫描式响应更新模型，仅作为迁移与设计历史保留；下文的 API、示例和“当前行为”声明均不适用于 TP 1.0。当前响应式模型使用 signal、binding、`tp-computed`、`tp-watch` 与 retained surface，详见 [README](../README_CN.md)、[当前架构](ARCHITECTURE.md) 和 [API 合同](API-SEMANTICS.md)。
> 将现代前端框架的响应式编程范式带入 Emacs 文本属性世界
## 引言

8
docs/retained-runtime-target-architecture-en.md
View File

@ -2,7 +2,7 @@
Chinese version: [TP Retained/Reactive Text Runtime 目标架构](retained-runtime-target-architecture.md).
Status: approved TP 1.0 target, not yet implemented. [ARCHITECTURE.md](ARCHITECTURE.md) and [API-SEMANTICS.md](API-SEMANTICS.md) remain authoritative for TP 0.3.x current behavior.
Status: implemented TP 1.0 architecture contract. This document records the target boundaries now implemented and protected by tests; [ARCHITECTURE.md](ARCHITECTURE.md) and [API-SEMANTICS.md](API-SEMANTICS.md) are authoritative for current module and public-behavior facts. The `target-architecture` filename remains stable for existing links.
## 1. Product position
@ -193,10 +193,10 @@ TP 1.0 is a major-version transition. Stateless public APIs that map directly to
An explicit one-shot legacy import may scan historical propertized text and construct a surface. Normal signal/property/update hot paths never invoke it automatically.
The final system deletes the layer-to-buffer registry, scan-driven refresh hooks, old inline managed codec, duplicate transactions, and old batch renderer. TP 1.0 package, tests, examples, and this document all work without an Ebox repository.
The current implementation has deleted the layer-to-buffer registry, scan-driven refresh hooks, old inline managed codec, duplicate transactions, and old batch renderer. The TP 1.0 package, tests, examples, and this document all work without an Ebox repository.
## 13. Contracts frozen before implementation
## 13. Implemented, frozen contracts
Executable contract tests must define prepare-context/object timing; binding identity and lifecycle; literal/computed values; range anchors and property conflicts; single/multi-surface rollback; the three convenience levels; error taxonomy; report shape; explicit nil versus absence; and read-only, undo, narrowing, indirect-buffer, and kill-buffer behavior before implementation begins.
TP 1.0 executable contract tests define and continuously protect prepare-context/object timing; binding identity and lifecycle; literal/computed values; range anchors and property conflicts; single/multi-surface rollback; the three convenience levels; error taxonomy; report shape; explicit nil versus absence; and read-only, undo, narrowing, indirect-buffer, and kill-buffer behavior.
If implementation requires an Ebox/ECSS-specific branch, a CSS selector/cascade winner, a post-commit identity scan, raw position/closure in a plan, a second renderer, or cannot safely remove a properties contribution, integration stops for ownership review rather than adding an adapter mode.

8
docs/retained-runtime-target-architecture.md
View File

@ -2,7 +2,7 @@
英文版见 [TP Retained/Reactive Text Runtime Target Architecture](retained-runtime-target-architecture-en.md)。
状态：TP 1.0 已批准目标，尚未实现。TP 0.3.x 当前事实仍以 [ARCHITECTURE.md](ARCHITECTURE.md) 和 [API-SEMANTICS.md](API-SEMANTICS.md) 为准。
状态：TP 1.0 已实现的架构合同。本文记录已经落地并由测试保护的目标边界；当前模块和公共行为事实分别以 [ARCHITECTURE.md](ARCHITECTURE.md) 与 [API-SEMANTICS.md](API-SEMANTICS.md) 为准。文件名保留 `target-architecture` 以维持既有链接稳定。
## 1. 产品定位
@ -193,10 +193,10 @@ TP 1.0 是主版本切换。能直接映射到统一 core 的静态 public API
允许显式 one-shot legacy import 扫描历史 propertized text 并建立 surface；normal signal/property/update 热路径禁止自动调用它。
最终删除 layer→buffer registry、scan-driven refresh hooks、旧 inline managed codec、重复 transaction 和旧 batch renderer。TP 1.0 package、tests、examples 和本文档都能在没有 Ebox repository 的环境中独立工作。
当前实现已经删除 layer→buffer registry、scan-driven refresh hooks、旧 inline managed codec、重复 transaction 和旧 batch renderer。TP 1.0 package、tests、examples 和本文档均可在没有 Ebox repository 的环境中独立工作。
## 13. 实施前必须冻结的合同
## 13. 已冻结并实现的合同
实现开始前的 executable contract tests 必须确定：prepare-context/object 时序；binding identity/lifecycle；literal/computed value；range anchor 和 property conflict；single/multi-surface rollback；三层便利 API；error taxonomy；report shape；explicit nil/absence；read-only、undo、narrowing、indirect-buffer 和 kill-buffer 行为。
TP 1.0 的 executable contract tests 已确定并持续保护：prepare-context/object 时序；binding identity/lifecycle；literal/computed value；range anchor 和 property conflict；single/multi-surface rollback；三层便利 API；error taxonomy；report shape；explicit nil/absence；read-only、undo、narrowing、indirect-buffer 和 kill-buffer 行为。
任何实现若要求 Ebox/ECSS-specific branch、CSS selector/cascade winner、post-commit identity scan、plan 中的 raw position/closure、第二套 renderer 或无法安全撤销 properties contribution，应停止接入并重新评审 ownership model，而不是增加 adapter mode。

117
examples/diagnostic-decoration.el Normal file
View File

@ -0,0 +1,117 @@
;;; diagnostic-decoration.el --- TP diagnostics decorations example -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Demonstrates properties-only diagnostics with explicit ownership boundaries:
;; - create marker anchors directly with `tp-range-anchor-create`
;; - mount a properties surface with `tp-surface-mount`
;; - update it from a signal
;; - handle external host overrides and cleanup.
;;; Code:
(require 'tp)
(defun tp-example-diagnostic-decoration-mount (buffer)
"Mount a diagnostics decoration on BUFFER and return its control plist.
The decoration tracks a signal-controlled color on the word \"DIAG\"."
(let* ((target (get-buffer-create buffer))
(palette '((ok . "DarkGreen") (warn . "DarkOrange") (busy . "Purple")))
(mode-signal (tp-signal-create 'ok))
(range (cons 2 6))
(anchor nil)
(producer nil)
(surface nil))
(with-current-buffer target
(erase-buffer)
(insert "xDIAG")
(setq anchor
(tp-range-anchor-create target 2 6 :boundary-policy 'stale))
(setq producer
(lambda (context)
(let* ((root (tp-object-ensure context nil 'diag 'column))
(node (tp-object-ensure
context root 'diagnostic 'range))
(mode (tp-signal-read mode-signal))
(color (alist-get mode palette)))
(tp-object-attach-range context node anchor)
(tp-surface-plan-create
:key 'diag
:kind 'column
:capability 'properties
:children
(list
(tp-surface-plan-create
:key 'diagnostic
:kind 'range
:props (list 'help-echo
(format "mode=%s" mode)
'face `(:foreground ,color))
:capability 'properties))))))
(setq surface
(tp-surface-mount target producer '(:capability properties :inhibit-read-only t))))
(list :buffer target
:range range
:anchor anchor
:producer producer
:surface surface
:mode-signal mode-signal)))
(defun tp-example-diagnostic-decoration-object (state)
"Return the retained diagnostic object from STATE."
(tp-object-resolve (plist-get state :surface) '(diag diagnostic)))
(defun tp-example-diagnostic-decoration-range (state)
"Return STATE's active diagnostic range as `(START . END)`."
(let ((mount (car (tp-object-mounts (tp-example-diagnostic-decoration-object state)))))
(cons (plist-get mount :start) (plist-get mount :end))))
(defun tp-example-diagnostic-decoration-set-mode (state mode)
"Set diagnostics MODE in STATE and return the resulting report.
MODE should be one of `ok`, `warn`, or `busy`."
(tp-signal-set (plist-get state :mode-signal) mode)
(tp-surface-report (plist-get state :surface)))
(defun tp-example-diagnostic-decoration-repaint-range (state properties)
"Apply external PROPERTIES on the diagnostic range in STATE's buffer.
This simulates host edits that are outside TP ownership."
(let* ((buffer (plist-get state :buffer))
(range (tp-example-diagnostic-decoration-range state)))
(with-current-buffer buffer
(add-text-properties (car range) (cdr range) properties))))
(defun tp-example-diagnostic-decoration-insert-host-text (state position text)
"Insert TEXT at POSITION in STATE buffer."
(with-current-buffer (plist-get state :buffer)
(save-excursion
(goto-char position)
(insert text))))
(defun tp-example-diagnostic-decoration-delete-host-range (state start end)
"Delete host text in STATE buffer between START and END."
(with-current-buffer (plist-get state :buffer)
(delete-region start end)))
(defun tp-example-diagnostic-decoration-rebase (state)
"Rebase diagnostics anchors for STATE."
(tp-range-rebase (plist-get state :anchor)))
(defun tp-example-diagnostic-decoration-unmount (state)
"Unmount diagnostic decoration in STATE and dispose its signal."
(let* ((surface (plist-get state :surface))
(signal (plist-get state :mode-signal))
(report (when (tp-surface-live-p surface)
(tp-surface-unmount surface))))
(when (tp-signal-live-p signal)
(tp-signal-dispose signal))
report))
(provide 'diagnostic-decoration)
;;; diagnostic-decoration.el ends here

178
examples/reactive-status.el Normal file
View File

@ -0,0 +1,178 @@
;;; reactive-status.el --- Public TP reactive status watch example -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Reactive status example built only from public APIs:
;; - `tp-signal-create`
;; - `tp-signal-set`
;; - `tp-watch`
;;
;; The watch surface only owns a fixed range and updates properties when the
;; status signal changes.
;;; Code:
(require 'tp)
(defconst tp-example-reactive-status-tag "STATUS"
"Fixed status label shown by this example.")
(defun tp-example-reactive-status-mount (buffer)
"Mount a status watch on BUFFER and return its control state plist.
The returned state has keys:
- `:buffer` target buffer
- `:surface` retained properties surface returned by `tp-watch`
- `:status` status signal controlling foreground color
- `:noise` unrelated signal used to demonstrate sparse updates
- `:range` watched region"
(let* ((target (get-buffer-create buffer))
(status (tp-signal-create 'ready))
(noise (tp-signal-create 0))
(surface nil))
(with-current-buffer target
(erase-buffer)
(insert "STATUS")
(setq surface
(tp-watch target 1 7
(lambda ()
(list
'face
(if (eq (tp-signal-read status) 'ready)
'(:foreground "ForestGreen")
'(:foreground "IndianRed"))
'help-echo
(tp-computed
(lambda ()
(format "status=%s"
(tp-signal-read status))))))))
(list :buffer target
:surface surface
:status status
:noise noise
:range '(1 . 7)))))
(defun tp-example-reactive-status-dispose (state)
"Unmount reactive status STATE and dispose internal signals."
(when-let ((surface (plist-get state :surface)))
(when (tp-surface-live-p surface)
(tp-surface-unmount surface))
(setf (plist-get state :surface) nil))
(when-let ((status (plist-get state :status)))
(when (tp-signal-live-p status)
(tp-signal-dispose status))
(setf (plist-get state :status) nil))
(when-let ((noise (plist-get state :noise)))
(when (tp-signal-live-p noise)
(tp-signal-dispose noise))
(setf (plist-get state :noise) nil)))
(defun tp-example-reactive-status-set (state value)
"Set status STATE to VALUE.
STATE must come from `tp-example-reactive-status-mount`."
(tp-signal-set (plist-get state :status) value))
(defun tp-example-reactive-status-poke (state value)
"Set an unrelated signal in STATE to VALUE.
This must not affect watched STATUS rendering."
(tp-signal-set (plist-get state :noise) value))
(defun tp-example-reactive-status-clear-reactive-counters ()
"Reset TP reactive scheduler counters.
Useful before measuring sparse update behavior."
(tp-reactive-reset-counters))
(defun tp-example-reactive-status-watch-report (state)
"Return `tp-surface-report` for STATE."
(tp-surface-report (plist-get state :surface)))
(defun tp-example-reactive-status-color (state)
"Return the effective face color on STATE's watched range.
If called outside STATE's buffer, returns nil."
(with-current-buffer (plist-get state :buffer)
(plist-get (tp-at 1 'face) :foreground)))
(defun tp-example-reactive-content--producer (state)
"Return a retained content producer bound to STATE."
(lambda (context)
(let* ((object (tp-object-ensure context nil 'status 'text))
(branch
(tp-bind
object '(example . branch)
(lambda ()
(if (tp-signal-read (plist-get state :enabled))
(cons 'primary
(tp-signal-read (plist-get state :primary)))
(cons 'fallback
(tp-signal-read (plist-get state :fallback)))))))
(label
(tp-bind
object '(example . label)
(lambda ()
(pcase-let ((`(,source . ,value) (tp-binding-read branch)))
(format "%s:%s" source value))))))
(tp-surface-plan-create
:key 'status :kind 'text :text (tp-binding-read label)
:props '(face bold) :capability 'content))))
(defun tp-example-reactive-content-mount (buffer)
"Mount a conditional retained status in BUFFER and return its state."
(let* ((target (get-buffer-create buffer))
(state (list :buffer target
:enabled (tp-signal-create t)
:primary (tp-signal-create "ready")
:fallback (tp-signal-create "offline")))
(producer (tp-example-reactive-content--producer state))
(surface (tp-surface-mount
target producer '(:capability content))))
(setf (plist-get state :producer) producer
(plist-get state :surface) surface)
state))
(defun tp-example-reactive-content-set-enabled (state enabled)
"Set STATE's conditional branch to ENABLED and return its report."
(tp-signal-set (plist-get state :enabled) enabled)
(tp-surface-report (plist-get state :surface)))
(defun tp-example-reactive-content-set-primary (state value)
"Set STATE's primary status to VALUE and return its report."
(tp-signal-set (plist-get state :primary) value)
(tp-surface-report (plist-get state :surface)))
(defun tp-example-reactive-content-set-fallback (state value)
"Set STATE's fallback status to VALUE and return its report."
(tp-signal-set (plist-get state :fallback) value)
(tp-surface-report (plist-get state :surface)))
(defun tp-example-reactive-content-batch-primary (state values)
"Set STATE's primary status through VALUES in one transaction."
(tp-with-transaction
(dolist (value values)
(tp-signal-set (plist-get state :primary) value)))
(tp-surface-report (plist-get state :surface)))
(defun tp-example-reactive-content-text (state)
"Return plain retained status text from STATE."
(with-current-buffer (plist-get state :buffer)
(buffer-substring-no-properties (point-min) (point-max))))
(defun tp-example-reactive-content-dispose (state)
"Unmount STATE and dispose all signals it owns."
(when (tp-surface-live-p (plist-get state :surface))
(tp-surface-unmount (plist-get state :surface)))
(dolist (key '(:enabled :primary :fallback))
(let ((signal (plist-get state key)))
(when (tp-signal-live-p signal)
(tp-signal-dispose signal)))))
(provide 'reactive-status)
;;; reactive-status.el ends here

160
examples/retained-dashboard.el Normal file
View File

@ -0,0 +1,160 @@
;;; retained-dashboard.el --- Public TP retained content dashboard example -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; A compact retained dashboard example with additive/removable/reordered
;; keyed entries. It uses:
;; - `tp-surface-mount`
;; - `tp-surface-update`
;; - `tp-surface-unmount`
;; - `tp-surface-inspect`
;; - `tp-object-resolve`
;;
;; No stack/render/managed runtime APIs are used.
;;; Code:
(require 'tp)
(defun tp-example-dashboard--entry-label (entry)
"Return a display label for ENTRY.
ENTRY is a plist with keys `:id` and `:label`."
(concat " " (or (plist-get entry :label) (prin1-to-string (plist-get entry :id))) " "))
(defun tp-example-dashboard--entry-face (entry theme)
"Return a native face declaration for ENTRY.
ENTRY may include `:active` (`t` / nil).
THEME is symbol `light` or `dark`."
(let* ((light-active '(:weight bold :foreground "#0f6fff"))
(light-idle '(:foreground "#657b83"))
(dark-active '(:weight bold :foreground "#83a598"))
(dark-idle '(:foreground "#d3d3d3"))
(palette (if (eq theme 'dark) (cons dark-active dark-idle)
(cons light-active light-idle))))
(if (plist-get entry :active)
(car palette)
(cdr palette))))
(defvar tp-example-dashboard-entry-keymap
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") #'ignore)
map)
"Keymap installed on each retained dashboard entry.")
(defun tp-example-dashboard--entry-button (entry)
"Return a BUTTON property for ENTRY."
(format "entry:%s" (or (plist-get entry :id) "item")))
(defun tp-example-dashboard--entry-theme (state)
"Return the active dashboard theme symbol from STATE."
(tp-signal-read (plist-get state :theme)))
(defun tp-example-retained-dashboard--build-producer (state entries)
"Return a dashboard producer function bound to STATE and ENTRIES.
STATE owns the theme signal. ENTRIES is candidate content captured by the
producer and becomes committed state only after publication succeeds."
(lambda (context)
(let* ((theme (tp-example-dashboard--entry-theme state))
(root (tp-object-ensure context nil 'dashboard 'group))
(children
(mapcar
(lambda (entry)
(let ((id (plist-get entry :id)))
(tp-object-ensure context root id 'entry)
(when (plist-get entry :force-failure)
(error "Dashboard update failure"))
(tp-surface-plan-create
:key id
:kind 'entry
:text (tp-example-dashboard--entry-label entry)
:props (list
'face (tp-example-dashboard--entry-face entry theme)
'keymap tp-example-dashboard-entry-keymap
'button (tp-example-dashboard--entry-button entry))
:capability 'content)))
entries)))
(tp-surface-plan-create
:key 'dashboard
:kind 'column
:children children
:capability 'content))))
(defun tp-example-retained-dashboard-mount (buffer &optional entries)
"Mount a retained dashboard in BUFFER and return its control plist.
ENTRIES defaults to three sample entries and is expected to be a list of
plist records `(:id <symbol> :label <string> :active <t/nil>)`."
(let* ((target (get-buffer-create buffer))
(state (list :entries (or entries
'((:id alpha :label "Alpha" :active t)
(:id beta :label "Beta")
(:id gamma :label "Gamma"))
)
:theme (tp-signal-create 'light)
:buffer target))
(producer (tp-example-retained-dashboard--build-producer
state (plist-get state :entries)))
(surface (tp-surface-mount target producer
'(:capability content))))
(list :buffer target
:surface surface
:producer producer
:state state)))
(defun tp-example-retained-dashboard-update (dashboard entries)
"Update DASHBOARD with ENTRIES and run a scoped mount publication.
Return `tp-surface-report`."
(let ((surface (plist-get dashboard :surface))
(state (plist-get dashboard :state)))
(let* ((producer (tp-example-retained-dashboard--build-producer
state entries))
(report (tp-surface-update surface producer)))
(setf (plist-get state :entries) entries)
(setf (plist-get dashboard :producer) producer)
report)))
(defun tp-example-retained-dashboard-set-theme (dashboard theme)
"Set DASHBOARD to THEME and return its resulting surface report.
THEME must be `light` or `dark`."
(let ((state (plist-get dashboard :state)))
(tp-signal-set (plist-get state :theme) theme)
(tp-surface-report (plist-get dashboard :surface))))
(defun tp-example-retained-dashboard-report (dashboard)
"Return DASHBOARD's current surface report."
(tp-surface-report (plist-get dashboard :surface)))
(defun tp-example-retained-dashboard-remove (dashboard)
"Unmount DASHBOARD, dispose its signal, and return the commit report."
(let* ((surface (plist-get dashboard :surface))
(state (plist-get dashboard :state))
(theme (plist-get state :theme))
(report (when (tp-surface-live-p surface)
(tp-surface-unmount surface))))
(when (tp-signal-live-p theme)
(tp-signal-dispose theme))
report))
(defun tp-example-retained-dashboard-entry-handle (dashboard id)
"Resolve retained object HANDLE for dashboard ID in DASHBOARD.
Return nil when ID has no committed object."
(tp-object-resolve (plist-get dashboard :surface)
(list 'dashboard id)))
(defun tp-example-retained-dashboard-text (dashboard)
"Return DASHBOARD's plain text from its host buffer."
(with-current-buffer (plist-get dashboard :buffer)
(buffer-substring-no-properties (point-min) (point-max))))
(provide 'retained-dashboard)
;;; retained-dashboard.el ends here

56
examples/static-properties.el Normal file
View File

@ -0,0 +1,56 @@
;;; static-properties.el --- Public API static TP property examples -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Examples that use only the one-shot public TP APIs: `tp-propertize` and
;; `tp-apply`. They do not rely on layer stacks, retained runtimes, or
;; managed state.
;;; Code:
(require 'tp)
(defconst tp-example-static-properties-caption-buffer-width 28
"Fixed width used by static diagnostics in this example set.")
(defvar tp-example-static-properties-keymap
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") #'ignore)
map)
"Keymap stored literally on the static title string.")
(defun tp-example-static-properties-help (_window _object _position)
"Return help text for a static title.
WINDOW, OBJECT, and POSITION are supplied by Emacs help display."
"Static TP title")
(defun tp-example-static-properties-format-title (label)
"Return LABEL padded and styled as a static title.
LABEL is shown using native Emacs properties only.
The returned value is a propertized string (no surface, no anchor, no object)."
(let ((text (format (format "%%-%ds" tp-example-static-properties-caption-buffer-width)
label)))
(tp-propertize text
`(face ((:weight bold)
(:foreground "white" :background "#3c4656"))
keymap ,tp-example-static-properties-keymap
help-echo ,#'tp-example-static-properties-help
mouse-face nil))))
(defun tp-example-static-properties-mark-range (buffer start end &optional color)
"Apply a one-shot property run on BUFFER [START, END).
COLOR defaults to a light neutral background and preserves all existing
properties outside [START, END)."
(tp-apply buffer start end
`(face (:background ,(or color "#f0e6cc"))
help-echo "Static range marker")))
(provide 'static-properties)
;;; static-properties.el ends here

93
tests/tp-architecture-tests.el Normal file
View File

@ -0,0 +1,93 @@
;;; tp-architecture-tests.el --- TP 1.0 boundary tests -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Structural contracts for the single retained/reactive TP runtime.
;;; Code:
(require 'ert)
(require 'tp)
(defconst tp-architecture-tests--root
(file-name-directory
(directory-file-name
(file-name-directory (or load-file-name buffer-file-name))))
"Absolute path to the TP repository root.")
(ert-deftest tp-architecture-test-legacy-runtime-modules-are-absent ()
"The removed scan renderer and inline stack runtime are not shipped."
(dolist (file '("tp-render.el" "tp-stack.el"))
(should-not
(file-exists-p (expand-file-name file tp-architecture-tests--root))))
(should-not (featurep 'tp-render))
(should-not (featurep 'tp-stack)))
(ert-deftest tp-architecture-test-legacy-runtime-symbols-are-absent ()
"The public runtime exposes no scan registry or inline identity API."
(dolist (symbol '(tp-reactive-deps
tp-layer-watchers
tp-layer-computed
tp-layer-data
tp--layer-buffers))
(should-not (boundp symbol)))
(dolist (symbol '(tp-reactive-layer-buffers
tp-reactive-track-buffer
tp--map-layer-buffers
tp-push-layer
tp-put-layer
tp-hide-layer
tp-show-layer
tp-move-layer
tp-merge-layers))
(should-not (fboundp symbol))))
(ert-deftest tp-architecture-test-production-has-no-legacy-scan-path ()
"Production sources contain no scan registry or inline identity access."
(let ((forbidden
(regexp-opt '("(buffer-list)"
"tp-reactive-deps"
"tp--layer-buffers"
"tp--map-layer-buffers"
"'tp-name"
"'tp-layers"
"'tp-meta"))))
(dolist (file (directory-files tp-architecture-tests--root t
"\\`tp-.*\\.el\\'"))
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(should-not (re-search-forward forbidden nil t))))))
(ert-deftest tp-architecture-test-recipes-do-not-publish-runtime-metadata ()
"Named declaration recipes expand without inline runtime identity."
(unwind-protect
(progn
(define-tp tp-architecture-test-recipe ()
'(face bold help-echo "recipe"))
(let ((value (tp-set "text" 'tp-architecture-test-recipe)))
(dolist (property '(tp-name tp-layers tp-meta tp-hidden tp-text))
(should-not (plist-member (text-properties-at 0 value) property)))))
(tp-undefine-layer 'tp-architecture-test-recipe)))
(ert-deftest tp-architecture-test-stateless-facade-does-not-touch-runtime-counters ()
"One-shot public property APIs do not create retained/reactive work."
(with-temp-buffer
(insert "text")
(let ((counters (tp-reactive-counters))
(surfaces tp--buffer-surfaces))
(tp-set 1 5 '(face bold))
(should (equal (tp-reactive-counters) counters))
(should (eq tp--buffer-surfaces surfaces)))))
(ert-deftest tp-architecture-test-loading-tp-does-not-advise-theme-lifecycle ()
"Loading TP does not install global theme lifecycle advice."
(dolist (symbol '(tp--palette-after-enable-theme
tp--palette-after-disable-theme))
(should-not (fboundp symbol))))
(provide 'tp-architecture-tests)
;;; tp-architecture-tests.el ends here

82
tests/tp-binding-tests.el
View File

@ -207,6 +207,36 @@
(should-not (eq failed replacement))
(should (= (tp-binding-read replacement) 42))))))
(ert-deftest tp-binding-test-key-owns-data-and-preserves-opaque-identities ()
"A retained binding key copies data containers but not identity objects."
(tp-binding-test--isolated
(with-temp-buffer
(let* ((caller-string (copy-sequence "binding"))
(caller-vector (vector (copy-sequence "key")))
(record (tp--make-native-range (current-buffer) :buffer 1 1))
(calls 0)
(callback (lambda () (cl-incf calls)))
(table (make-hash-table :test #'equal))
(marker (copy-marker (point-min)))
(key (list 'test caller-string caller-vector record callback
table marker (current-buffer)))
(binding (tp-bind 'owner key (lambda () 1)))
(stored (tp-binding-key binding)))
(should-not (eq stored key))
(should-not (eq (nth 1 stored) caller-string))
(should-not (eq (nth 2 stored) caller-vector))
(should-not (eq (aref (nth 2 stored) 0) (aref caller-vector 0)))
(should (eq (nth 3 stored) record))
(should (eq (nth 4 stored) callback))
(should (eq (nth 5 stored) table))
(should (eq (nth 6 stored) marker))
(should (eq (nth 7 stored) (current-buffer)))
(should (= calls 0))
(aset caller-string 0 ?B)
(aset (aref caller-vector 0) 0 ?K)
(should (equal (nth 1 stored) "binding"))
(should (equal (nth 2 stored) ["key"]))))))
(ert-deftest tp-binding-test-cycle-error-reports-binding-path ()
"A binding dependency cycle reports the keys in cycle order."
(tp-binding-test--isolated
@ -230,6 +260,58 @@
(should (= (tp-binding-read first) 1))
(should (= (tp-binding-read second) 2)))))
(ert-deftest tp-binding-test-cycle-error-cannot-mutate-retained-keys ()
"Cycle diagnostics return data copies instead of retained binding keys."
(tp-binding-test--isolated
(let* ((switch (tp-signal-create nil))
(first-key
(list 'test (copy-sequence "first")
(vector (copy-sequence "path"))))
(second-key
(list 'test (copy-sequence "second")
(vector (copy-sequence "path"))))
first second)
(setq first
(tp-bind 'first-owner first-key
(lambda ()
(if (tp-signal-read switch)
(tp-binding-read second)
1))))
(setq second
(tp-bind 'second-owner second-key
(lambda () (1+ (tp-binding-read first)))))
(let* ((failure
(should-error (tp-signal-set switch t)
:type 'tp-binding-cycle))
(reported-first (car (cadr failure))))
(aset (nth 1 reported-first) 0 ?F)
(aset (aref (nth 2 reported-first) 0) 0 ?P)
(should (equal (nth 1 (tp-binding-key first)) "first"))
(should (equal (nth 2 (tp-binding-key first)) ["path"]))))))
(ert-deftest tp-binding-test-participant-key-is-owned-by-transaction ()
"Transaction participant keys cannot follow caller container mutation."
(tp-binding-test--isolated
(let* ((caller-string (copy-sequence "participant"))
(caller-vector (vector (copy-sequence "key")))
(key (list 'test caller-string caller-vector)))
(tp-with-transaction
(tp-transaction-participate key #'ignore #'ignore)
(let ((stored (tp--transaction-participant-key
(car tp--transaction-participants))))
(should-not (eq (nth 1 stored) caller-string))
(should-not (eq (nth 2 stored) caller-vector))
(should-not (eq (aref (nth 2 stored) 0)
(aref caller-vector 0)))
(aset caller-string 0 ?P)
(aset (aref caller-vector 0) 0 ?K)
(should (equal (nth 1 stored) "participant"))
(should (equal (nth 2 stored) ["key"]))
(should-error
(tp-transaction-participate
(list 'test "participant" ["key"]) #'ignore #'ignore)
:type 'tp-reactive-error))))))
(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge ()
"A dirty target rewires before cycle validation examines its old edges."
(tp-binding-test--isolated

43
tests/tp-core-tests.el
View File

@ -133,6 +133,34 @@
(setf (tp--request-public-return request) :native)
(should (eq (tp--result-public-value result) 'native-value))))
(ert-deftest tp-core-test-property-value-copy-has-explicit-identity-rules ()
"Property copies own data containers and preserve opaque identities."
(with-temp-buffer
(let* ((caller-string (copy-sequence "value"))
(caller-vector (vector (copy-sequence "nested")))
(record (tp--make-native-range (current-buffer) :buffer 1 1))
(calls 0)
(callback (lambda () (cl-incf calls)))
(table (make-hash-table :test #'equal))
(marker (copy-marker (point-min)))
(value (list caller-string caller-vector record callback table
marker (current-buffer)))
(copy (tp--copy-property-value value)))
(should-not (eq copy value))
(should-not (eq (nth 0 copy) caller-string))
(should-not (eq (nth 1 copy) caller-vector))
(should-not (eq (aref (nth 1 copy) 0) (aref caller-vector 0)))
(should (eq (nth 2 copy) record))
(should (eq (nth 3 copy) callback))
(should (eq (nth 4 copy) table))
(should (eq (nth 5 copy) marker))
(should (eq (nth 6 copy) (current-buffer)))
(should (= calls 0))
(aset caller-string 0 ?V)
(aset (aref caller-vector 0) 0 ?N)
(should (equal (nth 0 copy) "value"))
(should (equal (nth 1 copy) ["nested"])))))
;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map
(ert-deftest tp-core-test-intervals-buffer-relative-default ()
@ -172,20 +200,19 @@
(should (equal (tp-intervals-map #'list 3 9 nil t)
'((3 4 nil nil) (4 8 (face bold) nil) (8 9 nil nil))))))
(ert-deftest tp-core-test-intervals-map-splits-layer-stack ()
"tp-intervals-map hands the tp-layers stack to FUNCTION separately."
(ert-deftest tp-core-test-intervals-map-returns-direct-properties ()
"tp-intervals-map returns direct properties and a nil reserved slot."
(with-temp-buffer
(insert "hello")
(set-text-properties
1 6 '(face bold tp-layers ((face italic tp-name below))))
(set-text-properties 1 6 '(face bold help-echo "direct"))
(let ((res (tp-intervals-map #'list 1 6 nil t)))
(should (= (length res) 1))
(pcase-let ((`(,beg ,end ,top ,below) (car res)))
(pcase-let ((`(,beg ,end ,props ,reserved) (car res)))
(should (= beg 1))
(should (= end 6))
(should (eq (plist-get top 'face) 'bold))
(should-not (plist-member top 'tp-layers))
(should (equal below '((face italic tp-name below))))))))
(should (eq (plist-get props 'face) 'bold))
(should (equal (plist-get props 'help-echo) "direct"))
(should-not reserved)))))
(ert-deftest tp-core-test-intervals-map-drops-nil-results ()
"nil results from FUNCTION are removed from the returned list."

1067
tests/tp-doctest.el
View File

File diff suppressed because it is too large Load Diff

247
tests/tp-examples-tests.el Normal file
View File

@ -0,0 +1,247 @@
;;; tp-examples-tests.el --- Tests for public TP examples -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Exercises the new examples in `examples/` through public TP entry points.
;;; Code:
(require 'ert)
(require 'tp)
(require 'static-properties)
(require 'reactive-status)
(require 'retained-dashboard)
(require 'diagnostic-decoration)
(defmacro tp-examples-tests--with-temp-buffer (name &rest body)
"Run BODY in a temporary isolated buffer.
NAME is the buffer name to create."
(declare (indent 1) (debug t))
`(let ((buffer (generate-new-buffer ,name)))
(unwind-protect
(progn ,@body)
(when (buffer-live-p buffer)
(kill-buffer buffer)))))
(defun tp-examples-tests--buffer-substring (buffer)
"Return full buffer text from BUFFER as plain string."
(with-current-buffer buffer
(buffer-substring-no-properties (point-min) (point-max))))
(defun tp-examples-tests--label-property (state label property)
"Return PROPERTY at LABEL start in STATE buffer."
(let ((buffer (plist-get state :buffer)))
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
(when (search-forward label nil t)
(get-text-property (match-beginning 0) property))))))
(ert-deftest tp-examples-test-static-properties-direct-output-observable ()
(let ((styled (tp-example-static-properties-format-title "Release")))
(should (equal (substring-no-properties styled) (format "%-28s" "Release")))
(should (equal (get-text-property 0 'face styled)
'((:weight bold)
(:foreground "white" :background "#3c4656"))))
(should (equal (get-text-property 0 'keymap styled)
tp-example-static-properties-keymap))
(should (eq (get-text-property 0 'help-echo styled)
#'tp-example-static-properties-help))
(should (plist-member (text-properties-at 0 styled) 'mouse-face))
(should-not (get-text-property 0 'mouse-face styled)))
(tp-examples-tests--with-temp-buffer " *tp-static-range*"
(with-current-buffer buffer
(insert "hello world")
(should (equal (tp-example-static-properties-mark-range buffer 1 6 "#dff0") '(1 . 6)))
(should (equal (tp-at 1 'face buffer) '(:background "#dff0")))
(should (equal (tp-at 1 'help-echo buffer) "Static range marker")))))
(ert-deftest tp-examples-test-reactive-status-noop-and-sparse-dependency ()
(tp-examples-tests--with-temp-buffer " *tp-reactive-status*"
(let* ((state (tp-example-reactive-status-mount buffer))
(surface (plist-get state :surface)))
(unwind-protect
(progn
(should (equal (tp-example-reactive-status-color state) "ForestGreen"))
(should (equal (tp-at 1 'help-echo buffer) "status=ready"))
(tp-example-reactive-status-clear-reactive-counters)
(let ((before-revision (tp-surface-revision surface)))
(tp-example-reactive-status-poke state 10)
(should (= (tp-surface-revision surface) before-revision))
(should (= (plist-get (tp-reactive-counters) :invalidated) 0))
(should (= (plist-get (tp-reactive-counters) :recomputed) 0))
(tp-example-reactive-status-set state 'error)
(should (= (tp-surface-revision surface) (+ before-revision 1)))
(should (equal (tp-example-reactive-status-color state) "IndianRed"))
(should (equal (tp-at 1 'help-echo buffer) "status=error"))
(should (= (plist-get (tp-example-reactive-status-watch-report state) :new-revision)
(+ before-revision 1)))
(tp-example-reactive-status-clear-reactive-counters)
(tp-example-reactive-status-set state 'error)
(should (= (tp-surface-revision surface) (+ before-revision 1)))
(should (= (plist-get (tp-reactive-counters) :invalidated) 0))
(should (= (plist-get (tp-reactive-counters) :recomputed) 0))
(tp-example-reactive-status-poke state 11)
(should (= (tp-surface-revision surface) (+ before-revision 1)))
(should (= (plist-get (tp-reactive-counters) :invalidated) 0))
(should (= (plist-get (tp-reactive-counters) :recomputed) 0))))
(tp-example-reactive-status-dispose state)
(should-not (tp-surface-live-p surface))
(should-not (tp-surface-live-p (plist-get state :surface)))
(should-not (tp-signal-live-p (plist-get state :status)))
(should-not (tp-signal-live-p (plist-get state :noise)))))))
(ert-deftest tp-examples-test-reactive-content-dependencies-and-batch ()
(tp-examples-tests--with-temp-buffer " *tp-reactive-content*"
(let* ((state (tp-example-reactive-content-mount buffer))
(surface (plist-get state :surface)))
(unwind-protect
(progn
(should (equal (tp-example-reactive-content-text state)
"primary:ready"))
(let ((revision (tp-surface-revision surface)))
(tp-reactive-reset-counters)
(tp-example-reactive-content-set-fallback state "standby")
(should (= (tp-surface-revision surface) revision))
(should (= (plist-get (tp-reactive-counters) :invalidated) 0)))
(let ((revision (tp-surface-revision surface)))
(tp-example-reactive-content-batch-primary
state (mapcar (lambda (number) (format "step-%d" number))
(number-sequence 1 100)))
(should (= (tp-surface-revision surface) (1+ revision)))
(should (equal (tp-example-reactive-content-text state)
"primary:step-100")))
(tp-example-reactive-content-set-enabled state nil)
(should (equal (tp-example-reactive-content-text state)
"fallback:standby"))
(let ((revision (tp-surface-revision surface)))
(tp-example-reactive-content-set-primary state "ignored")
(should (= (tp-surface-revision surface) revision)))
(tp-example-reactive-content-set-fallback state "offline")
(should (equal (tp-example-reactive-content-text state)
"fallback:offline")))
(tp-example-reactive-content-dispose state)
(should-not (tp-surface-live-p surface))
(dolist (key '(:enabled :primary :fallback))
(should-not (tp-signal-live-p (plist-get state key))))))))
(ert-deftest tp-examples-test-retained-dashboard-identity-theme-and-failure-recovery ()
(tp-examples-tests--with-temp-buffer " *tp-retained-dashboard*"
(let* ((dashboard (tp-example-retained-dashboard-mount buffer))
(surface (plist-get dashboard :surface))
(alpha-first-handle (tp-example-retained-dashboard-entry-handle dashboard 'alpha))
(gamma-handle (tp-example-retained-dashboard-entry-handle dashboard 'gamma))
(report-before (tp-example-retained-dashboard-report dashboard)))
(unwind-protect
(progn
(should (eq alpha-first-handle (tp-example-retained-dashboard-entry-handle dashboard 'alpha)))
(should (eq gamma-handle (tp-example-retained-dashboard-entry-handle dashboard 'gamma)))
(should (consp (tp-examples-tests--label-property dashboard " Alpha " 'keymap)))
(should (equal (tp-examples-tests--label-property dashboard " Alpha " 'button)
"entry:alpha"))
(let* ((theme-report (tp-example-retained-dashboard-set-theme dashboard 'dark))
(theme-revision (plist-get theme-report :new-revision)))
(should (= theme-revision (+ (plist-get report-before :new-revision) 1)))
(should (equal (tp-examples-tests--label-property dashboard " Alpha " 'face)
'(:weight bold :foreground "#83a598"))))
(let* ((revision-before-update (tp-surface-revision surface))
(update-report
(tp-example-retained-dashboard-update
dashboard
'((:id gamma :label "Gamma")
(:id alpha :label "Alpha" :active t)
(:id delta :label "Delta")))))
(should (eq gamma-handle
(tp-example-retained-dashboard-entry-handle
dashboard 'gamma)))
(should (eq alpha-first-handle
(tp-example-retained-dashboard-entry-handle
dashboard 'alpha)))
(should-not (tp-example-retained-dashboard-entry-handle
dashboard 'beta))
(should (string-match-p
"Gamma" (tp-examples-tests--buffer-substring buffer)))
(should (string-match-p
"Delta" (tp-examples-tests--buffer-substring buffer)))
(should (> (plist-get update-report :new-revision)
revision-before-update)))
(let ((committed-text
(tp-examples-tests--buffer-substring buffer))
(committed-revision (tp-surface-revision surface)))
(should-error
(tp-example-retained-dashboard-update
dashboard
'((:id forced :label "Boom" :force-failure t))))
(should (equal (tp-examples-tests--buffer-substring buffer)
committed-text))
(should (= (tp-surface-revision surface) committed-revision))
(should (eq (tp-example-retained-dashboard-entry-handle
dashboard 'alpha)
alpha-first-handle))))
(let ((report (tp-example-retained-dashboard-remove dashboard)))
(should (plist-get report :unmounted))
(should-not (tp-surface-live-p surface))
(should-not
(tp-signal-live-p (plist-get (plist-get dashboard :state)
:theme))))))))
(ert-deftest tp-examples-test-diagnostic-decoration-conflict-rebase-cleanup ()
(tp-examples-tests--with-temp-buffer " *tp-diagnostic-decoration*"
(let* ((state (tp-example-diagnostic-decoration-mount buffer))
(surface (plist-get state :surface)))
(unwind-protect
(progn
(let ((range-before (tp-example-diagnostic-decoration-range state)))
(should (equal range-before '(2 . 6)))
(let ((warn-report (tp-example-diagnostic-decoration-set-mode state 'warn)))
(should (> (plist-get warn-report :new-revision) 0))
(should (equal (tp-at (car range-before) 'face buffer)
'(:foreground "DarkOrange"))))
(tp-example-diagnostic-decoration-insert-host-text state 1 "[")
(should (equal (tp-example-diagnostic-decoration-range state)
(cons (+ (car range-before) 1) (+ (cdr range-before) 1))))
(tp-example-diagnostic-decoration-delete-host-range state 1 2)
(should (equal (tp-example-diagnostic-decoration-range state) range-before))
(tp-example-diagnostic-decoration-repaint-range
state '(face (:foreground "Blue") help-echo "host override"))
(let ((revision (tp-surface-revision surface)))
(should-error
(tp-example-diagnostic-decoration-set-mode state 'busy)
:type 'tp-property-conflict)
(should (= (tp-surface-revision surface) revision))
(should (eq (tp-signal-peek (plist-get state :mode-signal))
'warn))
(should (equal (tp-at (car range-before) 'face buffer)
'(:foreground "Blue"))))
(tp-example-diagnostic-decoration-rebase state)
(tp-example-diagnostic-decoration-set-mode state 'busy)
(should (equal (tp-at (car range-before) 'face buffer)
'(:foreground "Purple")))
(tp-example-diagnostic-decoration-repaint-range
state '(face (:foreground "Blue") help-echo "host override"))))
(let ((unmount (tp-example-diagnostic-decoration-unmount state)))
(should (plist-get unmount :unmounted))
(should (consp (plist-get unmount :property-conflicts)))
(should (buffer-live-p buffer))
(should-not (tp-range-anchor-live-p (plist-get state :anchor)))
(should-not (tp-signal-live-p (plist-get state :mode-signal)))
(should (equal (tp-at 2 'face buffer)
'(:foreground "Blue"))))))))
;;; tp-examples-tests.el ends here

971
tests/tp-layer-tests.el
View File

@ -1,719 +1,296 @@
;;; tp-layer-tests.el --- ERT regression tests for tp-layer.el -*- lexical-binding: t -*-
;;; tp-layer-tests.el --- Declaration recipe tests -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Regression tests for confirmed bugs fixed in the layer-definition
;; module (tp-layer.el). Each section is tagged with the canonical
;; bug id it guards against.
;; Contract tests for static and parameterized named declaration recipes.
;;; Code:
(require 'ert)
(require 'tp)
(defmacro tp-layer-tests--with-clean (&rest body)
"Run BODY with a clean layer/reactive state, resetting afterwards."
(declare (indent 0))
(defmacro tp-layer-test--isolated (&rest body)
"Run BODY with isolated declaration recipe registries."
(declare (indent 0) (debug t))
`(unwind-protect
(progn (tp-layer-reset) ,@body)
(tp-layer-reset)))
;; Dynamic variables used by reactive tests ($foo refers to variable foo).
(defvar tp-layer-test-b15-color nil)
(defvar tp-layer-test-b23-color nil)
(defvar tp-layer-test-b26-color nil)
(ert-deftest tp-layer-test-static-recipe-expands-to-direct-properties ()
"A static recipe expands without runtime metadata."
(tp-layer-test--isolated
(define-tp tp-layer-test-static ()
'(face bold help-echo "static"))
(should (equal (tp-layer-props 'tp-layer-test-static)
'(face bold help-echo "static")))
(let ((text (tp-set "demo" 'tp-layer-test-static)))
(should (eq (get-text-property 0 'face text) 'bold))
(should (equal (get-text-property 0 'help-echo text) "static")))))
;;; B20: documented parameterized define-tps format must yield props
(ert-deftest tp-layer-test-param-group-docstring-format ()
"The define-tps docstring Format 2 example returns real props."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-status (color)
`((face (:foreground ,color)))
'(face (:weight bold)))
(should (tp-group-parameterized-p 'tp-layer-test-status))
(should (equal (tp-group-props-with-arg 'tp-layer-test-status "red")
'((face (:foreground "red"))
(face (:weight bold)))))))
(ert-deftest tp-layer-test-param-group-resolves-in-tp-set-path ()
"tp--resolve-props builds a layered structure from a parameterized group."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-status (color)
`((face (:foreground ,color)))
'(face (:weight bold)))
(let ((props (tp--resolve-props '(tp-layer-test-status "red"))))
(should (equal (plist-get props 'face) '(:foreground "red")))
(should (equal (plist-get props 'tp-layers)
'((face (:weight bold))))))))
(ert-deftest tp-layer-test-param-group-layer-reference-specs ()
"Parameterized groups still accept layer-name and (LAYER ARG) specs."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-bold () '(face bold))
(define-tp tp-layer-test-fg (c) `(face (:foreground ,c)))
(define-tps tp-layer-test-mixed (color)
'tp-layer-test-bold
`(tp-layer-test-fg ,color))
(should (equal (tp-group-props-with-arg 'tp-layer-test-mixed "blue")
'((face bold)
(face (:foreground "blue")))))))
(ert-deftest tp-layer-test-param-group-named-element ()
"Parameterized groups accept named (\"NAME\" :props PLIST) elements."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-named (color)
`(("fg" :props (face (:foreground ,color)))))
(should (equal (tp-group-props-with-arg 'tp-layer-test-named "red")
'((face (:foreground "red")))))))
;;; B21: cyclic layer references signal a clear error, not stack overflow
(ert-deftest tp-layer-test-cycle-self-reference ()
"A layer referencing itself signals an error naming the cycle."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-cyc '(tp-layer-test-cyc t face bold))
(let ((err (should-error (tp-layer-props 'tp-layer-test-cyc))))
(should (string-match-p "cyclic layer reference"
(error-message-string err)))
(should (string-match-p "tp-layer-test-cyc -> tp-layer-test-cyc"
(error-message-string err))))))
(ert-deftest tp-layer-test-cycle-mutual-reference ()
"Two layers referencing each other signal an error naming both."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-ca '(tp-layer-test-cb t face bold))
(tp--set-layer-props 'tp-layer-test-cb '(tp-layer-test-ca t face italic))
(let ((err (should-error (tp-layer-props 'tp-layer-test-ca))))
(should (string-match-p
"tp-layer-test-ca -> tp-layer-test-cb -> tp-layer-test-ca"
(error-message-string err))))))
(ert-deftest tp-layer-test-cycle-diamond-is-not-a-cycle ()
"Re-using the same layer along different branches is not a cycle."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-base () '(face bold))
(tp--set-layer-props 'tp-layer-test-left '(tp-layer-test-base t help-echo "l"))
(tp--set-layer-props 'tp-layer-test-right '(tp-layer-test-base t mouse-face highlight))
(tp--set-layer-props 'tp-layer-test-top
'(tp-layer-test-left t tp-layer-test-right t))
(let ((props (tp-layer-props 'tp-layer-test-top)))
(should (equal (plist-get props 'help-echo) "l"))
(should (eq (plist-get props 'mouse-face) 'highlight)))))
;;; B22: extra body forms in define-tp simple format are an error
(ert-deftest tp-layer-test-extra-body-forms-error ()
"define-tp with two simple body forms errors instead of dropping one."
(ert-deftest tp-layer-test-parameterized-recipe-requires-exact-arity ()
"Parameterized recipes bind every declared argument exactly once."
(tp-layer-test--isolated
(define-tp tp-layer-test-parameterized (foreground weight)
`(face (:foreground ,foreground :weight ,weight)))
(should
(equal (tp-layer-props-with-args
'tp-layer-test-parameterized '("red" bold))
'(face (:foreground "red" :weight bold))))
(should-error
(eval '(define-tp tp-layer-test-extra ()
'(face bold)
'(display "x"))
t)))
(tp-layer-props-with-args 'tp-layer-test-parameterized '("red")))
(should-error
(tp-layer-props-with-args
'tp-layer-test-parameterized '("red" bold extra)))))
(ert-deftest tp-layer-test-single-body-form-still-works ()
"define-tp with exactly one simple body form still defines the layer."
(tp-layer-tests--with-clean
(eval '(define-tp tp-layer-test-single () '(face bold)) t)
(should (equal (tp-layer-props 'tp-layer-test-single) '(face bold)))))
(ert-deftest tp-layer-test-whole-string-call-supports-wrapped-arguments ()
"A multi-argument recipe accepts a wrapped argument list plus extras."
(tp-layer-test--isolated
(define-tp tp-layer-test-card (foreground background)
`(face (:foreground ,foreground :background ,background)))
(let ((text (tp-set "card" 'tp-layer-test-card
'("white" "navy") 'help-echo "Card")))
(should
(equal (get-text-property 0 'face text)
'(:foreground "white" :background "navy")))
(should (equal (get-text-property 0 'help-echo text) "Card")))))
(ert-deftest tp-layer-test-keyword-format-unaffected-by-arity-check ()
"The reactive keyword format still accepts multiple keyword pairs."
(tp-layer-tests--with-clean
(eval '(define-tp tp-layer-test-kw ()
:props '(face bold)
:transform #'upcase)
t)
(should (equal (plist-get (tp-layer-props 'tp-layer-test-kw) 'face) 'bold))
(should (eq (cdr (assoc 'tp-layer-test-kw tp-layer-transforms)) #'upcase))))
;;; B23: $-symbols in parameterized bodies resolve instead of leaking
(ert-deftest tp-layer-test-param-layer-resolves-reactive-symbols ()
"$-syms in a parameterized body resolve to current variable values."
(tp-layer-tests--with-clean
(setq tp-layer-test-b23-color "green")
(define-tp tp-layer-test-preact (x)
`(face (:foreground $tp-layer-test-b23-color) help-echo ,x))
(should (equal (tp-layer-props-with-arg 'tp-layer-test-preact "hi")
'(face (:foreground "green") help-echo "hi")))
;; And through the tp-set resolution pipeline as well.
(should (equal (tp--resolve-props '(tp-layer-test-preact "hi"))
'(face (:foreground "green") help-echo "hi")))))
(ert-deftest tp-layer-test-param-layer-reactive-syms-not-registered ()
"Resolved $-syms in parameterized bodies create no reactive deps."
(tp-layer-tests--with-clean
(setq tp-layer-test-b23-color "green")
(define-tp tp-layer-test-preact (x)
`(face (:foreground $tp-layer-test-b23-color) help-echo ,x))
(tp-layer-props-with-arg 'tp-layer-test-preact "hi")
(should-not (tp--layer-has-reactive-deps-p 'tp-layer-test-preact))))
;;; B24: accessors return copies, not internal storage
(ert-deftest tp-layer-test-props-mutation-does-not-corrupt-static-layer ()
"Mutating the plist returned for a define-tp layer leaves it intact."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-st () '(face bold))
(let ((props (tp-layer-props 'tp-layer-test-st)))
(setcar (cdr props) 'MUTATED))
(should (equal (tp-layer-props 'tp-layer-test-st) '(face bold)))))
(ert-deftest tp-layer-test-props-mutation-does-not-corrupt-old-format ()
"Mutating the plist returned for an old-format layer leaves it intact."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-old '(face bold))
(let ((props (tp-layer-props 'tp-layer-test-old)))
(setcar (cdr props) 'MUTATED))
(should (equal (tp-layer-props 'tp-layer-test-old) '(face bold)))))
(ert-deftest tp-layer-test-props-deep-mutation-does-not-corrupt ()
"Mutating nested structure of the returned plist leaves storage intact."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-deep '(face (:weight bold)))
(let ((props (tp-layer-props 'tp-layer-test-deep)))
(setcar (plist-get props 'face) 'MUTATED))
(should (equal (tp-layer-props 'tp-layer-test-deep)
'(face (:weight bold))))))
(ert-deftest tp-layer-test-group-props-mutation-does-not-corrupt ()
"Mutating plists returned by tp-group-props leaves layers intact."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-gm () '(face bold))
(define-tps tp-layer-test-gmg () 'tp-layer-test-gm)
(let ((props-list (tp-group-props 'tp-layer-test-gmg)))
(setcar (cdar props-list) 'MUTATED))
(should (equal (tp-group-props 'tp-layer-test-gmg) '((face bold))))))
;;; B25: :transform in define-tps group elements is registered
(ert-deftest tp-layer-test-group-element-transform-registered ()
"A format-4 group element's :transform lands in tp-layer-transforms."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-tg ()
'("a" :props (face (:foreground $tp-layer-test-b26-color))
:data ((tp-layer-test-b26-color . "red"))
:transform upcase))
(should (eq (cdr (assoc 'tp-layer-test-tg-a tp-layer-transforms))
'upcase))))
(ert-deftest tp-layer-test-group-element-transform-removed-on-redefine ()
"Redefining a group element without :transform unregisters the old one."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-tg ()
'("a" :props (face bold) :transform upcase))
(should (assoc 'tp-layer-test-tg-a tp-layer-transforms))
(define-tps tp-layer-test-tg ()
'("a" . (face bold)))
(should-not (assoc 'tp-layer-test-tg-a tp-layer-transforms))))
;;; B26: group redefinition / undefinition cleans up generated layers
(ert-deftest tp-layer-test-group-redefine-removes-orphans ()
"Shrinking a group on redefinition undefines the dropped layers."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-rg ()
'(face bold) '(face italic) '(face underline))
(should (assoc 'tp-layer-test-rg-1 tp-layer-alist))
(should (assoc 'tp-layer-test-rg-2 tp-layer-alist))
(define-tps tp-layer-test-rg ()
'(face bold))
(should (assoc 'tp-layer-test-rg-0 tp-layer-alist))
(should-not (assoc 'tp-layer-test-rg-1 tp-layer-alist))
(should-not (assoc 'tp-layer-test-rg-2 tp-layer-alist))
(should (equal (tp-group-props 'tp-layer-test-rg) '((face bold))))))
(ert-deftest tp-layer-test-undefine-group-removes-generated-layers ()
"tp-undefine-group also undefines layers generated by the group."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-ug ()
'(face bold)
'("named" . (face italic)))
(tp-undefine-group 'tp-layer-test-ug)
(should-not (assoc 'tp-layer-test-ug tp-layer-groups))
(should-not (assoc 'tp-layer-test-ug-0 tp-layer-alist))
(should-not (assoc 'tp-layer-test-ug-named tp-layer-alist))))
(ert-deftest tp-layer-test-undefine-group-keeps-referenced-layers ()
"Layers merely referenced by a group survive its undefinition."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-keep () '(face bold))
(define-tps tp-layer-test-ug2 ()
'tp-layer-test-keep
'(face italic))
(tp-undefine-group 'tp-layer-test-ug2)
(should (assoc 'tp-layer-test-keep tp-layer-alist))
(should-not (assoc 'tp-layer-test-ug2-0 tp-layer-alist))))
(ert-deftest tp-layer-test-undefine-group-cleans-reactive-deps ()
"Undefining a group unregisters reactive deps of generated layers."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-ug3 ()
'("r" :props (face (:foreground $tp-layer-test-b26-color))
:data ((tp-layer-test-b26-color . "red"))))
(should (tp--layer-has-reactive-deps-p 'tp-layer-test-ug3-r))
(tp-undefine-group 'tp-layer-test-ug3)
(should-not (tp--layer-has-reactive-deps-p 'tp-layer-test-ug3-r))
(should-not (assoc 'tp-layer-test-ug3-r tp-layer-alist))))
(ert-deftest tp-layer-test-group-redefine-to-parameterized-cleans-up ()
"Redefining a plain group as parameterized undefines its old layers."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-pg ()
'(face bold))
(should (assoc 'tp-layer-test-pg-0 tp-layer-alist))
(define-tps tp-layer-test-pg (color)
`((face (:foreground ,color))))
(should-not (assoc 'tp-layer-test-pg-0 tp-layer-alist))
(should (tp-group-parameterized-p 'tp-layer-test-pg))))
;;; B27: unknown keywords in group elements are an error, not a misparse
(ert-deftest tp-layer-test-group-element-unknown-keyword-errors ()
"An unknown keyword in a format-4 group element signals an error."
(tp-layer-tests--with-clean
(let ((err (should-error
(eval '(define-tps tp-layer-test-bad ()
'("a" :props (face bold)
:bogus (:props (face italic))))
t))))
(should (string-match-p "Unknown keyword"
(error-message-string err))))))
;;; B15: anonymous reactive layers are interned, not minted per call
(ert-deftest tp-layer-test-anonymous-layer-interned ()
"Equal reactive plists reuse a single anonymous layer entry."
(tp-layer-tests--with-clean
(setq tp-layer-test-b15-color "red")
(let* ((s1 (tp-set (copy-sequence "hi")
'(face (:foreground $tp-layer-test-b15-color))))
(s2 (tp-set (copy-sequence "hi")
'(face (:foreground $tp-layer-test-b15-color))))
(n1 (get-text-property 0 'tp-name s1))
(n2 (get-text-property 0 'tp-name s2)))
(should n1)
(should (eq n1 n2))
;; Exactly one anonymous registry entry for the shared spec.
(should (= (length tp-layer-alist) 1)))))
(ert-deftest tp-layer-test-anonymous-layer-distinct-specs-distinct ()
"Different reactive plists still get different anonymous layers."
(tp-layer-tests--with-clean
(setq tp-layer-test-b15-color "red")
(let* ((s1 (tp-set (copy-sequence "hi")
'(face (:foreground $tp-layer-test-b15-color))))
(s2 (tp-set (copy-sequence "hi")
'(face (:background $tp-layer-test-b15-color))))
(n1 (get-text-property 0 'tp-name s1))
(n2 (get-text-property 0 'tp-name s2)))
(should n1)
(should n2)
(should-not (eq n1 n2)))))
(ert-deftest tp-layer-test-anonymous-layer-reuse-keeps-reactivity ()
"Reactive updates still reach buffer text using a reused anonymous layer."
(tp-layer-tests--with-clean
(with-temp-buffer
(setq tp-layer-test-b15-color "red")
(insert "Hello World")
(tp-set 1 3 '(face (:foreground $tp-layer-test-b15-color)))
(tp-set 7 9 '(face (:foreground $tp-layer-test-b15-color)))
(should (eq (get-text-property 1 'tp-name)
(get-text-property 7 'tp-name)))
(setq tp-layer-test-b15-color "blue")
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"blue"))
(should (equal (plist-get (get-text-property 7 'face) :foreground)
"blue")))))
(ert-deftest tp-layer-test-anonymous-registry-cleared-on-reset ()
"tp-layer-reset clears the anonymous-layer intern registry."
(tp-layer-tests--with-clean
(setq tp-layer-test-b15-color "red")
(tp-set (copy-sequence "hi")
'(face (:foreground $tp-layer-test-b15-color)))
(should tp--anonymous-layer-registry)
(tp-layer-reset)
(should-not tp--anonymous-layer-registry)))
;;; 0.3.0 A4: multi-argument parameterized layers
(ert-deftest tp-layer-test-multi-arg-define-and-props-with-args ()
"define-tp accepts multi-symbol arglists; props-with-args expands them."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(should (tp-layer-parameterized-p 'tp-layer-test-fgbg))
(should (equal (tp-layer-arglist 'tp-layer-test-fgbg) '(fg bg)))
(should (equal (tp-layer-props-with-args 'tp-layer-test-fgbg
'("red" "blue"))
'(face (:foreground "red" :background "blue"))))
(should (equal (tp-layer-props-with-args 'tp-layer-test-fgbg
'("red" "blue") t)
'(face (:foreground "red" :background "blue")
tp-name tp-layer-test-fgbg)))))
(ert-deftest tp-layer-test-props-with-arg-is-thin-wrapper ()
"tp-layer-props-with-arg keeps its single-argument contract."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fg1 (c) `(face (:foreground ,c)))
(should (equal (tp-layer-props-with-arg 'tp-layer-test-fg1 "red")
'(face (:foreground "red"))))
(should (equal (tp-layer-props-with-arg 'tp-layer-test-fg1 "red")
(tp-layer-props-with-args 'tp-layer-test-fg1 '("red"))))))
(ert-deftest tp-layer-test-props-with-args-non-parameterized-nil ()
"props-with-args and tp-layer-arglist return nil for other layers."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-np () '(face bold))
(should-not (tp-layer-props-with-args 'tp-layer-test-np '(1)))
(should-not (tp-layer-arglist 'tp-layer-test-np))
(should-not (tp-layer-props-with-args 'tp-layer-test-missing '(1)))))
(ert-deftest tp-layer-test-multi-arg-tp-set-flat-string-form ()
"The flat (tp-set STRING \\='LAYER ARG1 ARG2) form binds all params."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(let ((s (tp-set "hello" 'tp-layer-test-fgbg "red" "blue")))
(should (equal (get-text-property 0 'face s)
'(:foreground "red" :background "blue"))))))
(ert-deftest tp-layer-test-multi-arg-tp-set-flat-with-extra-props ()
"Extra props after multi args survive, with no stray nil pair."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(let ((s (tp-set "hello" 'tp-layer-test-fgbg "red" "blue"
'help-echo "tip")))
(should (equal (plist-get (get-text-property 0 'face s) :foreground)
"red"))
(should (equal (get-text-property 0 'help-echo s) "tip"))
;; The odd-length flat spec is padded with nil by key merging;
;; resolution must strip it instead of setting a nil property.
(should (equal (text-properties-at 0 s)
'(face (:foreground "red" :background "blue")
help-echo "tip"))))))
(ert-deftest tp-layer-test-multi-arg-tp-set-region-list-form ()
"The region form (tp-set START END \\='(LAYER ARG1 ARG2)) works (1-based)."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(with-temp-buffer
(insert "hello")
(tp-set 1 4 '(tp-layer-test-fgbg "red" "blue"))
(should (equal (get-text-property 1 'face)
'(:foreground "red" :background "blue")))
(should-not (get-text-property 4 'face)))))
(ert-deftest tp-layer-test-multi-arg-tp-set-wrapped-args-plist-form ()
"The plist spec (LAYER (ARG1 ARG2) EXTRA...) passes args as one list."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
;; Layer at the head of the plist.
(let ((s (copy-sequence "hello")))
(tp-set 0 5 '(tp-layer-test-fgbg ("red" "blue") help-echo "tip") s)
(should (equal (get-text-property 0 'face s)
'(:foreground "red" :background "blue")))
(should (equal (get-text-property 0 'help-echo s) "tip")))
;; Layer at a non-head plist position.
(let ((s (copy-sequence "hello")))
(tp-set 0 5 '(help-echo "tip" tp-layer-test-fgbg ("red" "blue")) s)
(should (equal (plist-get (get-text-property 0 'face s) :background)
"blue"))
(should (equal (get-text-property 0 'help-echo s) "tip")))))
(ert-deftest tp-layer-test-multi-arg-normalize-layer-spec ()
"Normalized parameterized specs retain args in managed metadata."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(let* ((entry (tp--normalize-layer-spec
'(tp-layer-test-fgbg "red" "blue")))
(meta (plist-get entry 'tp-meta)))
(should (equal (plist-get entry 'face)
'(:foreground "red" :background "blue")))
(should (eq (plist-get entry 'tp-name) 'tp-layer-test-fgbg))
(should (equal (plist-get meta :args) '("red" "blue")))
(should (equal (plist-get meta :arglist) '(fg bg)))
(should (integerp (plist-get meta :definition-version))))))
(ert-deftest tp-layer-test-multi-arg-tp-put-layer ()
"tp-put-layer accepts multi-argument parameterized layer specs."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(let ((s (copy-sequence "hi")))
(tp-put-layer s '(tp-layer-test-fgbg "red" "blue") 0)
(should (equal (get-text-property 0 'face s)
'(:foreground "red" :background "blue")))
(should (eq (get-text-property 0 'tp-name s) 'tp-layer-test-fgbg)))))
(ert-deftest tp-layer-test-multi-arg-cycle-detection ()
"Cycle detection still fires through the multi-argument path."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-mcyc (a b)
`(tp-layer-test-mcyc (,a ,b)))
(let ((err (should-error
(tp-layer-props-with-args 'tp-layer-test-mcyc '(1 2)))))
(should (string-match-p "cyclic layer reference"
(error-message-string err))))))
(ert-deftest tp-layer-test-multi-arg-props-are-copies ()
"props-with-args returns fresh copies; mutation cannot corrupt storage."
(tp-layer-tests--with-clean
;; The (:weight bold) subform is a shared constant in the
;; backquoted body; without copy-on-return, mutating the returned
;; plist would corrupt every later expansion.
(define-tp tp-layer-test-mcopy (a b)
`(face (:weight bold) help-echo ,(format "%s-%s" a b)))
(let ((props (tp-layer-props-with-args 'tp-layer-test-mcopy '("x" "y"))))
(setcar (plist-get props 'face) 'MUTATED))
(should (equal (tp-layer-props-with-args 'tp-layer-test-mcopy '("x" "y"))
'(face (:weight bold) help-echo "x-y")))))
(ert-deftest tp-layer-test-multi-arg-group ()
"define-tps accepts multi-symbol arglists usable through tp-set specs."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-mgrp (fg w)
`((face (:foreground ,fg)))
`((face (:weight ,w))))
(should (tp-group-parameterized-p 'tp-layer-test-mgrp))
(should (equal (tp--group-arglist 'tp-layer-test-mgrp) '(fg w)))
(should (equal (tp--group-props-with-args 'tp-layer-test-mgrp
'("red" bold))
'((face (:foreground "red")) (face (:weight bold)))))
;; Flat (GROUP ARG1 ARG2) spec through the tp-set pipeline.
(let ((props (tp--resolve-props '(tp-layer-test-mgrp "red" bold))))
(should (equal (plist-get props 'face) '(:foreground "red")))
(should (equal (plist-get props 'tp-layers)
'((face (:weight bold))))))
;; Single-argument groups keep working through the wrapper.
(define-tps tp-layer-test-sgrp (color)
`((face (:foreground ,color))))
(should (equal (tp-group-props-with-arg 'tp-layer-test-sgrp "red")
'((face (:foreground "red")))))))
;;; 0.3.0 A5: tp-describe-layer and its data collector
(ert-deftest tp-layer-test-describe-data-unified ()
"Describe data for a define-tp layer reports the unified format."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-du () '(face bold))
(let ((data (tp--describe-layer-data 'tp-layer-test-du)))
(should (eq (plist-get data :name) 'tp-layer-test-du))
(should (eq (plist-get data :format) 'unified))
(should (equal (plist-get data :body) '(quote (face bold))))
(should (equal (plist-get data :props)
'(face bold tp-name tp-layer-test-du)))
(should-not (plist-get data :arglist))
(should-not (plist-get data :reactive-deps))
(should-not (plist-get data :transform))
(should-not (plist-get data :group)))))
(ert-deftest tp-layer-test-describe-data-flat ()
"Describe data for an old-format layer reports the flat format."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-df '(face italic))
(let ((data (tp--describe-layer-data 'tp-layer-test-df)))
(should (eq (plist-get data :format) 'flat))
(should (equal (plist-get data :body) '(face italic)))
(should (equal (plist-get data :props)
'(face italic tp-name tp-layer-test-df))))))
(ert-deftest tp-layer-test-describe-data-parameterized ()
"Describe data for a parameterized layer reports arglist and a note."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-dp (a b)
`(face (:foreground ,a :background ,b)))
(let ((data (tp--describe-layer-data 'tp-layer-test-dp)))
(should (eq (plist-get data :format) 'parameterized))
(should (equal (plist-get data :arglist) '(a b)))
;; Expanded props need arguments, so a placeholder note is used.
(should (stringp (plist-get data :props)))
(should (string-match-p "tp-layer-props-with-args"
(plist-get data :props))))))
(ert-deftest tp-layer-test-describe-data-reactive ()
"Describe data for a reactive layer reports format and dependencies."
(tp-layer-tests--with-clean
(setq tp-layer-test-b15-color "red")
(define-tp tp-layer-test-dr ()
'(face (:foreground $tp-layer-test-b15-color)))
(let ((data (tp--describe-layer-data 'tp-layer-test-dr)))
(should (eq (plist-get data :format) 'reactive))
(should (equal (plist-get data :reactive-deps)
'(tp-layer-test-b15-color))))))
(ert-deftest tp-layer-test-describe-data-group-and-transform ()
"Describe data reports the owning group and transform presence."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-dg ()
'("a" :props (face bold) :transform upcase))
(let ((data (tp--describe-layer-data 'tp-layer-test-dg-a)))
(should (eq (plist-get data :group) 'tp-layer-test-dg))
(should (plist-get data :transform)))))
(ert-deftest tp-layer-test-describe-data-unknown-layer-nil ()
"Describe data returns nil for names not in tp-layer-alist."
(tp-layer-tests--with-clean
(should-not (tp--describe-layer-data 'tp-layer-test-nonexistent))))
(ert-deftest tp-layer-test-describe-layer-command ()
"tp-describe-layer is a command and renders a help buffer."
(should (commandp 'tp-describe-layer))
(tp-layer-tests--with-clean
(define-tp tp-layer-test-dc () '(face bold))
(save-window-excursion
(tp-describe-layer 'tp-layer-test-dc)
(with-current-buffer (help-buffer)
(should (string-match-p "tp-layer-test-dc is a tp layer"
(buffer-string)))
(should (string-match-p "Storage format: unified"
(buffer-string)))))
(should-error (tp-describe-layer 'tp-layer-test-missing)
:type 'user-error)))
;;; ARG-1: wrong-arity parameterized-layer calls signal clear errors
(defmacro tp-layer-tests--with-colors (&rest body)
"Run BODY with the two-parameter test layer tp-lt-colors defined."
(declare (indent 0))
`(tp-layer-tests--with-clean
(define-tp tp-lt-colors (fg bg)
`(face (:foreground ,fg :background ,bg)))
,@body))
(ert-deftest tp-layer-test-props-with-args-missing-arg-errors ()
"tp-layer-props-with-args signals on fewer args than parameters.
Since Emacs 27 `cl-progv' silently binds missing parameters to nil,
so the old docstring's promised unbound-variable error could never
fire; the arity is now checked explicitly (ARG-1)."
(tp-layer-tests--with-colors
(let ((err (should-error
(tp-layer-props-with-args 'tp-lt-colors '("red")))))
;; Parens are literal in Emacs regexps.
(should (string-match-p "takes 2 argument(s), got 1" (cadr err))))
;; Correct arity still works.
(should (equal (tp-layer-props-with-args 'tp-lt-colors
'("red" "blue"))
'(face (:foreground "red" :background "blue"))))
;; Extra values are still ignored, per the documented contract.
(should (equal (tp-layer-props-with-args 'tp-lt-colors
'("red" "blue" "green"))
'(face (:foreground "red" :background "blue"))))))
(ert-deftest tp-layer-test-tp-set-flat-missing-arg-errors ()
"The flat tp-set form with too few layer args signals, not nil-binds.
Before ARG-1, (tp-set \"s\" \\='(layer \"red\")) on a two-parameter
layer silently produced (:foreground \"red\" :background nil)."
(tp-layer-tests--with-colors
(should-error (tp-set "s" '(tp-lt-colors "red")))))
(ert-deftest tp-layer-test-tp-set-flat-excess-arg-errors ()
"Flat-form excess positional args signal instead of corrupting props.
Before ARG-1, the excess string fell into extra-props and was applied
as a text-property KEY with value nil."
(tp-layer-tests--with-colors
(let ((err (should-error
(tp-set "gg" '(tp-lt-colors "red" "blue" "green")))))
(should (string-match-p "excess argument" (cadr err))))
;; Correct-arity flat form is unchanged.
(should (equal (text-properties-at
0 (tp-set "ok" '(tp-lt-colors "red" "blue")))
'(face (:foreground "red" :background "blue"))))
;; Legitimate extra PROPS after the args still work.
(should (equal (plist-get
(text-properties-at
0 (tp-set "ok" '(tp-lt-colors "red" "blue"
help-echo "tip")))
'help-echo)
"tip"))
;; The wrapped-args form with extra props is untouched as well.
(should (equal (plist-get
(text-properties-at
0 (tp-set "ok" '(tp-lt-colors ("red" "blue")
help-echo "tip")))
'help-echo)
"tip"))))
(ert-deftest tp-layer-test-stack-path-wrong-arity-clear-error ()
"The stack path signals a clear arity error, not \"Odd length ...\".
Before ARG-1, (tp-push-layer s \\='(layer \"red\")) fell through
tp--normalize-layer-spec's named-inline branch, producing the odd
plist (\"red\" tp-name layer) and the cryptic error \"Odd length
text property list\"."
(tp-layer-tests--with-colors
(let ((err (should-error
(tp-push-layer (copy-sequence "st")
'(tp-lt-colors "red")))))
(should (string-match-p "expects 2 args, got 1" (cadr err))))
(let ((err (should-error
(tp--normalize-layer-spec '(tp-lt-colors "red")))))
(should (string-match-p "expects 2 args, got 1" (cadr err))))
;; Correct arity through the stack path keeps the rendered facade
;; while authoritative metadata lives in stack storage.
(let ((s (copy-sequence "st")))
(tp-push-layer s '(tp-lt-colors "red" "blue"))
(should (equal (get-text-property 0 'face s)
'(:foreground "red" :background "blue")))
(should (eq (get-text-property 0 'tp-name s) 'tp-lt-colors))
(let* ((entry (car (get-text-property 0 'tp-layers s)))
(meta (plist-get entry 'tp-meta)))
(should (equal (plist-get meta :args) '("red" "blue")))))))
;;; API-SYM-01: public tp-group-props-with-args mirrors the layer pair
(ert-deftest tp-layer-test-group-props-with-args-public ()
"The public plural group accessor matches the private path."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-pgrp (fg w)
`((face (:foreground ,fg)))
`((face (:weight ,w))))
(should (equal (tp-group-props-with-args 'tp-layer-test-pgrp
'("red" bold))
'((face (:foreground "red")) (face (:weight bold)))))
(should (equal (tp-group-props-with-args 'tp-layer-test-pgrp
'("red" bold))
(tp--group-props-with-args 'tp-layer-test-pgrp
'("red" bold))))
(should (equal (tp-group-props-with-args 'tp-layer-test-pgrp
'("red" bold) t)
(tp--group-props-with-args 'tp-layer-test-pgrp
'("red" bold) t)))
;; Non-parameterized or undefined groups return nil, like the
;; layer counterpart.
(should-not (tp-group-props-with-args 'tp-layer-test-nope '("x")))))
;;; API-NAME-02: prefix-conforming tp-define-* aliases
(ert-deftest tp-layer-test-define-layer-alias ()
"tp-define-layer is a working macro alias of define-tp."
(tp-layer-tests--with-clean
(tp-define-layer tp-layer-test-alias-l ()
'(face bold))
(should (equal (tp-layer-props 'tp-layer-test-alias-l) '(face bold)))
;; Parameterized definitions work through the alias too.
(tp-define-layer tp-layer-test-alias-p (color)
(ert-deftest tp-layer-test-nested-recipes-compose-direct-properties ()
"Recipe keys expand recursively and use native merge semantics."
(tp-layer-test--isolated
(define-tp tp-layer-test-color (color)
`(face (:foreground ,color)))
(should (equal (tp-layer-props-with-arg 'tp-layer-test-alias-p "red")
'(face (:foreground "red"))))))
(define-tp tp-layer-test-button (color)
`(tp-layer-test-color ,color
face (:weight bold)
mouse-face highlight))
(should
(equal (tp-layer-props-with-arg 'tp-layer-test-button "red")
'(face (:foreground "red" :weight bold)
mouse-face highlight)))))
(ert-deftest tp-layer-test-define-group-alias ()
"tp-define-group is a working macro alias of define-tps."
(tp-layer-tests--with-clean
(tp-define-layer tp-layer-test-alias-m ()
'(face italic))
(tp-define-group tp-layer-test-alias-g ()
'tp-layer-test-alias-m
'(face bold))
(should (assoc 'tp-layer-test-alias-g tp-layer-groups))
(should (equal (tp-group-props 'tp-layer-test-alias-g)
'((face italic) (face bold))))))
(ert-deftest tp-layer-test-cycle-errors-name-the-path ()
"Cyclic recipe references fail instead of partially expanding."
(tp-layer-test--isolated
(define-tp tp-layer-test-a () '(tp-layer-test-b t))
(let ((error
(should-error
(eval '(define-tp tp-layer-test-b ()
'(tp-layer-test-a t))))))
(let ((message (error-message-string error)))
(should (string-match-p "tp-layer-test-a" message))
(should (string-match-p "tp-layer-test-b" message))
(should (string-match-p " -> " message))))))
(ert-deftest tp-layer-test-group-merges-ordered-contributions ()
"A group expands into ordered direct property contributions."
(tp-layer-test--isolated
(define-tp tp-layer-test-base () '(face (:weight bold)))
(define-tps tp-layer-test-group ()
'tp-layer-test-base
'(face (:foreground "cyan"))
'(help-echo "group"))
(let ((text (tp-set "group" 'tp-layer-test-group)))
(should
(equal (get-text-property 0 'face text)
'(:weight bold :foreground "cyan")))
(should (equal (get-text-property 0 'help-echo text) "group")))))
(ert-deftest tp-layer-test-parameterized-group-evaluates-at-application ()
"Parameterized groups remain recipes and are not frozen at definition."
(tp-layer-test--isolated
(define-tps tp-layer-test-theme (foreground background)
`(face (:foreground ,foreground))
`(face (:background ,background)))
(should
(equal (tp-group-props-with-args
'tp-layer-test-theme '("white" "black"))
'((face (:foreground "white"))
(face (:background "black")))))))
(ert-deftest tp-layer-test-static-named-group-element-compiles-style ()
"A named static group element also becomes a named direct style."
(tp-layer-test--isolated
(define-tps tp-layer-test-parts ()
'("label" . (face italic mouse-face highlight)))
(should
(equal (tp-style-declarations 'tp-layer-test-parts-label)
'(text/face italic text/mouse-face highlight)))))
(ert-deftest tp-layer-test-group-redefinition-removes-generated-recipes ()
"Redefining a group removes generated recipes no longer present."
(tp-layer-test--isolated
(define-tps tp-layer-test-parts ()
'("old" . (face bold)))
(should (tp-layer-props 'tp-layer-test-parts-old))
(define-tps tp-layer-test-parts ()
'("new" . (face italic)))
(should-not (tp-layer-props 'tp-layer-test-parts-old))
(should (tp-layer-props 'tp-layer-test-parts-new))))
(ert-deftest tp-layer-test-failed-group-definition-leaves-no-registry-state ()
"A failed first group definition must not publish partial entries."
(tp-layer-test--isolated
(should-error
(eval '(define-tps tp-layer-test-broken ()
'("label" . (face)))))
(should-not (assq 'tp-layer-test-broken tp-layer-groups))
(should-not (tp-layer-props 'tp-layer-test-broken-label))
(should-not (tp-style-declarations 'tp-layer-test-broken-label))))
(ert-deftest tp-layer-test-failed-group-redefinition-preserves-old-state ()
"A failed group redefinition must leave every old entry usable."
(tp-layer-test--isolated
(define-tps tp-layer-test-atomic ()
'("old" . (face bold help-echo "old")))
(let ((old-group (tp-group-props 'tp-layer-test-atomic))
(old-layer (tp-layer-props 'tp-layer-test-atomic-old))
(old-style (tp-style-declarations 'tp-layer-test-atomic-old)))
(should-error
(eval '(define-tps tp-layer-test-atomic ()
'("new" . (face)))))
(should (equal (tp-group-props 'tp-layer-test-atomic) old-group))
(should (equal (tp-layer-props 'tp-layer-test-atomic-old) old-layer))
(should (equal (tp-style-declarations 'tp-layer-test-atomic-old)
old-style))
(should-not (tp-layer-props 'tp-layer-test-atomic-new))
(should-not (tp-style-declarations 'tp-layer-test-atomic-new)))))
(ert-deftest tp-layer-test-failed-second-generated-install-rolls-back ()
"A failed generated recipe install must preserve the complete old group."
(tp-layer-test--isolated
(define-tps tp-layer-test-atomic-install ()
'("old-a" . (face bold help-echo "old-a"))
'("old-b" . (face italic help-echo "old-b")))
(let ((old-group (tp-group-props 'tp-layer-test-atomic-install))
(old-a-layer (tp-layer-props 'tp-layer-test-atomic-install-old-a))
(old-b-layer (tp-layer-props 'tp-layer-test-atomic-install-old-b))
(old-a-style
(tp-style-declarations 'tp-layer-test-atomic-install-old-a))
(old-b-style
(tp-style-declarations 'tp-layer-test-atomic-install-old-b))
(old-generated
(cdr (assq 'tp-layer-test-atomic-install
tp--group-generated-layers)))
(install-count 0)
(original-define
(symbol-function 'tp--candidate-define-layer-recipe)))
(cl-letf (((symbol-function 'tp--candidate-define-layer-recipe)
(lambda (name arglist body layers groups styles compiled)
(if (and (memq name '(tp-layer-test-atomic-install-new-a
tp-layer-test-atomic-install-new-b))
(= (cl-incf install-count) 2))
(error "synthetic second generated install failure")
(funcall original-define
name arglist body
layers groups styles compiled)))))
(should-error
(eval '(define-tps tp-layer-test-atomic-install ()
'("new-a" . (face underline help-echo "new-a"))
'("new-b" . (face shadow help-echo "new-b"))))))
(should (equal (tp-group-props 'tp-layer-test-atomic-install)
old-group))
(should (equal (tp-layer-props 'tp-layer-test-atomic-install-old-a)
old-a-layer))
(should (equal (tp-layer-props 'tp-layer-test-atomic-install-old-b)
old-b-layer))
(should
(equal (tp-style-declarations 'tp-layer-test-atomic-install-old-a)
old-a-style))
(should
(equal (tp-style-declarations 'tp-layer-test-atomic-install-old-b)
old-b-style))
(should (equal (cdr (assq 'tp-layer-test-atomic-install
tp--group-generated-layers))
old-generated))
(should-not (tp-layer-props 'tp-layer-test-atomic-install-new-a))
(should-not (tp-layer-props 'tp-layer-test-atomic-install-new-b))
(should-not
(tp-style-declarations 'tp-layer-test-atomic-install-new-a))
(should-not
(tp-style-declarations 'tp-layer-test-atomic-install-new-b)))))
(ert-deftest tp-layer-test-definition-results-are-defensive-copies ()
"Mutating one expanded result cannot corrupt the stored recipe."
(tp-layer-test--isolated
(define-tp tp-layer-test-copy ()
'(face (:foreground "red")))
(let ((first (tp-layer-props 'tp-layer-test-copy)))
(setcar (cdr (plist-get first 'face)) "blue")
(should
(equal (tp-layer-props 'tp-layer-test-copy)
'(face (:foreground "red")))))))
(ert-deftest tp-layer-test-recipe-owns-mutable-values-and-keeps-identities ()
"Recipe storage and expansion isolate data without cloning opaque values."
(tp-layer-test--isolated
(let* ((caller-string (copy-sequence "tooltip"))
(caller-vector (vector (copy-sequence "display")))
(record (tp--make-native-range 'owner :test 1 2))
(calls 0)
(callback (lambda (&rest _args) (cl-incf calls))))
(eval
`(define-tp tp-layer-test-deep-copy ()
(list 'help-echo ',caller-string
'display ',caller-vector
'tp-test-record ',record
'action ',callback)))
(let* ((first (tp-layer-props 'tp-layer-test-deep-copy))
(first-string (plist-get first 'help-echo))
(first-vector (plist-get first 'display)))
(should-not (eq first-string caller-string))
(should-not (eq first-vector caller-vector))
(should-not (eq (aref first-vector 0) (aref caller-vector 0)))
(should (eq (plist-get first 'tp-test-record) record))
(should (eq (plist-get first 'action) callback))
(should (= calls 0))
(aset caller-string 0 ?T)
(aset (aref caller-vector 0) 0 ?D)
(should (equal first-string "tooltip"))
(should (equal first-vector ["display"]))
(aset first-string 1 ?O)
(aset (aref first-vector 0) 1 ?I)
(should
(equal (tp-layer-props 'tp-layer-test-deep-copy)
(list 'help-echo "tooltip"
'display ["display"]
'tp-test-record record
'action callback)))))))
(ert-deftest tp-layer-test-legacy-dollar-syntax-is-rejected ()
"Legacy dollar-variable syntax cannot recreate a hidden watcher runtime."
(tp-layer-test--isolated
(should-error
(eval '(define-tp tp-layer-test-reactive ()
'(face (:foreground $tp-layer-test-color))))
:type 'tp-invalid-layer-definition)))
(ert-deftest tp-layer-test-computed-source-uses-the-shared-policy-core ()
"Explicit computed sources evaluate through ordinary property projection."
(tp-layer-test--isolated
(let ((color "red") (calls 0))
(define-tp tp-layer-test-computed ()
`(face ,(tp-computed
(lambda ()
(cl-incf calls)
(list :foreground color)))))
(let ((text (tp-set "computed" 'tp-layer-test-computed)))
(should (equal (get-text-property 0 'face text)
'(:foreground "red")))
(should (= calls 1))))))
(ert-deftest tp-layer-test-literal-function-property-is-not-called ()
"Literal function values remain callbacks when a recipe is applied."
(tp-layer-test--isolated
(let* ((calls 0)
(callback (lambda (&rest _args) (cl-incf calls))))
(eval `(define-tp tp-layer-test-help ()
(list 'help-echo ,callback)))
(let ((text (tp-set "help" 'tp-layer-test-help)))
(should (eq (get-text-property 0 'help-echo text) callback))
(should (= calls 0))))))
(provide 'tp-layer-tests)
;;; tp-layer-tests.el ends here

303
tests/tp-managed-tests.el
View File

@ -1,303 +0,0 @@
;;; tp-managed-tests.el --- ERT tests for managed lifecycle APIs -*- lexical-binding: t -*-
;;; Commentary:
;; Stage 4 RED tests for additive managed lifecycle behavior. These
;; tests intentionally drive public entry points and should fail until
;; managed metadata, diagnostics, transactions, and theme generation are
;; implemented.
;;; Code:
(require 'ert)
(require 'tp)
(defmacro tp-managed-tests--with-clean (&rest body)
"Run BODY in a temp buffer with clean layer/reactive state."
(declare (indent 0))
`(unwind-protect
(with-temp-buffer
(tp-layer-reset)
(tp-reactive-reset)
(setq tp-reactive-observer-errors nil)
,@body)
(tp-layer-reset)
(tp-reactive-reset)
(setq tp-reactive-observer-errors nil)))
(defun tp-managed-tests--require-api (fn)
"Assert FN exists and return its function binding."
(should (fboundp fn))
(symbol-function fn))
(defun tp-managed-tests--raw-intervals ()
"Return raw text and property intervals for the current buffer."
(list (buffer-substring-no-properties (point-min) (point-max))
(tp-intervals (point-min) (point-max) nil t)))
(defun tp-managed-tests--managed-buffer-diagnostics ()
"Call `tp-managed-buffer-diagnostics' after asserting it exists."
(tp-managed-tests--require-api 'tp-managed-buffer-diagnostics)
(tp-managed-buffer-diagnostics (current-buffer)))
(defun tp-managed-tests--managed-layer-diagnostics (layer)
"Call `tp-managed-layer-diagnostics' for LAYER after asserting it exists."
(tp-managed-tests--require-api 'tp-managed-layer-diagnostics)
(tp-managed-layer-diagnostics layer))
(defun tp-managed-tests--managed-diagnostics ()
"Call `tp-managed-diagnostics' after asserting it exists."
(tp-managed-tests--require-api 'tp-managed-diagnostics)
(tp-managed-diagnostics))
(ert-deftest tp-managed-test-metadata-is-not-public-stack-or-rendered ()
"Managed tp-meta is stripped from public stack query and rendered props."
(tp-managed-tests--with-clean
(insert "abcd")
(tp-put-layer 1 4
'(stage4-visible
face (:foreground "red")
help-echo "visible"
tp-meta (:schema 1
:entry-id stage4-entry-a
:origin inline
:args ("red" 7)))
0)
(let* ((stack (tp-layer-stack-at 1))
(top (cdr (assq 'stage4-visible stack)))
(rendered (text-properties-at 1)))
(should (assq 'stage4-visible stack))
(should-not (plist-member top 'tp-meta))
(should-not (plist-member rendered 'tp-meta))
(should (equal (plist-get rendered 'face) '(:foreground "red")))
(should (equal (plist-get rendered 'help-echo) "visible")))))
(ert-deftest tp-managed-test-parameterized-mounted-layer-retains-args ()
"Parameterized mounted layer diagnostics retain each entry's args."
(tp-managed-tests--with-clean
(insert "abcdefgh")
(define-tp stage4-color (fg bg)
`(face (:foreground ,fg :background ,bg)))
(tp-put-layer 1 4 '(stage4-color "red" "blue") 0)
(tp-put-layer 5 8 '(stage4-color "green" "black") 0)
(let* ((diag (tp-managed-tests--managed-layer-diagnostics 'stage4-color))
(entries (plist-get diag :entries))
(args (mapcar (lambda (entry) (plist-get entry :args)) entries)))
(should (member '("red" "blue") args))
(should (member '("green" "black") args)))))
(ert-deftest tp-managed-test-parameterized-mounted-layer-refreshes-after-redefine ()
"Parameterized mounted entries re-render from stored args after redefine."
(tp-managed-tests--with-clean
(insert "abcdefgh")
(define-tp stage4-redef (fg bg)
`(face (:foreground ,fg :background ,bg)))
(tp-put-layer 1 4 '(stage4-redef "red" "blue") 0)
(tp-put-layer 5 8 '(stage4-redef "green" "black") 0)
(define-tp stage4-redef (fg bg)
`(face (:foreground ,fg :background ,bg :weight bold)))
(should (equal (get-text-property 1 'face)
'(:foreground "red" :background "blue" :weight bold)))
(should (equal (get-text-property 5 'face)
'(:foreground "green" :background "black" :weight bold)))))
(ert-deftest tp-managed-test-attach-finds-inserted-managed-string ()
"Attach registers layers copied in through a propertized string."
(tp-managed-tests--with-clean
(define-tp stage4-attached () '(face (:box t)))
(let ((payload (copy-sequence "xy")))
(tp-put-layer payload 'stage4-attached 0)
(insert payload))
(tp-managed-tests--require-api 'tp-attach-managed-layers)
(should (equal (tp-attach-managed-layers 1 3 (current-buffer))
'(stage4-attached)))
(should (equal (tp-reactive-layer-buffers 'stage4-attached)
(list (current-buffer))))))
(ert-deftest tp-managed-test-detach-removes-managed-storage-and-keeps-rendered ()
"Detach with KEEP-RENDERED removes managed storage but preserves visible props."
(tp-managed-tests--with-clean
(insert "abcd")
(define-tp stage4-detach () '(face italic help-echo "kept"))
(tp-put-layer 1 4 'stage4-detach 0)
(tp-managed-tests--require-api 'tp-detach-managed-layers)
(should (equal (tp-detach-managed-layers 1 4 (current-buffer) t)
'(stage4-detach)))
(should-not (plist-member (text-properties-at 1) 'tp-layers))
(should-not (plist-member (text-properties-at 1) 'tp-meta))
(should-not (plist-member (text-properties-at 1) 'tp-name))
(should (eq (get-text-property 1 'face) 'italic))
(should (equal (get-text-property 1 'help-echo) "kept"))
(should-not (tp-reactive-layer-buffers 'stage4-detach))))
(ert-deftest tp-managed-test-buffer-diagnostics-are-read-only ()
"Managed buffer diagnostics do not mutate text, props, point, or modified state."
(tp-managed-tests--with-clean
(insert "abcd")
(define-tp stage4-diag () '(face bold))
(tp-put-layer 1 4 'stage4-diag 0)
(goto-char 3)
(set-buffer-modified-p nil)
(let ((before-state (tp-managed-tests--raw-intervals))
(before-point (point))
(before-modified (buffer-modified-p))
(before-undo buffer-undo-list))
(let ((diag (tp-managed-tests--managed-buffer-diagnostics)))
(should (plist-member diag :layers))
(should (member 'stage4-diag (plist-get diag :layers))))
(should (equal (tp-managed-tests--raw-intervals) before-state))
(should (= (point) before-point))
(should (eq (buffer-modified-p) before-modified))
(should (eq buffer-undo-list before-undo)))))
(ert-deftest tp-managed-test-layer-transaction-rolls-back-on-body-error ()
"tp-layer-transaction restores raw properties when the body errors."
(tp-managed-tests--with-clean
(insert "abcdef")
(define-tp stage4-base () '(face bold help-echo "base"))
(define-tp stage4-temp () '(face italic help-echo "temp"))
(tp-put-layer 1 6 'stage4-base 0)
(let ((before (tp-managed-tests--raw-intervals)))
(tp-managed-tests--require-api 'tp-layer-transaction)
(let ((err (should-error
(tp-layer-transaction
1 6 (current-buffer)
(lambda ()
(tp-put-layer 1 3 'stage4-temp 0)
(error "stage4 boom"))))))
(should (eq (car err) 'tp-layer-transaction-error)))
(should (equal (tp-managed-tests--raw-intervals) before)))))
(ert-deftest tp-managed-test-buffer-transaction-rolls-back-length-changes ()
"Buffer rollback tracks insertions and deletions inside the live range."
(dolist (mutation '(insert delete))
(tp-managed-tests--with-clean
(insert (propertize "abcdef" 'face 'bold))
(let ((before (buffer-substring (point-min) (point-max))))
(should-error
(tp-layer-transaction
2 5 (current-buffer)
(lambda ()
(pcase mutation
('insert
(goto-char 3)
(insert (propertize "XYZ" 'help-echo "temporary")))
('delete
(delete-region 3 4)))
(error "length-changing rollback"))))
(should (equal-including-properties
(buffer-substring (point-min) (point-max))
before))))))
(ert-deftest tp-managed-test-layer-transaction-success-keeps-body-result ()
"Successful transactions expose the body's result and changed ranges."
(tp-managed-tests--with-clean
(insert "abcd")
(define-tp stage4-success () '(face bold))
(let ((result
(tp-layer-transaction
1 4 (current-buffer)
(lambda ()
(tp-push-layer 1 4 'stage4-success)
:body-result))))
(should (eq (plist-get result :status) 'ok))
(should (eq (plist-get result :ok) t))
(should (eq (plist-get result :result) :body-result))
(should (plist-get result :changed-ranges)))))
(ert-deftest tp-managed-test-layer-transaction-noerror-returns-structured-failure ()
"NOERROR transaction failures return operation data and rollback status."
(tp-managed-tests--with-clean
(insert "abcdef")
(define-tp stage4-base2 () '(face bold))
(define-tp stage4-temp2 () '(face italic))
(tp-put-layer 1 6 'stage4-base2 0)
(let ((before (tp-managed-tests--raw-intervals)))
(tp-managed-tests--require-api 'tp-layer-transaction)
(let ((result (tp-layer-transaction
1 6 (current-buffer)
(lambda ()
(tp-put-layer 2 5 'stage4-temp2 0)
(signal 'error '("stage4 noerror")))
t)))
(should (eq (plist-get result :status) 'error))
(should (plist-get result :operation-id))
(should (plist-member result :stage))
(should (equal (plist-get result :range) '(1 . 6)))
(should (eq (plist-get result :rollback-applied) t))
(should (plist-get result :original-condition)))
(should (equal (tp-managed-tests--raw-intervals) before)))))
(ert-deftest tp-managed-test-string-transaction-restores-every-property-run ()
"String rollback restores characters and every distinct property run."
(tp-managed-tests--with-clean
(let ((text (copy-sequence "abcdef")))
(put-text-property 0 2 'face 'bold text)
(put-text-property 2 4 'face 'italic text)
(put-text-property 4 6 'help-echo "tail" text)
(let ((before (copy-sequence text)))
(should-error
(tp-layer-transaction
0 6 text
(lambda ()
(set-text-properties 0 6 '(face underline) text)
(signal 'error '("rollback string")))))
(should (equal-including-properties text before))))))
(ert-deftest tp-managed-test-fixed-seed-stack-state-machine ()
"Fixed seeds preserve public stack order across varied operations."
(dolist (seed '(1 7 42 747555))
(tp-managed-tests--with-clean
(insert "x")
(dolist (name '(stage4-sm-a stage4-sm-b stage4-sm-c))
(eval `(define-tp ,name () '(face bold))))
(let ((state seed)
(names '(stage4-sm-a stage4-sm-b stage4-sm-c))
model)
(dotimes (_ 40)
(setq state (mod (+ (* state 1103515245) 12345) 2147483648))
(pcase (% state 4)
(0
(let ((name (nth (% (/ state 4) 3) names)))
(unless (memq name model)
(tp-push-layer 1 2 name)
(push name model))))
(1
(when model
(tp-pop-layer 1 2)
(setq model (cdr model))))
(2
(when (cdr model)
(tp-move-layer 1 2 0 -1)
(setq model (append (cdr model) (list (car model))))))
(3
(when model
(tp-hide-layer 1 2 (car model))
(tp-show-layer 1 2 (car model)))))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) model)))))))
(ert-deftest tp-managed-test-theme-generation-diagnostics-increments-on-theme-hooks ()
"Theme lifecycle diagnostics record generation and hook source."
(tp-managed-tests--with-clean
(insert "abcd")
(define-tp stage4-theme () '(face (:foreground "red")))
(tp-put-layer 1 4 'stage4-theme 0)
(let* ((before (tp-managed-tests--managed-diagnostics))
(before-theme (plist-get before :theme))
(before-generation (plist-get before-theme :generation)))
(should (integerp before-generation))
(enable-theme 'user)
(let* ((after-enable (tp-managed-tests--managed-diagnostics))
(theme (plist-get after-enable :theme)))
(should (> (plist-get theme :generation) before-generation))
(should (eq (plist-get theme :last-hook-source) 'enable-theme))
(should (member (plist-get theme :refresh-mode)
'(:dependency-targeted :conservative)))
(should (plist-get theme :refreshed-ranges)))
(disable-theme 'user)
(let* ((after-disable (tp-managed-tests--managed-diagnostics))
(theme (plist-get after-disable :theme)))
(should (eq (plist-get theme :last-hook-source) 'disable-theme))))))
(provide 'tp-managed-tests)
;;; tp-managed-tests.el ends here

1062
tests/tp-render-tests.el
View File

File diff suppressed because it is too large Load Diff

76
tests/tp-search-tests.el
View File

@ -364,7 +364,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(should (null (get-text-property 0 'face str)))
(should (eq (get-text-property 0 'marker str) t))))
;;; Guard: nil return still means "no replacement" (used by tp-render)
;;; Guard: nil return still means "no replacement".
(ert-deftest tp-search-test-search-map-nil-return-no-replacement ()
"A callback returning nil leaves text and properties untouched."
@ -616,80 +616,6 @@ value changes when a non-nil predicate is given."
(should (= (tp-forward-do #'upcase 'lvl 2 s) 1))
(should (equal (substring-no-properties s) "abc DEF"))))
;;; REG-1: pattern-apply paths must register buffers in the reactive registry
(defvar tp-search-reg1-color nil)
(defvar tp-search-reg1b-color nil)
(ert-deftest tp-search-test-regexp-add-registers-reactive-buffer ()
"tp-regexp-add in a second buffer keeps reactive updates flowing there.
The deep-merge apply path stamps `tp-name' but never registered the
buffer, so once the layer was known from a `tp-set' elsewhere the
regexp-applied buffer went permanently stale (REG-1)."
(setq tp-search-reg1-color "red")
(unwind-protect
(progn
(tp-layer-reset)
(define-tp tp-search-reg1-layer ()
:props '(face (:foreground $tp-search-reg1-color)))
(let ((a (generate-new-buffer " *tp-sreg1-a*"))
(b (generate-new-buffer " *tp-sreg1-b*")))
(unwind-protect
(progn
(with-current-buffer a (insert "foo bar"))
(with-current-buffer b (insert "foo bar"))
(tp-set 1 4 'tp-search-reg1-layer a) ; registers A
(tp-regexp-add "foo" 'tp-search-reg1-layer b)
(let ((bufs (tp-reactive-layer-buffers
'tp-search-reg1-layer)))
(should (memq a bufs))
(should (memq b bufs)))
(setq tp-search-reg1-color "blue")
(should (equal (with-current-buffer a
(get-text-property 1 'face))
'(:foreground "blue")))
(should (equal (with-current-buffer b
(get-text-property 1 'face))
'(:foreground "blue"))))
(kill-buffer a)
(kill-buffer b))))
(tp-layer-reset)
(setq tp-search-reg1-color nil)))
(ert-deftest tp-search-test-match-reset-registers-reactive-buffer ()
"tp-match-reset in a second buffer keeps reactive updates flowing there.
The reset-apply path stamps `tp-name' via `set-text-properties' but
never registered the buffer (REG-1)."
(setq tp-search-reg1b-color "red")
(unwind-protect
(progn
(tp-layer-reset)
(define-tp tp-search-reg1b-layer ()
:props '(face (:foreground $tp-search-reg1b-color)))
(let ((a (generate-new-buffer " *tp-sreg1b-a*"))
(b (generate-new-buffer " *tp-sreg1b-b*")))
(unwind-protect
(progn
(with-current-buffer a (insert "foo bar"))
(with-current-buffer b (insert "foo bar"))
(tp-set 1 4 'tp-search-reg1b-layer a)
(tp-match-reset "foo" 'tp-search-reg1b-layer b)
(let ((bufs (tp-reactive-layer-buffers
'tp-search-reg1b-layer)))
(should (memq a bufs))
(should (memq b bufs)))
(setq tp-search-reg1b-color "blue")
(should (equal (with-current-buffer a
(get-text-property 1 'face))
'(:foreground "blue")))
(should (equal (with-current-buffer b
(get-text-property 1 'face))
'(:foreground "blue"))))
(kill-buffer a)
(kill-buffer b))))
(tp-layer-reset)
(setq tp-search-reg1b-color nil)))
;;; SRC-1: reversed START/END bounds are swapped on both object paths
(ert-deftest tp-search-test-reversed-bounds-string-swaps ()

1304
tests/tp-stack-tests.el
View File

File diff suppressed because it is too large Load Diff

661
tests/tp-style-tests.el
View File

@ -1,10 +1,12 @@
;;; tp-style-tests.el --- Tests for TP style cascade -*- lexical-binding: t; -*-
;;; tp-style-tests.el --- Tests for TP property policies -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Contract tests for the TP 1.0 schema-driven cascade kernel.
;; Contract tests for CSS-independent native property policies, direct
;; declarations, and explicit computed values.
;;; Code:
@ -13,76 +15,124 @@
(require 'tp-layer)
(defmacro tp-style-test--isolated (&rest body)
"Run BODY with empty TP style registries."
"Run BODY with isolated TP property and named-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)
`(let ((tp--property-policies (make-hash-table :test #'eq))
(tp--property-policy-order nil)
(tp--named-styles (make-hash-table :test #'eq)))
(tp--register-default-text-properties)
,@body))
(defun tp-style-test--color-schema (&optional inherits)
"Register and return the demo color schema using INHERITS."
(tp-define-property
(defun tp-style-test--color-policy ()
"Register and return a direct demo color policy."
(tp-define-property-policy
'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."
(ert-deftest tp-style-test-policy-registration-is-atomic ()
"Invalid replacement leaves the previous valid policy installed."
(tp-style-test--isolated
(let ((schema (tp-style-test--color-schema t)))
(should (eq schema (tp-property-schema 'demo/color)))
(let ((policy (tp-style-test--color-policy)))
(should (eq policy (tp-property-policy 'demo/color)))
(should-error
(tp-define-property 'demo/color :normalizer 42)
:type 'tp-invalid-property-schema)
(should (eq schema (tp-property-schema 'demo/color)))
(tp-define-property-policy 'demo/color :normalizer 42)
:type 'tp-invalid-property-policy)
(should (eq policy (tp-property-policy 'demo/color)))
(should-error
(tp-define-property 'color :initial "black")
:type 'tp-invalid-property-schema))))
(tp-define-property-policy 'color)
:type 'tp-invalid-property-policy))))
(ert-deftest tp-style-test-shorthand-expands-before-cascade-once ()
"A shorthand expands once into registered canonical longhands."
(ert-deftest tp-style-test-policy-rejects-css-schema-options ()
"TP property policies reject CSS inheritance and shorthand fields."
(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))))))
(dolist (options '((:initial "black")
(:inherits t)
(:shorthand identity)))
(should-error
(apply #'tp-define-property-policy 'demo/color options)
:type 'tp-invalid-property-policy))))
(ert-deftest tp-style-test-direct-declarations-require-registered-properties ()
"Direct declarations cannot silently introduce an unknown vocabulary."
(tp-style-test--isolated
(tp-style-test--color-policy)
(should
(equal (tp-merge-declarations
'(demo/color "red")
'(demo/color nil))
'(demo/color nil)))
(should-error
(tp-merge-declarations '(demo/unknown 1))
:type 'tp-invalid-declaration)))
(ert-deftest tp-style-test-text-declarations-copy-mutable-values ()
"Text declarations do not retain caller-owned strings or vectors."
(tp-style-test--isolated
(let* ((caller-string (copy-sequence "label"))
(caller-vector (vector (copy-sequence "display")))
(declarations
(tp-text-declarations
(list 'help-echo caller-string 'display caller-vector)))
(copied-string (plist-get declarations 'text/help-echo))
(copied-vector (plist-get declarations 'text/display)))
(should-not (eq copied-string caller-string))
(should-not (eq copied-vector caller-vector))
(should-not (eq (aref copied-vector 0) (aref caller-vector 0)))
(aset caller-string 0 ?L)
(aset (aref caller-vector 0) 0 ?D)
(should (equal copied-string "label"))
(should (equal copied-vector ["display"]))
(aset copied-string 1 ?A)
(aset (aref copied-vector 0) 1 ?I)
(should (equal caller-string "Label"))
(should (equal caller-vector ["Display"])))))
(ert-deftest tp-style-test-direct-merge-defensively-copies-values ()
"Merged declarations isolate mutable values and preserve functions."
(tp-style-test--isolated
(dolist (property '(demo/string demo/vector demo/callback))
(tp-define-property-policy property))
(let* ((calls 0)
(caller-string (copy-sequence "source"))
(caller-vector (vector (copy-sequence "nested")))
(callback (lambda () (cl-incf calls)))
(merged
(tp-merge-declarations
(list 'demo/string caller-string
'demo/vector caller-vector
'demo/callback callback)))
(merged-string (plist-get merged 'demo/string))
(merged-vector (plist-get merged 'demo/vector))
(merged-callback (plist-get merged 'demo/callback)))
(should-not (eq merged-string caller-string))
(should-not (eq merged-vector caller-vector))
(should-not (eq (aref merged-vector 0) (aref caller-vector 0)))
(should (eq merged-callback callback))
(should (functionp merged-callback))
(should (= calls 0))
(aset caller-string 0 ?S)
(aset (aref caller-vector 0) 0 ?N)
(should (equal merged-string "source"))
(should (equal merged-vector ["nested"]))
(aset merged-string 1 ?O)
(aset (aref merged-vector 0) 1 ?E)
(should (equal caller-string "Source"))
(should (equal caller-vector ["Nested"])))))
(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))
(tp-define-property-policy
'demo/help :projector (lambda (value) (list 'help-echo value)))
(let ((projected
(tp--project-declarations (list 'demo/help callback))))
(should (eq (plist-get projected 'help-echo) callback))
(should (= calls 0))))))
(ert-deftest tp-style-test-computed-runs-once-and-result-stays-literal ()
@ -92,436 +142,94 @@
(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-define-property-policy
'demo/help :projector (lambda (value) (list 'help-echo value)))
(let ((projected
(tp--project-declarations
(list 'demo/help
(tp-computed
(lambda ()
(cl-incf compute-calls)
result-function))))))
(should (eq (plist-get values 'text/help) result-function))
(should (eq (plist-get projected 'help-echo) 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))))
(ert-deftest tp-style-test-public-resolver-only-executes-computed-sources ()
"The public resolver preserves literal functions and evaluates tags."
(let ((literal (lambda () 'literal))
(calls 0))
(should (eq (tp-resolve-value literal) literal))
(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)))))
(equal (tp-resolve-value
(tp-computed (lambda () (cl-incf calls) '(computed value))))
'(computed value)))
(should (= calls 1))))
(ert-deftest tp-style-test-subject-class-and-state-tokens-use-value-equality ()
"Selectors match generic string tokens without requiring symbol identity."
(ert-deftest tp-style-test-policy-normalizes-validates-and-projects ()
"A direct value passes through one policy pipeline exactly once."
(tp-style-test--isolated
(let ((subject (tp-subject-create
:type 'button
:classes (list (copy-sequence "primary"))
:state (list (copy-sequence "active")))))
(should (tp-selector-match-p '(:class "primary") subject))
(should (tp-selector-match-p '(:state "active") subject)))))
(ert-deftest tp-style-test-stylesheet-instances-isolate-rules-and-layers ()
"Independent stylesheets cannot leak rules or layer order into each other."
(tp-style-test--isolated
(tp-style-test--color-schema)
(let ((left (tp-stylesheet-create))
(right (tp-stylesheet-create))
(subject (tp-subject-create :type 'button)))
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
:layer 'base :stylesheet left)
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
:layer 'components :stylesheet left)
(tp-stylesheet-add-rule '(:type button) '(demo/color "green")
:layer 'components :stylesheet right)
(tp-stylesheet-add-rule '(:type button) '(demo/color "purple")
:layer 'base :stylesheet right)
(should (equal (plist-get
(tp-style-test--values subject :rules left)
'demo/color)
"red"))
(should (equal (plist-get
(tp-style-test--values subject :rules right)
'demo/color)
"purple"))
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
"black"))
(tp-style-reset-rules left)
(should (equal (plist-get
(tp-style-test--values subject :rules left)
'demo/color)
"black"))
(should (equal (plist-get
(tp-style-test--values subject :rules right)
'demo/color)
"purple")))))
(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))
(let ((normalizations 0) (validations 0) (projections 0))
(tp-define-property-policy
'demo/color
:normalizer (lambda (value) (cl-incf normalizations) (downcase value))
:validator (lambda (value) (cl-incf validations) (stringp value))
:projector (lambda (value)
(cl-incf projections)
(list 'face (list :foreground value))))
(should
(equal (tp--project-declarations '(demo/color "RED"))
'(face (:foreground "red"))))
(should (equal (list normalizations validations projections) '(1 1 1)))
(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)))))
(tp--project-declarations '(demo/color 42))
:type 'tp-invalid-declaration))))
(ert-deftest tp-style-test-nearer-scope-wins-after-specificity ()
"A rule scoped to the nearest matching ancestor wins a tie."
(ert-deftest tp-style-test-validator-rejection-is-explicit ()
"A false validator result raises a direct declaration error."
(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")))))
(tp-define-property-policy 'demo/count :validator #'natnump)
(should-error
(tp--project-declarations '(demo/count -1))
:type 'tp-invalid-declaration)))
(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."
(ert-deftest tp-style-test-native-properties-preserve-functions-and-nil ()
"Native projectors keep callbacks 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)))
(projected
(tp--project-text-declarations
(list 'help-echo callback
'keymap nil
'display '(space :width 4)))))
(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."
(ert-deftest tp-style-test-native-face-policy-merges-contributions ()
"The native face policy retains TP's established face merge semantics."
(tp-style-test--isolated
(let ((result (tp-compute-style (tp-subject-create :type 'label))))
(should-not (tp-project-style result)))))
(let* ((policy (tp-register-text-property 'face))
(merge (tp-property-policy-merge policy)))
(should
(equal (funcall merge '(:foreground "red") '(:weight bold))
'(:foreground "red" :weight bold))))))
(ert-deftest tp-style-test-define-tp-compiles-static-layer-declarations ()
"A static `define-tp' layer also becomes a canonical named style."
(ert-deftest tp-style-test-define-tp-compiles-static-direct-declarations ()
"A static `define-tp' layer compiles into a named direct style."
(tp-style-test--isolated
(unwind-protect
(progn
(define-tp tp-style-test-layer ()
'(face (:weight bold) help-echo "Demo" tp-text "content"))
'(face (:weight bold) help-echo "Demo"))
(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."
(ert-deftest tp-style-test-parameterized-layer-has-no-frozen-style ()
"A parameterized redefinition removes its former static style."
(tp-style-test--isolated
(unwind-protect
(progn
@ -533,7 +241,7 @@
(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."
"A generated static group layer becomes a named direct style."
(tp-style-test--isolated
(unwind-protect
(progn
@ -544,19 +252,48 @@
'(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."
(ert-deftest tp-style-test-named-styles-are-defensive ()
"Named styles own declarations and return defensive copies."
(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")))))))
(dolist (property '(demo/title demo/layout))
(tp-define-property-policy property))
(let* ((title (copy-sequence "button"))
(layout (vector (copy-sequence "row")))
(merged
(tp-merge-declarations
(list 'demo/title title 'demo/layout layout))))
(tp-define-style 'demo/button merged)
(aset (plist-get merged 'demo/title) 0 ?B)
(aset (aref (plist-get merged 'demo/layout) 0) 0 ?R)
(should
(equal (tp-style-declarations 'demo/button)
'(demo/title "button" demo/layout ["row"])))
(let* ((first (tp-style-declarations 'demo/button))
(first-title (plist-get first 'demo/title))
(first-layout (plist-get first 'demo/layout)))
(aset first-title 1 ?U)
(aset (aref first-layout 0) 1 ?O)
(should (equal (plist-get merged 'demo/title) "Button"))
(should (equal (plist-get merged 'demo/layout) ["Row"]))
(should
(equal (tp-style-declarations 'demo/button)
'(demo/title "button" demo/layout ["row"])))))))
(ert-deftest tp-style-test-css-engine-symbols-are-not-owned-by-tp ()
"TP does not expose the CSS cascade surface migrated to ECSS."
(dolist (symbol '(tp-subject-create
tp-subject-set-children
tp-selector-match-p
tp-selector-specificity
tp-stylesheet-create
tp-stylesheet-add-rule
tp-compute-style
tp-project-style
tp-wide-value
tp-important
tp-var))
(should-not (fboundp symbol)))
(should-not (featurep 'ecss)))
(provide 'tp-style-tests)
;;; tp-style-tests.el ends here

378
tests/tp-surface-tests.el
View File

@ -55,6 +55,100 @@
:capability 'content)
:type 'tp-duplicate-object-key)))
(ert-deftest tp-surface-test-plan-copy-obeys-value-identity-rules ()
"Plan data is copied while opaque records and functions keep identity."
(with-temp-buffer
(let* ((caller-string (copy-sequence "tag"))
(caller-vector (vector (copy-sequence "nested")))
(record (tp--make-native-range (current-buffer) :buffer 1 1))
(calls 0)
(callback (lambda () (cl-incf calls)))
(table (make-hash-table :test #'equal))
(marker (copy-marker (point-min)))
(tags (list caller-string caller-vector record callback table
marker (current-buffer)))
(plan (tp-surface-plan-create
:key 'root :kind 'text :text "x" :tags tags
:capability 'content))
(copy (tp-surface-plan-tags plan)))
(should-not (eq copy tags))
(should-not (eq (nth 0 copy) caller-string))
(should-not (eq (nth 1 copy) caller-vector))
(should-not (eq (aref (nth 1 copy) 0) (aref caller-vector 0)))
(should (eq (nth 2 copy) record))
(should (eq (nth 3 copy) callback))
(should (eq (nth 4 copy) table))
(should (eq (nth 5 copy) marker))
(should (eq (nth 6 copy) (current-buffer)))
(should (= calls 0)))))
(ert-deftest tp-surface-test-retained-options-own-mutable-containers ()
"Surface options copy data containers without cloning opaque identities."
(tp-surface-test--with-buffer
(let* ((caller-string (copy-sequence "state"))
(caller-vector (vector (copy-sequence "nested")))
(record (tp--make-native-range buffer :buffer 1 1))
(calls 0)
(callback (lambda () (cl-incf calls)))
(table (make-hash-table :test #'equal))
(start (copy-marker (point-min)))
(end (copy-marker (point-max) t))
(client-state
(list caller-string caller-vector record callback table buffer))
(options
(list :capability 'content :start start :end end
:client-state client-state))
(surface (tp--create-surface buffer 'content options))
(stored-options (tp--surface-options surface))
(stored-state (plist-get stored-options :client-state)))
(should-not (eq stored-state client-state))
(should-not (eq (nth 0 stored-state) caller-string))
(should-not (eq (nth 1 stored-state) caller-vector))
(should-not (eq (aref (nth 1 stored-state) 0)
(aref caller-vector 0)))
(should (eq (nth 2 stored-state) record))
(should (eq (nth 3 stored-state) callback))
(should (eq (nth 4 stored-state) table))
(should (eq (nth 5 stored-state) buffer))
(should (eq (plist-get stored-options :start) start))
(should (eq (plist-get stored-options :end) end))
(should (= calls 0))
(aset caller-string 0 ?S)
(aset (aref caller-vector 0) 0 ?N)
(should (equal (nth 0 stored-state) "state"))
(should (equal (nth 1 stored-state) ["nested"])))))
(ert-deftest tp-surface-test-report-copy-is-deep-for-data-values ()
"Public reports cannot mutate retained data and preserve opaque identities."
(with-temp-buffer
(let* ((report-string (copy-sequence "report"))
(report-vector (vector (copy-sequence "nested")))
(record (tp--make-native-range (current-buffer) :buffer 1 1))
(calls 0)
(callback (lambda () (cl-incf calls)))
(table (make-hash-table :test #'equal))
(marker (copy-marker (point-min)))
(payload (list report-string report-vector record callback table
marker (current-buffer)))
(surface (tp--make-surface :report (list :payload payload)))
(first-payload (plist-get (tp-surface-report surface) :payload)))
(should-not (eq (nth 0 first-payload) report-string))
(should-not (eq (nth 1 first-payload) report-vector))
(should-not (eq (aref (nth 1 first-payload) 0)
(aref report-vector 0)))
(should (eq (nth 2 first-payload) record))
(should (eq (nth 3 first-payload) callback))
(should (eq (nth 4 first-payload) table))
(should (eq (nth 5 first-payload) marker))
(should (eq (nth 6 first-payload) (current-buffer)))
(should (= calls 0))
(aset (nth 0 first-payload) 0 ?R)
(aset (aref (nth 1 first-payload) 0) 0 ?N)
(let ((second-payload
(plist-get (tp-surface-report surface) :payload)))
(should (equal (nth 0 second-payload) "report"))
(should (equal (nth 1 second-payload) ["nested"]))))))
(ert-deftest tp-surface-test-materialize-producer-is-ephemeral ()
"Pure materialization leaves no live object, binding, or subscription."
(let ((signal (tp-signal-create 7)) object binding)
@ -266,6 +360,45 @@
(should (= (plist-get report :scope-range-count) 1))
(should (= (plist-get report :property-operations) 1))))))
(ert-deftest tp-surface-test-sparse-property-update-does-not-scan-between-anchors ()
"A sparse properties update inspects only owned anchor intervals."
(tp-surface-test--with-buffer
(insert (make-string 120 ?x))
(let* ((left-anchor (tp-range-anchor-create buffer 2 3))
(right-anchor (tp-range-anchor-create buffer 100 101))
(left-face 'bold)
(producer
(lambda (context)
(let ((root (tp-object-ensure context nil 'root 'group)))
(let ((left (tp-object-ensure context root 'left 'range))
(right (tp-object-ensure context root 'right 'range)))
(tp-object-attach-range context left left-anchor)
(tp-object-attach-range context right right-anchor)))
(tp-surface-plan-create
:key 'root :kind 'group :capability 'properties
:children
(list
(tp-surface-plan-create
:key 'left :kind 'range :props (list 'face left-face)
:capability 'properties)
(tp-surface-plan-create
:key 'right :kind 'range :props '(face italic)
:capability 'properties)))))
(surface
(tp-surface-mount buffer producer '(:capability properties))))
(setq left-face 'underline)
(let ((original (symbol-function 'next-single-property-change)))
(cl-letf (((symbol-function 'next-single-property-change)
(lambda (position property &optional object limit)
(unless (or (and (>= position 2) (< position 3))
(and (>= position 100) (< position 101)))
(error "Unexpected sparse scan at %s for %s"
position property))
(funcall original position property object limit))))
(tp-surface-update surface producer)))
(should (eq (get-text-property 2 'face) 'underline))
(should (eq (get-text-property 100 'face) 'italic)))))
(ert-deftest tp-surface-test-scoped-update-can-explicitly-fall-back-to-root ()
"A scoped mismatch should publish the root only when explicitly requested."
(tp-surface-test--with-buffer
@ -533,6 +666,82 @@
(tp-surface-unmount surface)
(should (equal (get-text-property 2 'help-echo) "external")))))
(ert-deftest tp-surface-test-property-update-uses-policy-equality ()
"Retained property comparison uses the registered text-property policy."
(tp-surface-test--with-buffer
(insert "host")
(let* ((old-policy (tp-property-policy 'text/help-echo))
(anchor (tp-range-anchor-create buffer 1 5))
(value "A")
surface)
(unwind-protect
(progn
(tp-define-property-policy
'text/help-echo
:equality (lambda (left right)
(string-equal (downcase left) (downcase right)))
:merge (lambda (_old new) new)
:projector (lambda (v) (list 'help-echo v)))
(setq surface
(tp-surface-mount
buffer
(lambda (context)
(let ((object (tp-object-ensure
context nil 'root 'range)))
(tp-object-attach-range context object anchor))
(tp-surface-plan-create
:key 'root :kind 'range
:props (list 'help-echo value)
:capability 'properties))
'(:capability properties)))
(let ((revision (tp-surface-revision surface)))
(setq value "a")
(tp-surface-update surface (tp--surface-producer surface))
(should (= (tp-surface-revision surface) revision))
(should (= (plist-get (tp-surface-report surface)
:property-operations)
1))
(should (equal (get-text-property 2 'help-echo) "A"))))
(when old-policy
(puthash 'text/help-echo old-policy tp--property-policies))
(when (and surface (tp-surface-live-p surface))
(tp-surface-unmount surface))))))
(ert-deftest tp-surface-test-content-property-diff-uses-policy-equality ()
"Content publication skips policy-equal property writes."
(tp-surface-test--with-buffer
(let ((old-policy (tp-property-policy 'text/help-echo))
(value "A")
(client-state 1)
surface producer)
(unwind-protect
(progn
(tp-define-property-policy
'text/help-echo
:equality (lambda (left right)
(string-equal (downcase left) (downcase right)))
:merge (lambda (_old new) new)
:projector (lambda (current) (list 'help-echo current)))
(setq producer
(lambda (context)
(tp-object-ensure context nil 'root 'text)
(tp-surface-result-create
(tp-surface-test--leaf
'root "text" (list 'help-echo value))
(list :state client-state)))
surface (tp-surface-mount
buffer producer '(:capability content)))
(let ((revision (tp-surface-revision surface)))
(setq value "a" client-state 2)
(let ((report (tp-surface-update surface producer)))
(should (= (tp-surface-revision surface) (1+ revision)))
(should (= (plist-get report :property-operations) 0))
(should (equal (get-text-property 1 'help-echo) "A")))))
(when old-policy
(puthash 'text/help-echo old-policy tp--property-policies))
(when (and surface (tp-surface-live-p surface))
(tp-surface-unmount surface))))))
(ert-deftest tp-surface-test-unmount-preserves-conflicting-host-value ()
"Unmount removes only TP's still-current property contribution."
(tp-surface-test--with-buffer
@ -554,6 +763,123 @@
(should-not (tp-surface-live-p surface))
(should-not (tp-range-anchor-live-p anchor)))))
(ert-deftest tp-surface-test-complete-anchor-deletion-applies-boundary-policy ()
"Deleting an entire anchor span applies stale, shorten, and remove policy."
(dolist (case '((stale . t) (shorten . nil) (remove . remove)))
(tp-surface-test--with-buffer
(insert "abcd")
(let* ((policy (car case))
(expected (cdr case))
(anchor (tp-range-anchor-create
buffer 2 4 :boundary-policy policy))
(producer
(lambda (context)
(let ((object (tp-object-ensure context nil 'root 'range)))
(tp-object-attach-range context object anchor))
(tp-surface-plan-create
:key 'root :kind 'range :props '(help-echo "tp")
:capability 'properties)))
(surface
(tp-surface-mount buffer producer '(:capability properties))))
(delete-region 2 4)
(should (eq (tp--anchor-stale anchor) expected))
(when expected
(should-error (tp-surface-update surface producer)
:type 'tp-stale-mount))))))
(ert-deftest tp-surface-test-complete-content-deletion-marks-surface-stale ()
"Deleting a content surface's full span makes the mount stale."
(tp-surface-test--with-buffer
(let ((surface
(tp-surface-mount buffer (tp-surface-test--leaf 'root "abc")
'(:capability content))))
(delete-region 1 4)
(should (tp--surface-stale surface))
(should-error
(tp-surface-update surface (tp-surface-test--leaf 'root "next"))
:type 'tp-stale-mount))))
(ert-deftest tp-surface-test-failed-prepare-rolls-back-direct-buffer-mutation ()
"Producer buffer edits during prepare roll back when preparation fails."
(tp-surface-test--with-buffer
(let* ((surface
(tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
'(:capability content)))
(revision (tp-surface-revision surface)))
(should-error
(tp-surface-update
surface
(lambda (context)
(goto-char (point-min))
(insert "BAD")
(tp-object-ensure context nil 'other 'text)
(tp-surface-test--leaf 'root "new")))
:type 'tp-surface-error)
(should (equal (buffer-string) "old"))
(should-not (tp--surface-stale surface))
(should (= (tp-surface-revision surface) revision)))))
(ert-deftest tp-surface-test-successful-prepare-rejects-direct-buffer-mutation ()
"Producers cannot commit live surface buffers outside TP publication."
(tp-surface-test--with-buffer
(let* ((surface
(tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
'(:capability content)))
(revision (tp-surface-revision surface)))
(should-error
(tp-surface-update
surface
(lambda (context)
(tp-object-ensure context nil 'root 'text)
(goto-char (point-min))
(insert "BAD")
(tp-surface-test--leaf 'root "new")))
:type 'tp-surface-error)
(should (equal (buffer-string) "old"))
(should-not (tp--surface-stale surface))
(should (= (tp-surface-revision surface) revision)))))
(ert-deftest tp-surface-test-prepare-rejects-direct-property-mutation ()
"Producers cannot write live surface properties during prepare."
(tp-surface-test--with-buffer
(let* ((surface
(tp-surface-mount
buffer (tp-surface-test--leaf 'root "old" '(help-echo "old"))
'(:capability content)))
(revision (tp-surface-revision surface)))
(should-error
(tp-surface-update
surface
(lambda (context)
(tp-object-ensure context nil 'root 'text)
(put-text-property (point-min) (1+ (point-min))
'help-echo "BAD")
(tp-surface-test--leaf 'root "new" '(help-echo "new"))))
:type 'tp-producer-buffer-mutation)
(should (equal (buffer-string) "old"))
(should (equal (get-text-property 1 'help-echo) "old"))
(should-not (tp--surface-stale surface))
(should (= (tp-surface-revision surface) revision)))))
(ert-deftest tp-surface-test-boundary-crossing-uses-pre-edit-ranges ()
"A deletion crossing the old right boundary marks retained ranges stale."
(tp-surface-test--with-buffer
(insert "abcd")
(let* ((anchor (tp-range-anchor-create buffer 2 4))
(producer
(lambda (context)
(let ((object (tp-object-ensure context nil 'root 'range)))
(tp-object-attach-range context object anchor))
(tp-surface-plan-create
:key 'root :kind 'range :props '(help-echo "tp")
:capability 'properties)))
(surface (tp-surface-mount
buffer producer '(:capability properties))))
(delete-region 3 5)
(should (tp--anchor-stale anchor))
(should-error (tp-surface-update surface producer)
:type 'tp-stale-mount))))
(ert-deftest tp-surface-test-content-external-edit-marks-mount-stale ()
"An external edit inside content-owned text prevents silent overwrite."
(tp-surface-test--with-buffer
@ -619,6 +945,58 @@
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
(when (buffer-live-p second-buffer) (kill-buffer second-buffer)))))
(ert-deftest tp-surface-test-two-buffer-identities-are-isolated ()
"The same keyed producer creates separate object identity per surface."
(let* ((first-buffer (generate-new-buffer " *tp-surface-first*"))
(second-buffer (generate-new-buffer " *tp-surface-second*"))
(producer (lambda (context)
(tp-object-ensure context nil 'root 'text)
(tp-surface-test--leaf 'root
(buffer-name (current-buffer)))))
first second)
(unwind-protect
(progn
(setq first (tp-surface-mount
first-buffer producer '(:capability content))
second (tp-surface-mount
second-buffer producer '(:capability content)))
(should-not (eq (tp-object-resolve first '(root))
(tp-object-resolve second '(root))))
(should-error
(tp-surface-update-scoped
first (list (tp-object-resolve second '(root))) producer)
:type 'tp-cross-surface-object))
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
(when (buffer-live-p second-buffer) (kill-buffer second-buffer)))))
(ert-deftest tp-surface-test-unmount-cleans-weak-registry-and-markers ()
"Unmount releases weak surface registration and marker-backed state."
(tp-surface-test--with-buffer
(insert "host")
(let* ((anchor (tp-range-anchor-create buffer 1 5))
(producer
(lambda (context)
(let ((object (tp-object-ensure context nil 'root 'range)))
(tp-object-attach-range context object anchor))
(tp-surface-plan-create
:key 'root :kind 'range :props '(help-echo "tp")
:capability 'properties)))
(surface (tp-surface-mount
buffer producer '(:capability properties)))
(id (tp--surface-id surface))
(ledger (tp--surface-ledger surface))
(mounts (tp--surface-mounts surface)))
(should (eq (gethash id tp--surfaces) surface))
(tp-surface-unmount surface)
(should-not (gethash id tp--surfaces))
(should-not (tp-range-anchor-live-p anchor))
(dolist (entry ledger)
(should-not (marker-position (tp--property-ledger-start entry)))
(should-not (marker-position (tp--property-ledger-end entry))))
(dolist (mount mounts)
(should-not (marker-position (tp--surface-mount-start mount)))
(should-not (marker-position (tp--surface-mount-end mount)))))))
(ert-deftest tp-surface-test-materialize-matches-first-content-mount ()
"Pure and live publication produce identical propertized text."
(tp-surface-test--with-buffer

4251
tests/tp-tests.el
View File

File diff suppressed because it is too large Load Diff

332
tp-benchmark.el
View File

@ -7,7 +7,7 @@
;;; Commentary:
;; Run with:
;; emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run
;; Emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run
;;; Code:
@ -20,9 +20,6 @@
(defconst tp-benchmark--generated-seed 8675309
"Printed generated seed. Fixed so the benchmark output is reproducible.")
(defvar tp-bench-fanout-color nil
"Reactive color variable used by `tp-benchmark-run'.")
(defun tp-benchmark--print (plist)
"Print one benchmark row from PLIST."
(princ
@ -32,7 +29,9 @@
(format "%s=%S" (substring (symbol-name key) 1)
(plist-get plist key)))
'(:scenario :status :fixture :seed :requested :actual :operations
:scanned :changed :refreshed :elapsed :gcs :note)
:objects :subscribers :invalidated :recomputed :skipped
:text-operations :property-operations :touched :revision :published
:elapsed :gcs :note)
" ")
"\n")))
@ -49,7 +48,10 @@
result))
(defun tp-benchmark--measure (scenario fixture seed requested actual body)
"Measure BODY after GC and print a benchmark row."
"Measure BODY for SCENARIO and print a benchmark row.
SCENARIO, FIXTURE, SEED, REQUESTED and ACTUAL identify the row metadata.
BODY performs the timed operation."
(garbage-collect)
(let* ((gc-start gcs-done)
(start (float-time))
@ -62,19 +64,12 @@
result
(list :elapsed elapsed :gcs (- gcs-done gc-start) :note nil)))))
(defun tp-benchmark--blocked (scenario fixture seed requested note)
"Print a blocked benchmark row."
(tp-benchmark--print
(list :scenario scenario :status 'blocked :fixture fixture :seed seed
:requested requested :actual 0 :operations 0 :scanned 0
:changed 0 :refreshed 0 :elapsed nil :gcs 0 :note note)))
(defun tp-benchmark--large-text (size seed)
"Benchmark large text property set/search for SIZE and SEED."
(let ((text (tp-benchmark--random-string size seed)))
(tp-set 0 size '(tp-bench t) text)
(unless (equal (tp-search text 'tp-bench t) (list (list 0 size t)))
(error "large-text correctness failed"))
(error "Large-text correctness failed"))
(set-text-properties 0 size nil text)
(tp-benchmark--measure
'large-text 'string seed size size
@ -82,118 +77,230 @@
(tp-set 0 size '(tp-bench t) text)
(let ((matches (tp-search text 'tp-bench t)))
(unless (equal matches (list (list 0 size t)))
(error "timed large-text correctness failed"))
(list :operations 2 :scanned size :changed size
:refreshed 0 :note (length matches)))))))
(error "Timed large-text correctness failed"))
(list :operations 2 :touched size :note (length matches)))))))
(defun tp-benchmark--fragmented (runs seed)
"Benchmark RUNS fragmented property intervals using SEED."
"Measure fragmented property intervals using SEED.
RUNS is the number of intervals."
(let ((text (make-string runs ?x)))
(cl-loop for i below runs
when (zerop (mod i 2))
do (put-text-property i (1+ i) 'tp-bench i text))
(unless (= (length (tp-search text 'tp-bench)) (/ (1+ runs) 2))
(error "fragmented correctness failed"))
(error "Fragmented correctness failed"))
(tp-benchmark--measure
'fragmented 'string seed runs runs
(lambda ()
(let ((matches (tp-search text 'tp-bench)))
(list :operations 1 :scanned runs :changed (length matches)
:refreshed 0 :note nil))))))
(list :operations 1 :touched runs :note (length matches)))))))
(defun tp-benchmark--define-stack-layers (depth)
"Define DEPTH benchmark stack layers."
(cl-loop for i below depth
do (eval `(define-tp ,(intern (format "tp-bench-stack-%d" i))
() '(face bold)))))
(defun tp-benchmark--retained-producer (entries)
"Return a retained content producer for ENTRIES.
Each entry is a cons whose car is a stable key and whose cdr is text."
(lambda (context)
(let ((root (tp-object-ensure context nil 'root 'group)))
(tp-surface-plan-create
:key 'root
:kind 'group
:children
(mapcar
(lambda (entry)
(tp-object-ensure context root (car entry) 'text)
(tp-surface-plan-create
:key (car entry) :kind 'text :text (cdr entry)
:capability 'content))
entries)
:capability 'content))))
(defun tp-benchmark--stack-depth (depth seed)
"Benchmark stack operations at DEPTH using SEED."
(tp-layer-reset)
(tp-benchmark--define-stack-layers depth)
(with-temp-buffer
(insert (make-string 2000 ?s))
(cl-loop for i below depth
do (tp-push-layer 1 2001
(intern (format "tp-bench-stack-%d" i))))
(unless (= (tp-layer-count 1 2001) depth)
(error "stack-depth correctness failed"))
(set-text-properties 1 2001 nil)
(tp-benchmark--measure
'stack-depth 'buffer seed depth depth
(lambda ()
(cl-loop for i below depth
do (tp-push-layer 1 2001
(intern (format "tp-bench-stack-%d" i))))
(unless (= (tp-layer-count 1 2001) depth)
(error "timed stack-depth correctness failed"))
(let ((top (tp-layer-top 1 2001)))
(list :operations (1+ depth) :scanned 2000 :changed 2000
:refreshed 0 :note top))))))
(defun tp-benchmark--define-fanout-layer (seed)
"Define one reactive layer for SEED."
(set 'tp-bench-fanout-color "red")
(eval '(define-tp tp-bench-fanout ()
:props '(face (:foreground $tp-bench-fanout-color))
:data '((tp-bench-fanout-color . "red"))))
seed)
(defun tp-benchmark--reactive-fanout (requested seed)
"Benchmark reactive fanout REQUESTED using SEED."
(let ((actual (min requested 200)))
(tp-layer-reset)
(tp-reactive-reset)
(tp-benchmark--define-fanout-layer seed)
(let ((buffers nil))
(defun tp-benchmark--retained-reconcile (count seed)
"Benchmark retained keyed reconciliation of COUNT items using SEED."
(let* ((entries
(cl-loop for index below count
collect (cons index (format "%d " index))))
(changed-key (mod seed count))
(updated
(reverse
(mapcar
(lambda (entry)
(if (= (car entry) changed-key)
(cons (car entry) (format "changed-%d " seed))
entry))
entries)))
(buffer (generate-new-buffer " *tp-benchmark-retained*"))
surface object)
(unwind-protect
(progn
(dotimes (i actual)
(let ((buf (generate-new-buffer
(format " *tp-bench-fanout-%d*" i))))
(push buf buffers)
(with-current-buffer buf
(insert "x")
(tp-set 1 2 'tp-bench-fanout))))
(setq tp-bench-fanout-color "blue")
(with-current-buffer (car buffers)
(unless (equal (plist-get (get-text-property 1 'face)
:foreground)
"blue")
(error "reactive-fanout correctness failed")))
(setq surface
(tp-surface-mount
buffer (tp-benchmark--retained-producer entries)
'(:capability content))
object (tp-object-resolve surface (list 'root changed-key)))
(tp-benchmark--measure
'reactive-fanout 'buffers seed requested actual
'retained-keyed-reconcile 'buffer seed count count
(lambda ()
(setq tp-bench-fanout-color "green")
(list :operations 1 :scanned actual :changed actual
:refreshed actual
:note (format "requested=%d actual=%d"
requested actual)))))
(mapc (lambda (buf)
(when (buffer-live-p buf) (kill-buffer buf)))
buffers)))))
(let ((report
(tp-surface-update
surface (tp-benchmark--retained-producer updated))))
(unless (eq object
(tp-object-resolve surface
(list 'root changed-key)))
(error "Retained object identity changed"))
(with-current-buffer buffer
(unless (equal (buffer-string)
(mapconcat #'cdr updated ""))
(error "Retained reconciliation published wrong text")))
(unless (and (zerop (plist-get report :created-objects))
(zerop (plist-get report :removed-objects)))
(error "Retained reconciliation replaced stable objects"))
(list :operations 1
:objects (plist-get report :reconciled-objects)
:text-operations (plist-get report :text-operations)
:property-operations
(plist-get report :property-operations)
:touched (plist-get report :touched-characters)
:revision (plist-get report :new-revision)
:published 1
:note (format "moved=%d"
(plist-get report :moved-objects)))))))
(when (and surface (tp-surface-live-p surface))
(tp-surface-unmount surface))
(when (buffer-live-p buffer)
(kill-buffer buffer)))))
(defun tp-benchmark--theme-refresh (seed)
"Benchmark current theme managed refresh hook using SEED."
(if (not (fboundp 'tp--refresh-managed-after-theme-change))
(tp-benchmark--blocked
'theme-managed-refresh 'buffer seed 1
"tp--refresh-managed-after-theme-change unavailable")
(tp-layer-reset)
(with-temp-buffer
(insert (make-string 1000 ?t))
(define-tp tp-bench-theme () '(face (:foreground "red")))
(tp-push-layer 1 1001 'tp-bench-theme)
(tp--refresh-managed-after-theme-change 'benchmark)
(unless tp-theme-last-refreshed-ranges
(error "theme-refresh correctness failed"))
(tp-benchmark--measure
'theme-managed-refresh 'buffer seed 1 1
(defun tp-benchmark--sparse-signal-update (unrelated-count seed)
"Benchmark one exact signal update beside UNRELATED-COUNT bindings.
SEED supplies the target signal value."
(let* ((target (tp-signal-create 0))
(unrelated (tp-signal-create 0))
(target-owner (list 'target seed))
(unrelated-owner (list 'unrelated seed))
(target-calls 0)
(unrelated-calls 0))
(unwind-protect
(progn
(tp-with-transaction
(tp-bind target-owner '(benchmark . target)
(lambda ()
(tp--refresh-managed-after-theme-change 'benchmark)
(list :operations 1 :scanned 1000 :changed 0
:refreshed (length tp-theme-last-refreshed-ranges)
:note tp-theme-last-refresh-mode))))))
(cl-incf target-calls)
(tp-signal-read target)))
(dotimes (index unrelated-count)
(tp-bind unrelated-owner (list 'benchmark index)
(lambda ()
(cl-incf unrelated-calls)
(tp-signal-read unrelated)))))
(unless (and (= (tp-signal-subscriber-count target) 1)
(= (tp-signal-subscriber-count unrelated)
unrelated-count))
(error "Sparse dependency graph has wrong subscriber counts"))
(tp-reactive-reset-counters)
(tp-benchmark--measure
'signal-sparse-update 'binding-graph seed
unrelated-count unrelated-count
(lambda ()
(tp-signal-set target (1+ seed))
(unless (and (= target-calls 2)
(= unrelated-calls unrelated-count))
(error "Sparse update recomputed unrelated bindings"))
(let ((counters (tp-reactive-counters)))
(unless (and (= (plist-get counters :invalidated) 1)
(= (plist-get counters :recomputed) 1))
(error "Sparse update did not stay dependency-local"))
(list :operations 1
:objects (1+ unrelated-count)
:subscribers (tp-signal-subscriber-count target)
:invalidated (plist-get counters :invalidated)
:recomputed (plist-get counters :recomputed)
:skipped (plist-get counters :skipped)
:published 0
:note "unrelated-bindings-untouched")))))
(tp-binding-dispose-owner target-owner)
(tp-binding-dispose-owner unrelated-owner)
(when (tp-signal-live-p target)
(tp-signal-dispose target))
(when (tp-signal-live-p unrelated)
(tp-signal-dispose unrelated)))))
(defun tp-benchmark--reactive-surface-producer (signal)
"Return a retained producer backed by a binding to SIGNAL."
(let ((compute (lambda () (tp-signal-read signal))))
(lambda (context)
(let* ((object (tp-object-ensure context nil 'value 'text))
(binding (tp-bind object '(benchmark . value) compute)))
(tp-surface-plan-create
:key 'value :kind 'text
:text (number-to-string (tp-binding-read binding))
:capability 'content)))))
(defun tp-benchmark--batched-and-noop-publication (writes seed)
"Benchmark WRITES batched writes and equal no-ops using SEED."
(let* ((signal (tp-signal-create seed))
(buffer (generate-new-buffer " *tp-benchmark-batch*"))
(producer (tp-benchmark--reactive-surface-producer signal))
surface)
(unwind-protect
(progn
(setq surface
(tp-surface-mount buffer producer '(:capability content)))
(let ((revision (tp-surface-revision surface)))
(tp-reactive-reset-counters)
(tp-benchmark--measure
'transaction-batch 'retained-surface seed writes writes
(lambda ()
(tp-with-transaction
(dotimes (index writes)
(tp-signal-set signal (+ seed index 1))))
(let* ((report (tp-surface-report surface))
(counters (tp-reactive-counters))
(expected (+ seed writes)))
(with-current-buffer buffer
(unless (equal (buffer-string)
(number-to-string expected))
(error "Batched publication produced wrong text")))
(unless (and (= (tp-surface-revision surface)
(1+ revision))
(= (plist-get report :candidate-source-writes) 1)
(= (plist-get counters :recomputed) 2))
(error "Batched writes were not committed once"))
(list :operations writes
:objects (plist-get report :reconciled-objects)
:invalidated (plist-get counters :invalidated)
:recomputed (plist-get counters :recomputed)
:skipped (plist-get counters :skipped)
:text-operations (plist-get report :text-operations)
:property-operations
(plist-get report :property-operations)
:touched (plist-get report :touched-characters)
:revision (tp-surface-revision surface)
:published 1
:note "one-surface-commit")))))
(let ((revision (tp-surface-revision surface))
(value (tp-signal-peek signal)))
(tp-reactive-reset-counters)
(tp-benchmark--measure
'equal-write-noop 'retained-surface seed writes writes
(lambda ()
(tp-with-transaction
(dotimes (_index writes)
(tp-signal-set signal value)))
(let ((counters (tp-reactive-counters)))
(unless (and (= (tp-surface-revision surface) revision)
(equal counters
'(:invalidated 0 :recomputed 0 :skipped 0
:subscription-added 0
:subscription-removed 0)))
(error "Equal writes changed retained runtime state"))
(list :operations writes
:subscribers (tp-signal-subscriber-count signal)
:invalidated 0 :recomputed 0 :skipped 0
:revision revision :published 0
:note "revision-unchanged"))))))
(when (and surface (tp-surface-live-p surface))
(tp-surface-unmount surface))
(when (tp-signal-live-p signal)
(tp-signal-dispose signal))
(when (buffer-live-p buffer)
(kill-buffer buffer)))))
(defun tp-benchmark-run ()
"Run tp benchmarks in batch mode."
@ -207,11 +314,12 @@
(tp-benchmark--large-text size seed))
(dolist (runs '(1000 10000 50000))
(tp-benchmark--fragmented runs seed))
(dolist (depth '(1 5 20 50))
(tp-benchmark--stack-depth depth seed))
(dolist (fanout '(1 10 100 500))
(tp-benchmark--reactive-fanout fanout seed))
(tp-benchmark--theme-refresh seed)))
(dolist (count '(10 100 1000))
(tp-benchmark--retained-reconcile count seed))
(dolist (unrelated-count '(1 100 10000))
(tp-benchmark--sparse-signal-update unrelated-count seed))
(dolist (writes '(1 100 10000))
(tp-benchmark--batched-and-noop-publication writes seed))))
(provide 'tp-benchmark)
;;; tp-benchmark.el ends here

43
tp-builtins.el
View File

@ -203,48 +203,5 @@ the gallery window."
keymap)
rear-nonsticky (keymap))))
(defun tp--managed-theme-ranges ()
"Return managed buffer ranges and the layer names found in them."
(let (ranges)
(dolist (buffer (buffer-list))
(when (buffer-live-p buffer)
(tp--map-intervals
buffer nil nil
(lambda (start end props)
(let ((names (delq nil
(cons (plist-get props 'tp-name)
(mapcar
(lambda (entry)
(plist-get entry 'tp-name))
(plist-get props 'tp-layers))))))
(when names
(push (list :buffer buffer :start start :end end
:layers (delete-dups names))
ranges)))))))
(nreverse ranges)))
(defun tp--refresh-managed-after-theme-change (_source)
"Conservatively refresh all managed layers after a theme change."
(let* ((ranges (tp--managed-theme-ranges))
(layers (delete-dups
(apply #'append
(mapcar (lambda (range)
(copy-sequence
(plist-get range :layers)))
ranges))))
errors)
(dolist (layer layers)
(condition-case condition
(tp--layer-refresh layer)
(error
(push (list :kind 'theme-refresh :layer layer
:condition condition)
errors))))
(setq tp-theme-last-refresh-mode :conservative
tp-theme-last-refreshed-ranges ranges
tp-theme-last-refresh-errors (nreverse errors))))
(add-hook 'tp-theme-change-hook #'tp--refresh-managed-after-theme-change)
(provide 'tp-builtins)
;;; tp-builtins.el ends here

127
tp-core.el
View File

@ -252,8 +252,10 @@ OBJECT can be string or buffer; nil means current buffer."
(null (object-intervals (or object (current-buffer)))))
(defun tp-plist (start-or-string &optional end object)
"Return merged plist of all properties from START to END in OBJECT.
With single STRING argument, return properties of entire string."
"Return merged plist of all properties from START-OR-STRING to END in OBJECT.
When START-OR-STRING is a string, return properties of the whole string.
Otherwise, START-OR-STRING and END define the range."
(let (start-pos end-pos obj)
(if (stringp start-or-string)
(setq start-pos 0
@ -269,6 +271,25 @@ With single STRING argument, return properties of entire string."
do (setq result (plist-put result key val)))))
result)))
(defun tp--copy-property-value (value)
"Return a defensive copy of mutable containers in property VALUE.
Cons cells, strings, and vectors are copied recursively. Functions, records,
and other opaque objects keep their identity; functions are never executed."
(cond
((functionp value) value)
((recordp value) value)
((consp value)
(cons (tp--copy-property-value (car value))
(tp--copy-property-value (cdr value))))
((stringp value) (copy-sequence value))
((vectorp value)
(let ((copy (copy-sequence value)))
(dotimes (index (length copy))
(aset copy index
(tp--copy-property-value (aref copy index))))
copy))
(t value)))
(defun tp--deep-merge-plist (base new)
"Deep merge NEW plist into BASE plist.
For nested plists (starting with keyword), recursively merge.
@ -608,81 +629,6 @@ Supports plists, alists, and list-of-keys extraction."
(t nil))))
(tp--get-nested next-value rest))))
(defun tp--reactive-symbol-p (sym)
"Return non-nil if SYM is a reactive variable symbol (starts with $)."
(and (symbolp sym)
(string-prefix-p "$" (symbol-name sym))))
(defun tp--reactive-var-symbol (sym)
"Convert a reactive symbol SYM (e.g., $foo) to its variable symbol (e.g., foo).
Returns nil if SYM is not a reactive symbol."
(when (tp--reactive-symbol-p sym)
(intern (substring (symbol-name sym) 1))))
(defun tp--collect-reactive-symbols (form)
"Recursively collect all reactive symbols ($-prefixed) from FORM.
Returns a list of reactive symbols found."
(cond
((tp--reactive-symbol-p form)
(list form))
((consp form)
(append (tp--collect-reactive-symbols (car form))
(tp--collect-reactive-symbols (cdr form))))
(t nil)))
(defun tp--extract-reactive-value (val reactive-var)
"Extract only the parts of VAL that use REACTIVE-VAR.
If VAL is a plist, recursively extract only the key-value pairs
containing REACTIVE-VAR.
If VAL directly contains REACTIVE-VAR, return VAL as-is.
REACTIVE-VAR should be the $-prefixed symbol (e.g., $my-color)."
(cond
;; If val is the reactive var itself, return it
((eq val reactive-var) val)
;; If val is a plist (starts with a keyword), extract reactive parts recursively
((and (listp val) (keywordp (car val)))
(let ((result nil))
(cl-loop for (key subval) on val by #'cddr
when (member reactive-var (tp--collect-reactive-symbols subval))
do (setq result
(plist-put result key
(tp--extract-reactive-value subval reactive-var))))
result))
;; Otherwise return val as-is if it contains the reactive var
(t val)))
(defun tp--extract-reactive-props (plist reactive-var)
"Extract only the properties from PLIST that use REACTIVE-VAR.
Returns a plist containing only the key-value pairs that reference REACTIVE-VAR.
For nested plists, only the sub-properties containing REACTIVE-VAR are included.
REACTIVE-VAR should be the $-prefixed symbol (e.g., $my-color)."
(let ((result nil))
(cl-loop for (key val) on plist by #'cddr
when (member reactive-var (tp--collect-reactive-symbols val))
do (setq result
(plist-put result key
(tp--extract-reactive-value val reactive-var))))
result))
(defun tp--resolve-reactive-symbols (form &optional override-alist)
"Recursively resolve all reactive symbols in FORM to their values.
Reactive symbols ($foo) are replaced with the value of the variable foo.
OVERRIDE-ALIST is an optional alist of (SYMBOL . VALUE) pairs that
override the current variable values (used during watcher callbacks)."
(cond
((tp--reactive-symbol-p form)
(let* ((var-sym (tp--reactive-var-symbol form))
(override (assoc var-sym override-alist)))
(if override
(cdr override)
(if (boundp var-sym)
(symbol-value var-sym)
nil))))
((consp form)
(cons (tp--resolve-reactive-symbols (car form) override-alist)
(tp--resolve-reactive-symbols (cdr form) override-alist)))
(t form)))
(defun tp--prepend-face (new-face existing-face)
"Prepend NEW-FACE to EXISTING-FACE for the face property.
Returns a face value where NEW-FACE takes precedence.
@ -838,16 +784,10 @@ order."
(defun tp-intervals-map (function start end &optional object absolute)
"Apply FUNCTION to each property interval of [START, END) in OBJECT.
FUNCTION is called with (I-START I-END TOP-PROPS BELOW-PROPS-LST) for
every interval `tp-intervals' reports, splitting the layer-stack
bookkeeping out of the raw properties:
- TOP-PROPS is the interval's property plist with the `tp-layers'
entry removed: the directly rendered properties.
- BELOW-PROPS-LST is the value of the interval's `tp-layers'
property: the list of stored layer plists (normally the layers
buried below the rendered top layer; while any layer is hidden it
holds the whole ordered stack - see `tp-layer-stack-at' for the
decoded view). It is nil when the interval carries no layer stack.
FUNCTION is called with (I-START I-END PROPERTIES RESERVED) for every
interval `tp-intervals' reports. PROPERTIES is the direct property plist and
RESERVED is nil. The fourth argument is retained so existing stateless callers
do not need an arity change; TP no longer stores an inline layer stack.
I-START/I-END follow `tp-intervals' coordinates: for buffers they
are by default relative to START (0-based offsets, the legacy
@ -861,18 +801,7 @@ Returns the list of FUNCTION's non-nil results, in interval order
nil
(mapcar
(lambda (tp)
(let* ((interval-start (nth 0 tp)) ;; start from 0
(interval-end (nth 1 tp))
(interval-props (nth 2 tp))
(top-props
(if-let ((idx (cl-position 'tp-layers interval-props)))
(append (cl-subseq interval-props 0 idx)
(nthcdr (+ idx 2) interval-props))
interval-props))
(below-props-lst (plist-get interval-props 'tp-layers)))
(funcall function
interval-start interval-end
top-props below-props-lst)))
(funcall function (nth 0 tp) (nth 1 tp) (nth 2 tp) nil))
(tp-intervals start end object absolute))))
(provide 'tp-core)

2210
tp-layer.el
View File

File diff suppressed because it is too large Load Diff

1520
tp-ops.el
View File

File diff suppressed because it is too large Load Diff

42
tp-palette.el
View File

@ -33,46 +33,6 @@ the library supports Emacs 28.1.")
"Alist of (NAME . PLIST) palette definitions.
This is the single source of truth for palette lookups.")
(defvar tp-theme-generation 0
"Monotonic generation incremented after theme enable/disable events.")
(defvar tp-theme-last-hook-source nil
"Most recent theme lifecycle function observed by tp.")
(defvar tp-theme-last-refresh-mode nil
"Refresh strategy used for the most recent theme lifecycle event.")
(defvar tp-theme-last-refreshed-ranges nil
"Managed ranges considered by the most recent theme refresh.")
(defvar tp-theme-last-refresh-errors nil
"Structured failures from the most recent theme refresh.")
(defvar tp-theme-change-hook nil
"Hook run after a theme lifecycle event.
Each function receives the source symbol, either `enable-theme' or
`disable-theme'. The palette module owns event detection only;
managed renderers may subscribe without creating a reverse dependency.")
(defun tp--palette-note-theme-change (source)
"Record theme lifecycle SOURCE and notify `tp-theme-change-hook'."
(setq tp-theme-generation (1+ tp-theme-generation)
tp-theme-last-hook-source source)
(run-hook-with-args 'tp-theme-change-hook source))
(defun tp--palette-after-enable-theme (&rest _)
"Record an `enable-theme' lifecycle event."
(tp--palette-note-theme-change 'enable-theme))
(defun tp--palette-after-disable-theme (&rest _)
"Record a `disable-theme' lifecycle event."
(tp--palette-note-theme-change 'disable-theme))
(unless (advice-member-p #'tp--palette-after-enable-theme 'enable-theme)
(advice-add 'enable-theme :after #'tp--palette-after-enable-theme))
(unless (advice-member-p #'tp--palette-after-disable-theme 'disable-theme)
(advice-add 'disable-theme :after #'tp--palette-after-disable-theme))
(defmacro define-tp-palette (name &rest plist)
"Register a color palette named NAME, defined by PLIST.
PLIST maps the keys :fg, :bg and :border to colors in any format
@ -358,7 +318,7 @@ color."
(tp-palette--get-color symbol key))
(defun tp-palette-has-p (symbol &optional kind)
"Return non-nil when SYMBOL names a palette that defines KIND.
"Return non-nil when KIND is available in SYMBOL's palette.
With nil KIND, test only that SYMBOL names a palette registered in
`tp-palette-alist' (like `tp-palette-p'). Otherwise KIND is one of
:fg, :bg or :border, and the palette's definition must contain that

43
tp-query.el
View File

@ -24,7 +24,10 @@ only when that overlay supplied the winning character-property value."
property value present-p source mode object position overlay)
(defun tp--lookup-direct (position property object mode)
"Return direct text lookup result at POSITION for PROPERTY in OBJECT."
"Return direct text lookup result for PROPERTY at POSITION in OBJECT.
POSITION, PROPERTY, and OBJECT identify the lookup target; MODE is
returned in the result."
(let* ((obj (or object (current-buffer)))
(cell (plist-member (text-properties-at position object) property)))
(tp--make-lookup-result
@ -33,7 +36,10 @@ only when that overlay supplied the winning character-property value."
:object obj :position position)))
(defun tp--lookup-effective (position property object mode)
"Return effective text lookup result at POSITION for PROPERTY in OBJECT."
"Return effective text lookup result for PROPERTY at POSITION in OBJECT.
POSITION, PROPERTY, and OBJECT identify the lookup target; MODE is
returned in the result."
(let* ((value (get-text-property position property object))
(source-cell (tp--lookup-source-cell position property object))
(present-p (nth 2 source-cell)))
@ -65,7 +71,7 @@ MODE is recorded in the returned `tp-lookup-result'."
(throw 'found (list alias value))))))
(defun tp--lookup-source-cell (position property object)
"Return (SOURCE VALUE PRESENT-P) for text-only source lookup."
"Return (SOURCE VALUE PRESENT-P) for PROPERTY at POSITION in OBJECT."
(let* ((props (text-properties-at position object))
(direct (plist-member props property))
(category (plist-get props 'category))
@ -83,6 +89,8 @@ MODE is recorded in the returned `tp-lookup-result'."
(cl-defun tp-lookup (position property &key object (mode :text-effective))
"Look up PROPERTY at POSITION in OBJECT according to MODE.
POSITION, PROPERTY, OBJECT, and MODE are lookup parameters.
MODE is one of `:text-direct', `:text-effective', `:text-source',
`:char', or `:char-source'. Text modes ignore overlays. Character
modes delegate overlay precedence to `get-char-property-and-overlay';
@ -103,7 +111,7 @@ absence from a direct property whose value is nil."
:position position)))
((or :char :char-source)
(tp--lookup-char position property object mode))
(_ (error "tp-lookup: unknown mode %S" mode))))
(_ (error "TP-LOOKUP: unknown mode %S" mode))))
;;;###autoload
(cl-defun tp-property-change
@ -122,28 +130,35 @@ meanings. Return the changed position or nil."
(if property
(previous-single-property-change position property object limit)
(previous-property-change position object limit)))
(_ (error "tp-property-change: unknown direction %S" direction))))
(_ (error "TP-PROPERTY-CHANGE: unknown direction %S" direction))))
;;;###autoload
(defun tp-property-any (start end property value &optional object)
"Return first position in [START, END) where PROPERTY is VALUE.
This is the facade entry for `text-property-any'; OBJECT is a string,
a buffer, or nil for the current buffer."
START and END are search bounds.
PROPERTY and VALUE are matched directly.
OBJECT is a string, a buffer, or nil for the current buffer."
(text-property-any start end property value object))
;;;###autoload
(defun tp-property-not-all (start end property value &optional object)
"Return first position in [START, END) where PROPERTY is not VALUE.
This delegates directly to `text-property-not-all'."
START and END are search bounds.
PROPERTY and VALUE are matched directly.
OBJECT is a string, a buffer, or nil for the current buffer."
(text-property-not-all start end property value object))
(defun tp--mutation-policy-modes (policy)
"Return normalized (MODIFIED READ-ONLY) modes for POLICY."
"Return normalized (MODIFIED READ-ONLY) modes for POLICY.
POLICY is a property list with keys `:modified' and `:read-only'."
(unless (and (proper-list-p policy) (cl-evenp (length policy)))
(error "tp-with-mutation-policy: POLICY must be a plist"))
(error "TP-WITH-MUTATION-POLICY: POLICY must be a plist"))
(cl-loop for (key _value) on policy by #'cddr
unless (memq key '(:modified :read-only))
do (error "tp-with-mutation-policy: unknown key %S" key))
do (error "TP-WITH-MUTATION-POLICY: unknown key %S" key))
(let ((modified (if (plist-member policy :modified)
(plist-get policy :modified)
:ordinary))
@ -151,11 +166,11 @@ This delegates directly to `text-property-not-all'."
(plist-get policy :read-only)
:respect)))
(unless (memq modified '(:ordinary :silent))
(error "tp-with-mutation-policy: unknown :modified %S" modified))
(error "TP-WITH-MUTATION-POLICY: unknown :modified %S" modified))
(unless (memq read-only '(:respect :inhibit))
(error "tp-with-mutation-policy: unknown :read-only %S" read-only))
(error "TP-WITH-MUTATION-POLICY: unknown :read-only %S" read-only))
(when (and (eq modified :silent) (eq read-only :respect))
(error "tp-with-mutation-policy: :silent requires :read-only :inhibit"))
(error "TP-WITH-MUTATION-POLICY: :silent requires :read-only :inhibit"))
(list modified read-only)))
;;;###autoload

442
tp-reactive.el
View File

@ -12,9 +12,7 @@
;;; Commentary:
;; TP 1.0's exact signal-to-binding dependency graph, transaction-local
;; scheduler, scoped variable adapters, and rollback state. The lower legacy
;; section remains temporarily available to the 0.3 layer/render facade during
;; the staged cutover; new graph execution never calls its scan renderer.
;; scheduler, scoped variable adapters, and rollback state.
;;; Code:
@ -317,7 +315,8 @@ Disposed signals return zero."
"Signal a binding-cycle error for binding PATH."
(signal 'tp-binding-cycle
(list (mapcar (lambda (binding)
(copy-tree (tp-binding-key binding)))
(tp--copy-property-value
(tp-binding-key binding)))
path))))
(defun tp--validate-binding-read (binding &optional computing-only)
@ -446,7 +445,7 @@ EQUALITY compares values and LIFECYCLE controls retention."
(setq binding
(tp--make-binding
:id (cl-incf tp--binding-id-counter)
:owner owner :key (copy-tree key) :compute compute
:owner owner :key (tp--copy-property-value key) :compute compute
:equality equality :subscribers (make-hash-table :test #'eq)
:dirty t :state 'clean :revision 0 :lifecycle lifecycle))
(tp--register-binding binding)
@ -569,9 +568,10 @@ transaction."
(signal 'wrong-type-argument (list 'functionp rollback)))
(when (member key tp--transaction-participant-keys)
(signal 'tp-reactive-error (list :duplicate-participant-key key)))
(push (copy-tree key) tp--transaction-participant-keys)
(push (tp--copy-property-value key) tp--transaction-participant-keys)
(push (tp--make-transaction-participant
:key (copy-tree key) :publish publish :rollback rollback)
:key (tp--copy-property-value key)
:publish publish :rollback rollback)
tp--transaction-participants)
key)
@ -812,435 +812,11 @@ OPERATION and WHERE follow the standard variable watcher protocol."
tp--variable-signal-watched nil)
(tp-reactive-reset-counters))
(defvar tp-reactive-deps nil
"Alist mapping reactive variables to dependent layers.
Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).")
(defvar tp-layer-watchers nil
"Alist of layer watchers: (LAYER-NAME . ((VAR-SYMBOL . CALLBACK) ...)).")
(defvar tp-reactive-observer-errors nil
"Structured observer failures, newest first.
Each entry is a plist containing `:kind', `:layer', `:symbol',
`:condition', `:new-value', and `:old-value'. Watcher failures are
recorded here and reported, but do not block the managed update.")
(defvar tp-layer-computed nil
"Alist of computed properties: (LAYER-NAME . ((VAR-SYMBOL . COMPUTE-FN) ...)).")
(defvar tp-layer-data nil
"Alist of data variables: (LAYER-NAME . (VAR-SYMBOL ...)).")
(defvar tp--batch-update-pending nil
"Queue of deferred reactive buffer re-renders.
Each entry is a list (LAYER-NAME CHANGED-SYMBOLS WHERE TP-TEXT-AFFECTED).
Entries are created and widened by `tp--queue-batch-update'.")
(defvar tp--layer-buffers (make-hash-table :test 'equal)
"Hash table mapping layer names to buffers showing their regions.
Keys are layer names; values are lists of buffers registered via
`tp-reactive--register-layer-buffer'. Reactive updates walk only
these buffers instead of scanning `buffer-list' (see
`tp-reactive-layer-buffers'). A key holding an empty list means
\"known: no buffer shows this layer\", which is distinct from an
absent key (`unknown').")
(defvar tp--layer-buffers-hook-installed nil
"Non-nil once the registry's `kill-buffer-hook' pruner is installed.")
(defun tp-reactive--install-kill-buffer-hook ()
"Install the global `kill-buffer-hook' pruning the buffer registry.
Idempotent; guarded by `tp--layer-buffers-hook-installed'."
(unless tp--layer-buffers-hook-installed
(add-hook 'kill-buffer-hook #'tp-reactive--prune-killed-buffer)
(setq tp--layer-buffers-hook-installed t)))
(defun tp-reactive--prune-killed-buffer ()
"Drop the buffer being killed from `tp--layer-buffers'.
Runs on `kill-buffer-hook' with the dying buffer current. The layer
entries themselves are kept: an entry left with an empty list means
\"known: no buffer shows this layer\", not `unknown'."
(let ((buf (current-buffer)))
(maphash (lambda (layer bufs)
(when (memq buf bufs)
(puthash layer (delq buf bufs) tp--layer-buffers)))
tp--layer-buffers)))
(defun tp-reactive--register-layer-buffer (layer-name buffer)
"Register BUFFER as showing regions of layer LAYER-NAME.
Idempotent: registering the same live BUFFER again keeps a single
entry. Dead buffers and a nil LAYER-NAME are ignored. Installs the
`kill-buffer-hook' pruner on first use. See
`tp-reactive-layer-buffers' for the consumer side of the registry."
(when (and layer-name (buffer-live-p buffer))
(tp-reactive--install-kill-buffer-hook)
(let ((bufs (gethash layer-name tp--layer-buffers)))
(unless (memq buffer bufs)
(puthash layer-name (cons buffer bufs) tp--layer-buffers)))))
(defun tp-reactive--unregister-layer-buffer (layer-name buffer)
"Remove BUFFER from LAYER-NAME's registry entry when it is known."
(let ((buffers (gethash layer-name tp--layer-buffers 'unknown)))
(unless (eq buffers 'unknown)
(puthash layer-name (delq buffer buffers) tp--layer-buffers))))
(defun tp-reactive-layer-buffers (layer-name)
"Return the live buffers registered as showing layer LAYER-NAME.
Return a list of live buffers - possibly empty, meaning \"known: no
buffer shows this layer\" - or the symbol `unknown' when LAYER-NAME
has no registry entry at all. Killed buffers still recorded in the
registry are dropped lazily by this accessor.
KNOWN GAP: inserting an already-propertized STRING into a buffer
bypasses the buffer operations that register buffers, so such a
buffer is missing here until a reactive update's full-scan fallback
finds it or `tp-reactive-track-buffer' is called on it."
(let ((bufs (gethash layer-name tp--layer-buffers 'unknown)))
(if (eq bufs 'unknown)
'unknown
(let ((live (cl-remove-if-not #'buffer-live-p bufs)))
(unless (= (length live) (length bufs))
(puthash layer-name live tp--layer-buffers))
live))))
(defun tp-reactive--buffer-layer-names (&optional buffer)
"Return the layer names present in BUFFER, in buffer order.
BUFFER defaults to the current buffer; a dead BUFFER yields nil.
Stack-aware: a layer counts as present when its name is the direct
`tp-name' text property of a run (the rendered top layer) or the
`tp-name' of any layer plist inside the run's `tp-layers'
stack-storage property (layers buried below the top, or hidden - see
tp-stack.el). The `tp-layers' value is read as a plain list of
plists, so this helper stays below the stack module. Names are
deduplicated with `equal'. This is the shared scan behind
`tp-reactive-track-buffer' and the anonymous-layer GC's liveness
test `tp--buffer-has-layer-region-p'."
(let ((buf (or buffer (current-buffer)))
(found nil))
(when (buffer-live-p buf)
(tp--map-intervals
buf nil nil
(lambda (_start _end props)
(let ((direct (plist-get props 'tp-name)))
(when (and direct (not (member direct found)))
(push direct found)))
(dolist (layer (plist-get props 'tp-layers))
(let ((name (plist-get layer 'tp-name)))
(when (and name (not (member name found)))
(push name found)))))))
(nreverse found)))
;;;###autoload
(defun tp-reactive-track-buffer (&optional buffer)
"Scan BUFFER for layer regions and register it in the buffer registry.
BUFFER defaults to the current buffer. Walk BUFFER's text-property
runs and register BUFFER for every layer name found - rendered top
layers (direct `tp-name') as well as layers inside `tp-layers' stack
storage (buried below another layer, or hidden) - so reactive updates
visit it without a full `buffer-list' scan.
Call this after inserting an already-propertized string into a
buffer: string application bypasses the buffer operations that
register buffers (see `tp-reactive-layer-buffers'), and this command
closes that gap. Return the list of layer names registered, in
buffer order."
(interactive)
(let* ((buf (or buffer (current-buffer)))
(found (tp-reactive--buffer-layer-names buf)))
(dolist (name found)
(tp-reactive--register-layer-buffer name buf))
(when (called-interactively-p 'interactive)
(message "tp: tracking %d layer(s) in %s"
(length found) (buffer-name buf)))
found))
(defvar tp--batch-update-active nil
"When non-nil, we are inside a `tp-with-batch-updates' form.")
(defvar tp--reactive-updating nil
"Non-nil while a reactive update is being applied.
Used as a reentrancy guard: when a variable is set from within an
update (a computed variable being written, or the tp-text two-way
sync), the nested change still updates the variable, but its
re-render is queued in `tp--batch-update-pending' and flushed after
the outermost update completes instead of recursing.")
(defun tp--queue-batch-update (layer-name symbol where tp-text-affected)
"Queue a deferred re-render of LAYER-NAME in `tp--batch-update-pending'.
SYMBOL is the changed variable, WHERE the buffer for buffer-local
changes (nil for global ones), TP-TEXT-AFFECTED non-nil when the
change touches the layer's `tp-text'. When the layer already has a
pending entry, the entry is widened to the union of both changes:
SYMBOL is added, TP-TEXT-AFFECTED is sticky (once set it stays set)
and WHERE widens to nil (all buffers) as soon as two changes disagree
on it."
(let ((existing (assoc layer-name tp--batch-update-pending)))
(if existing
(progn
(unless (memq symbol (nth 1 existing))
(setf (nth 1 existing) (cons symbol (nth 1 existing))))
(unless (eq (nth 2 existing) where)
(setf (nth 2 existing) nil))
(when tp-text-affected
(setf (nth 3 existing) t)))
(push (list layer-name (list symbol) where (and tp-text-affected t))
tp--batch-update-pending))))
(defun tp--register-reactive-deps (layer-name reactive-symbols props)
"Register REACTIVE-SYMBOLS as dependencies for LAYER-NAME.
PROPS is the original property specification with reactive symbols.
Only the reactive portions of the properties are stored for each variable."
;; Register each reactive symbol's dependency with only its relevant properties
(dolist (rsym reactive-symbols)
(let* ((var-sym (tp--reactive-var-symbol rsym))
;; Extract only the properties that use this specific reactive variable
(reactive-props (tp--extract-reactive-props props rsym))
(existing (assoc var-sym tp-reactive-deps)))
(if existing
;; Update or add this layer to existing dependencies
(let ((layer-entry (assoc layer-name (cdr existing))))
(if layer-entry
;; Update existing entry with new reactive-props
(setf (cdr layer-entry) reactive-props)
;; Add new layer entry
(push (cons layer-name reactive-props) (cdr existing))))
;; Create new dependency entry and add watcher
(push (cons var-sym (list (cons layer-name reactive-props))) tp-reactive-deps)
;; Add variable watcher for this variable
(unless (boundp var-sym) (set var-sym nil))
(add-variable-watcher var-sym #'tp--reactive-variable-watcher)))))
(defun tp--unregister-reactive-deps (layer-name)
"Unregister all reactive dependencies for LAYER-NAME."
;; Collect variables that need watcher removal
(let ((vars-to-clean nil))
;; First pass: remove layer from dependencies and collect empty vars
(dolist (dep tp-reactive-deps)
(let ((var-sym (car dep)))
(setf (cdr dep) (assq-delete-all layer-name (cdr dep)))
;; If no more dependencies, mark for watcher removal
(when (null (cdr dep))
(push var-sym vars-to-clean))))
;; Remove watchers for variables with no dependencies
(dolist (var-sym vars-to-clean)
(remove-variable-watcher var-sym #'tp--reactive-variable-watcher)))
;; Clean up empty dependency entries
(setq tp-reactive-deps
(cl-remove-if (lambda (dep) (null (cdr dep))) tp-reactive-deps))
;; Also clean up layer watchers, computed properties, and data
(tp--unregister-layer-watchers layer-name)
(tp--unregister-layer-computed layer-name)
(tp--unregister-layer-data layer-name)
;; Drop the layer's buffer-registry entry: an undefined (or about to
;; be redefined) layer must not linger as stale "known" state; the
;; next update or refresh falls back to a learning full scan.
(remhash layer-name tp--layer-buffers))
(defun tp--layer-has-reactive-deps-p (layer-name)
"Return non-nil if LAYER-NAME has reactive dependencies registered.
Layers with reactive deps need tp-name for reactive tracking."
(cl-some (lambda (dep)
(assoc layer-name (cdr dep)))
tp-reactive-deps))
(defvar tp--reactive-update-function nil
"Function applying a reactive update to layer definitions and buffers.
Installed by tp-render.el. Called with (LAYER-NAME REACTIVE-PROPS
SYMBOL NEWVAL WHERE OVERRIDE-ALIST) after the user watch callbacks
have run. When nil, variable changes only invoke watch callbacks and
no re-rendering happens.")
(defun tp--reactive-variable-watcher (symbol newval operation where)
"Watcher function called when a reactive variable changes.
SYMBOL is the variable that changed.
NEWVAL is the new value being set.
OPERATION is the type of operation (set, let, unlet, makunbound, defvaralias).
WHERE indicates where the variable was set:
- nil for global `setq' or `set'
- a buffer for `setq-local'
Updates all layers that depend on this variable.
Only `set' operations trigger updates because:
- `let'/`unlet': Temporary bindings that will be restored, no need to update UI
- `makunbound': Variable is being undefined, not a value change
- `defvaralias': Aliasing, the actual value change will trigger a separate `set'
When `tp--batch-update-active' is non-nil, buffer updates are deferred until
the batch completes. Layer definitions are still updated immediately.
Uses `tp--equal-including-string-properties' for comparison to properly detect
changes in text properties when the text content is the same.
The actual recomputation and buffer re-rendering is delegated to
`tp--reactive-update-function', installed by tp-render.el."
(when (and (not (tp--equal-including-string-properties
(when (boundp symbol)
(symbol-value symbol))
newval))
(eq operation 'set))
(tp-debug-log "Variable %s changed: %S -> %S (where: %s)"
symbol (when (boundp symbol) (symbol-value symbol)) newval
(if where (buffer-name where) "global"))
(let ((deps (cdr (assoc symbol tp-reactive-deps)))
(oldval (when (boundp symbol) (symbol-value symbol)))
;; Create override alist with the new value
;; (watcher is called before the variable is actually updated)
(override-alist (list (cons symbol newval))))
(dolist (dep deps)
(let ((layer-name (car dep))
;; Get the reactive props stored directly in the dependency
(reactive-props (cdr dep)))
;; Call user-defined watch callbacks for this layer
(tp--invoke-layer-watchers layer-name symbol newval oldval)
;; Delegate recomputation and re-rendering to the update engine
(when tp--reactive-update-function
(funcall tp--reactive-update-function
layer-name reactive-props symbol newval
where override-alist)))))))
(defun tp--invoke-layer-watchers (layer-name symbol newval oldval)
"Invoke all registered watcher callbacks for LAYER-NAME watching SYMBOL.
NEWVAL is the new value, OLDVAL is the old value."
(when-let ((watchers (cdr (assoc layer-name tp-layer-watchers))))
(dolist (watcher watchers)
(let ((watch-sym (car watcher))
(callback (cdr watcher)))
(when (eq watch-sym symbol)
(tp-debug-log " Invoking watcher for %s on %s" watch-sym layer-name)
(condition-case err
(funcall callback newval oldval layer-name)
(error
(push (list :kind 'watcher
:layer layer-name
:symbol watch-sym
:condition err
:new-value newval
:old-value oldval)
tp-reactive-observer-errors)
(message "tp: watcher error for %s watching %s: %s"
layer-name watch-sym err))))))))
(defun tp--register-layer-watchers (layer-name watchers)
"Register WATCHERS for LAYER-NAME.
WATCHERS is a list of (VAR-SYMBOL CALLBACK) pairs."
(when watchers
(let ((watcher-pairs
(mapcar (lambda (watcher)
(cons (car watcher) (cadr watcher)))
watchers)))
(if (assoc layer-name tp-layer-watchers)
(setf (cdr (assoc layer-name tp-layer-watchers)) watcher-pairs)
(push (cons layer-name watcher-pairs) tp-layer-watchers)))))
(defun tp--register-layer-computed (layer-name computed)
"Register COMPUTED variable definitions for LAYER-NAME.
COMPUTED is a list of (VAR-SYMBOL COMPUTE-FN) pairs."
(when computed
(let ((computed-pairs
(mapcar (lambda (comp)
(cons (car comp) (cadr comp)))
computed)))
(if (assoc layer-name tp-layer-computed)
(setf (cdr (assoc layer-name tp-layer-computed)) computed-pairs)
(push (cons layer-name computed-pairs) tp-layer-computed)))))
(defun tp--unregister-layer-watchers (layer-name)
"Unregister all watchers for LAYER-NAME."
(setq tp-layer-watchers (assq-delete-all layer-name tp-layer-watchers)))
(defun tp--unregister-layer-computed (layer-name)
"Unregister all computed properties for LAYER-NAME."
(setq tp-layer-computed (assq-delete-all layer-name tp-layer-computed)))
(defun tp--apply-initial-computed (compute)
"Apply initial computed values using COMPUTE definitions.
COMPUTE is a list of (VAR-SYMBOL COMPUTE-FN) pairs.
Sets the global variables to their computed values.
A compute function returning nil is a legitimate result. Compute
errors propagate because a skipped value would leave stale state."
(dolist (comp compute)
(let* ((var-sym (car comp))
(compute-fn (cadr comp))
(val (funcall compute-fn)))
(set var-sym val))))
(defun tp--data-var-symbol (data-entry)
"Extract the variable symbol from DATA-ENTRY.
DATA-ENTRY can be a symbol or a cons cell (SYMBOL . INITIAL-VALUE)."
(if (consp data-entry)
(car data-entry)
data-entry))
(defun tp--register-layer-data (layer-name data-vars)
"Register DATA-VARS for LAYER-NAME.
DATA-VARS is a list of variable symbols or cons cells (SYMBOL . INITIAL-VALUE).
Also adds variable watchers so changes to data vars trigger computed updates."
(when data-vars
;; Extract just the symbols for storage
(let ((var-symbols (mapcar #'tp--data-var-symbol data-vars)))
(if (assoc layer-name tp-layer-data)
(setf (cdr (assoc layer-name tp-layer-data)) var-symbols)
(push (cons layer-name var-symbols) tp-layer-data))
;; Add watchers for data variables
(dolist (var-sym var-symbols)
(let ((existing (assoc var-sym tp-reactive-deps)))
(if existing
;; Add this layer to existing dependencies
;; (with nil props since data vars don't have direct props)
(let ((layer-entry (assoc layer-name (cdr existing))))
(unless layer-entry
(push (cons layer-name nil) (cdr existing))))
;; Create new dependency entry and add watcher
(push (cons var-sym (list (cons layer-name nil))) tp-reactive-deps)
(unless (boundp var-sym) (set var-sym nil))
(add-variable-watcher var-sym #'tp--reactive-variable-watcher)))))))
(defun tp--unregister-layer-data (layer-name)
"Unregister data variables for LAYER-NAME."
(setq tp-layer-data (assq-delete-all layer-name tp-layer-data)))
(defun tp--ensure-reactive-variables (var-symbols)
"Ensure all VAR-SYMBOLS are defined as global variables.
VAR-SYMBOLS can be a list of symbols or cons cells (SYMBOL . INITIAL-VALUE).
If a variable is not bound, define it with the initial value (nil if
not specified).
If a variable has an explicit initial value (cons cell), always update
it to allow re-definition to change initial values."
(dolist (sym var-symbols)
(let* ((is-cons (and (consp sym) (not (tp--reactive-symbol-p sym))))
(var-sym (cond
(is-cons (car sym))
((tp--reactive-symbol-p sym)
(tp--reactive-var-symbol sym))
(t sym)))
(initial-val (if is-cons (cdr sym) nil)))
(if is-cons
;; For explicit initial values, always update (allows re-definition)
(set var-sym initial-val)
;; For implicit initial values, only set if not already bound
(unless (boundp var-sym)
(set var-sym initial-val))))))
;;;###autoload
(defun tp-reactive-reset ()
"Reset all reactive text property watchers and dependencies."
"Reset TP's signal, binding, adapter, and scheduler graph."
(interactive)
(tp--reactive-graph-reset)
;; Remove all variable watchers
(dolist (dep tp-reactive-deps)
(let ((var-sym (car dep)))
(remove-variable-watcher var-sym #'tp--reactive-variable-watcher)))
;; Clear all registries
(setq tp-reactive-deps nil)
(setq tp-layer-watchers nil)
(setq tp-reactive-observer-errors nil)
(setq tp-layer-computed nil)
(setq tp-layer-data nil)
;; Drop queued re-renders too: entries stranded by an error escaping
;; an update would otherwise survive the reset and replay against
;; freshly (re)defined layers on the next flush (ARCH-4).
(setq tp--batch-update-pending nil)
(clrhash tp--layer-buffers))
(tp--reactive-graph-reset))
(provide 'tp-reactive)
;;; tp-reactive.el ends here

668
tp-render.el
View File

@ -1,668 +0,0 @@
;;; tp-render.el --- Reactive re-rendering engine for tp -*- lexical-binding: t -*-
;; Copyright (C) 2024-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:
;; The reactive update engine: when a reactive variable changes, this
;; module recomputes layer definitions and re-renders every affected
;; buffer region, including live `tp-text' text replacement. It also
;; owns the batching flush and the public `tp-with-batch-updates'
;; macro (the queue state lives in tp-reactive.el). It installs
;; itself into tp-reactive.el (update hook) and tp-layer.el (layer
;; refresh hook), and calls down into tp-ops.el for the `tp-text'
;; helper chain.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(require 'tp-reactive)
(require 'tp-layer)
(require 'tp-ops)
(require 'tp-search)
(defun tp--layer-reactive-props (layer-name)
"Collect LAYER-NAME's unresolved reactive props from `tp-reactive-deps'.
Each dependency entry stores only the portions of the layer's props
that reference one variable; this merges the fragments back into a
single plist with the `$var' markers intact. Returns nil when the
layer has no reactive props (data-only dependencies store nil)."
(let ((all nil))
(dolist (dep tp-reactive-deps)
(let ((layer-entry (assoc layer-name (cdr dep))))
(when (and layer-entry (cdr layer-entry))
(setq all (if all
(tp--deep-merge-plist all (cdr layer-entry))
(copy-sequence (cdr layer-entry)))))))
all))
(defun tp--layer-render-props (layer-name override-alist)
"Return LAYER-NAME's props for re-rendering in the current buffer.
Starts from the stored layer definition and deep-merges the layer's
reactive props re-resolved against the current variable values, so
buffer-local values are honored when the target buffer is current.
OVERRIDE-ALIST maps variables to not-yet-visible new values (the
variable watcher runs before the variable is actually set) and takes
precedence over `symbol-value'. Returns nil when the layer has no
usable definition."
(let ((base (tp-layer-props layer-name t))) ; include tp-name for tracking
(when base
(let ((reactive (tp--layer-reactive-props layer-name)))
(if reactive
(tp--deep-merge-plist
base (tp--resolve-reactive-symbols reactive override-alist))
base)))))
(defun tp--store-computed-value
(layer-name var-sym computed-val override-alist)
"Store LAYER-NAME's computed VAR-SYM and return updated OVERRIDE-ALIST."
(set var-sym computed-val)
(push (cons var-sym computed-val) override-alist)
(let ((current-props (cdr (assoc layer-name tp-layer-alist)))
(reactive-props (tp--layer-reactive-props layer-name)))
(when (and current-props reactive-props)
(let ((resolved
(tp--resolve-reactive-symbols reactive-props override-alist)))
(when resolved
(tp--set-layer-props
layer-name
(tp--deep-merge-plist current-props resolved))))))
override-alist)
(defun tp--update-layer-computed (layer-name override-alist)
"Compute LAYER-NAME values and return an updated OVERRIDE-ALIST.
Compute errors propagate; returning nil remains a legitimate value."
(dolist (comp (cdr (assoc layer-name tp-layer-computed)))
(let* ((var-sym (car comp))
(compute-fn (cdr comp))
(computed-val
(cl-progv
(mapcar #'car override-alist)
(mapcar #'cdr override-alist)
(funcall compute-fn))))
(setq override-alist
(tp--store-computed-value
layer-name var-sym computed-val override-alist))))
override-alist)
(defun tp--render-visit-buffer (buffer fn)
"Call FN with BUFFER current and `inhibit-read-only' bound to t.
Dead buffers are skipped. This is the per-buffer seam of the
reactive update walk; tests may advise it to count buffer visits."
(when (buffer-live-p buffer)
(tp-with-current-buffer buffer
(funcall fn))))
(defun tp--map-layer-buffers (layer-name where fn)
"Run FN in each buffer that may show LAYER-NAME's regions.
A non-nil WHERE (a live buffer, the `setq-local' case) restricts the
walk to that buffer. Otherwise the walk consults the buffer registry
via `tp-reactive-layer-buffers' and visits only registered live
buffers. When the registry answers `unknown', the walk falls back to
a full `buffer-list' scan, registering every buffer that actually
contains a region of LAYER-NAME; once at least one buffer is
registered the layer is known and later updates skip the full scan.
A layer found in no buffer at all deliberately stays `unknown', so a
later application through a path that does not register buffers is
still picked up by the next update's full scan."
(if (and where (bufferp where) (buffer-live-p where))
(tp--render-visit-buffer where fn)
(let ((registered (tp-reactive-layer-buffers layer-name)))
(if (not (eq registered 'unknown))
(dolist (buf registered)
(tp--render-visit-buffer buf fn))
;; Learning fallback: behave exactly like the historical full
;; scan, but record which buffers actually carry the layer.
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(when (tp--buffer-has-layer-region-p layer-name buf)
(tp-reactive--register-layer-buffer layer-name buf))
(tp--render-visit-buffer buf fn)))))))
(defun tp--reconcile-layer-props
(current old-props new-props &optional include-meta)
"Replace one layer's OLD-PROPS in CURRENT with NEW-PROPS.
Keys owned by OLD-PROPS are removed when CURRENT still carries the old
value, then NEW-PROPS are written in full. A differing current value
is preserved when the new definition no longer owns that key, because
it may be an explicit post-application edit. Stack metadata
`tp-layers' and `tp-hidden' is never owned by a layer definition.
`tp-meta' is rendered only when INCLUDE-META is non-nil.
Return a fresh plist."
(let ((result (copy-sequence current)))
(cl-loop for (key val) on old-props by #'cddr
unless (memq key '(tp-name tp-layers tp-hidden tp-meta))
when (and (plist-member result key)
(equal (plist-get result key) val))
do (cl-remf result key))
(cl-loop for (key val) on new-props by #'cddr
unless (or (memq key '(tp-layers tp-hidden))
(and (eq key 'tp-meta) (not include-meta)))
do (setq result (plist-put result key val)))
result))
(defun tp--reconcile-layer-region (start end old-props new-props)
"Reconcile OLD-PROPS and NEW-PROPS on every property run in START..END."
(let ((pos start))
(while (< pos end)
(let* ((next (or (next-property-change pos nil end) end))
(current (text-properties-at pos))
(updated (tp--reconcile-layer-props
current old-props new-props)))
(unless (equal updated current)
(set-text-properties pos next updated))
(setq pos next)))))
(defun tp--replace-stack-entry-props (entry old-props new-props)
"Return ENTRY with OLD-PROPS replaced by NEW-PROPS."
(tp--refresh-entry-meta-version
(tp--reconcile-layer-props entry old-props new-props t)))
(defun tp--refresh-entry-meta-version (entry)
"Return ENTRY with refreshed metadata version fields when present."
(if-let ((meta (plist-get entry 'tp-meta))
(name (plist-get entry 'tp-name)))
(let ((updated (copy-tree meta)))
(setq updated
(plist-put updated :definition-version
(tp--layer-definition-version name)))
(setq updated
(plist-put updated :entry-version
(1+ (or (plist-get meta :entry-version) 0))))
(when (boundp 'tp-theme-generation)
(setq updated
(plist-put updated :palette-generation
tp-theme-generation)))
(plist-put entry 'tp-meta updated))
entry))
(defun tp--entry-parameterized-refresh (entry layer-name)
"Return refreshed ENTRY for parameterized LAYER-NAME, or ENTRY."
(let ((meta (plist-get entry 'tp-meta)))
(if (and meta
(eq (plist-get entry 'tp-name) layer-name)
(not (plist-get meta :legacy-no-args))
(plist-member meta :args)
(tp-layer-parameterized-p layer-name))
(tp--entry-from-parameterized-meta entry layer-name meta)
entry)))
(defun tp--entry-from-parameterized-meta (entry layer-name meta)
"Build a refreshed managed ENTRY for LAYER-NAME from META."
(let* ((args (plist-get meta :args))
(props (tp-layer-props-with-args layer-name args t))
(hidden (tp--stack-hidden-p entry))
(updated (tp--refresh-entry-meta-version
(plist-put props 'tp-meta (copy-tree meta)))))
(if hidden
(plist-put updated 'tp-hidden t)
updated)))
(defun tp--refresh-parameterized-stack (stack layer-name)
"Refresh parameterized LAYER-NAME entries in STACK."
(mapcar (lambda (entry)
(tp--entry-parameterized-refresh entry layer-name))
stack))
(defun tp--refresh-parameterized-layer-regions (layer-name)
"Refresh mounted parameterized entries for LAYER-NAME in current buffer."
(let ((pos (point-min))
(max (point-max)))
(while (< pos max)
(let* ((next (or (next-property-change pos nil max) max))
(stack (tp--stack-props-to-list (text-properties-at pos)))
(new-stack (tp--refresh-parameterized-stack stack layer-name)))
(unless (equal new-stack stack)
(set-text-properties pos next
(tp--stack-build-props new-stack)))
(setq pos next)))))
(defun tp--managed-stack-with-direct-edits (props stored)
"Return authoritative STORED after absorbing visible edits from PROPS.
In managed full-stack storage, direct properties are the render
projection of the first visible entry. A caller may legitimately
edit that projection with native text-property primitives. Preserve
those edits on the visible entry before refreshing definitions, while
keeping managed identity and metadata authoritative."
(let ((direct (copy-sequence props)))
(cl-remf direct 'tp-layers)
(let ((visible (seq-find (lambda (entry)
(not (tp--stack-hidden-p entry)))
stored)))
(cond
((null visible)
(if direct
(signal 'tp-layer-conflict
(list "Properties appeared while all layers were hidden"
:actual direct))
stored))
((not (equal (plist-get direct 'tp-name)
(plist-get visible 'tp-name)))
(signal 'tp-layer-conflict
(list "Managed render identity changed"
:actual direct :expected visible)))
(t
(let ((updated (copy-tree visible)))
(cl-loop for (key _value)
on (tp--entry-render-projection visible) by #'cddr
unless (or (eq key 'tp-name)
(plist-member direct key))
do (cl-remf updated key))
(cl-loop for (key value) on direct by #'cddr
unless (eq key 'tp-name)
do (setq updated (plist-put updated key value)))
(mapcar (lambda (entry)
(if (eq entry visible) updated entry))
stored)))))))
(defun tp--write-layer-through-stack-storage
(layer-name props &optional old-props)
"Write PROPS through to LAYER-NAME's entries in `tp-layers' storage.
A reactive re-render rewrites a layer's direct (rendered) properties,
but the same layer can also sit inside the `tp-layers' stack-storage
property of a run: buried below another layer, or hidden (see
`tp-hide-layer'), in which case the direct properties are only a
render cache and the stored entry is what the next stack operation
rebuilds from. OLD-PROPS, when non-nil, identifies definition-owned
keys that disappeared and must be removed.
For every run of the current buffer whose `tp-layers' holds an entry
whose `tp-name' equals LAYER-NAME, reconcile the layer entry and
rewrite the run via `tp--stack-props-to-list' /
`tp--stack-build-props'. Runs already storing the current values are
left untouched."
(let ((pos (point-min))
(max (point-max)))
(while (< pos max)
(let ((next (or (next-property-change pos nil max) max))
(stored (get-text-property pos 'tp-layers)))
(when (and stored
(cl-some (lambda (entry)
(equal (plist-get entry 'tp-name) layer-name))
stored))
(let* ((raw (text-properties-at pos))
(stack
(if (tp--entry-authoritative-storage-p stored)
(tp--managed-stack-with-direct-edits raw stored)
(tp--stack-props-to-list raw)))
(new-stack
(mapcar (lambda (entry)
(if (equal (plist-get entry 'tp-name) layer-name)
(tp--replace-stack-entry-props
entry old-props props)
entry))
stack)))
(unless (equal new-stack stack)
(set-text-properties pos next
(tp--stack-build-props new-stack)))))
(setq pos next)))))
(defun tp--update-layer-regions
(layer-name &optional where override-alist old-props)
"Update text regions that have LAYER-NAME applied.
Reconcile the layer's current properties with OLD-PROPS, when given,
so redefinition removes keys and nested values the old definition
owned while preserving unrelated direct properties.
The update also writes through to `tp-layers' stack storage: copies
of the layer that are hidden or buried below another layer are
refreshed in place, so a later stack operation or `tp-show-layer'
renders current values instead of a stale snapshot.
WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update the buffers registered for the layer,
falling back to a full scan when the registry has no knowledge.
OVERRIDE-ALIST maps reactive variables to their new values when a
watcher fires before those variables are set."
(let ((update-buffer
(lambda ()
(let ((props (tp--layer-render-props layer-name override-alist)))
(save-excursion
(if props
(progn
;; In hidden/full-stack mode storage is authoritative.
;; Update it first so the render-cache conflict guard
;; compares old cache with old storage.
(tp--write-layer-through-stack-storage
layer-name props old-props)
(tp-search-map
(lambda (_text start end)
(tp--reconcile-layer-region
start end old-props props)
nil)
'tp-name layer-name))
(tp--refresh-parameterized-layer-regions layer-name)))))))
(tp--map-layer-buffers layer-name where update-buffer)))
(defun tp--update-reactive-text (layer-name &optional where override-alist)
"Update text regions that have tp-text property with LAYER-NAME applied.
This is called when a reactive variable bound to tp-text changes.
WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update the buffers registered for the layer in
the reactive buffer registry, falling back to one full
`buffer-list' scan when the registry has no knowledge of the
layer (see `tp--map-layer-buffers').
OVERRIDE-ALIST maps reactive variables to their new values when the
watcher fires before the variables are set; the layer's props are
re-resolved against it in each target buffer.
If a transform function is registered for LAYER-NAME via `:transform',
it will be applied to the text before updating."
(let ((update-buffer
(lambda ()
(let ((props (tp--layer-render-props layer-name override-alist)))
(when props
(let* ((raw-text (plist-get props 'tp-text))
;; Apply transformation if registered
(new-text (if (stringp raw-text)
(tp--tp-text-transform layer-name raw-text)
raw-text)))
(when (and new-text (stringp new-text))
;; No save-excursion here: the replace function
;; owns point restoration (its clamping semantics
;; would be overridden by save-excursion's own
;; drifting marker).
(tp--replace-reactive-text-in-buffer
layer-name new-text props))))))))
(tp--map-layer-buffers layer-name where update-buffer)))
(defun tp--edit-region-minimal-diff (m-start m-end plain-text skip-props)
"Make [M-START, M-END) of the current buffer read PLAIN-TEXT.
Only the differing span of the region is edited: the common prefix
and suffix of the old and new text are left untouched. The
replacement is inserted BEFORE the old span is deleted, so markers
sitting in unchanged text keep tracking their characters - including
a marker at the first character of the preserved suffix, which the
old delete-then-insert order collapsed onto the edit start (TXT-1).
Markers whose characters were deleted end up at the end of the edit.
Does nothing when the region already reads PLAIN-TEXT, so an
identical-text update does not mark the buffer as modified.
Properties present at M-START whose keys the plist SKIP-PROPS does
not contain are re-applied over the edited span (a nil SKIP-PROPS
carries every existing property); the untouched prefix and suffix
keep their own properties as is.
Returns the cons (EDIT-START . EDIT-END) of the replaced span in
PRE-edit coordinates - the caller uses it to clamp a remembered
point that sat inside the edit - or nil when nothing was edited."
(let ((old-text (buffer-substring-no-properties m-start m-end)))
(unless (equal old-text plain-text)
;; Text content differs: trim the common prefix and suffix and
;; edit only the span that actually differs, so point and
;; markers in the unchanged parts survive the update.
(let* ((old-len (length old-text))
(new-len (length plain-text))
(min-len (min old-len new-len))
(prefix 0)
(suffix 0))
(while (and (< prefix min-len)
(eq (aref old-text prefix) (aref plain-text prefix)))
(setq prefix (1+ prefix)))
(while (and (< suffix (- min-len prefix))
(eq (aref old-text (- old-len suffix 1))
(aref plain-text (- new-len suffix 1))))
(setq suffix (1+ suffix)))
(let ((edit-start (+ m-start prefix))
(edit-end (- m-end suffix))
(insert-text (substring plain-text prefix (- new-len suffix)))
(existing-props (text-properties-at m-start)))
;; Insert first, then delete the (shifted) old span: an
;; insertion-type-nil marker at the start of the preserved
;; suffix sits strictly after EDIT-START, so the insertion
;; shifts it right with its character, and the deletion of
;; the old span just before it shifts it back into place.
(goto-char edit-start)
(insert insert-text)
(delete-region (point) (+ (point) (- edit-end edit-start)))
;; Carry over existing properties whose keys SKIP-PROPS does
;; not name onto the newly inserted span; the untouched
;; prefix and suffix keep their own properties as is.
(let ((mid-end (+ edit-start (length insert-text))))
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member skip-props key)
(put-text-property edit-start mid-end key
val))))
(cons edit-start edit-end))))))
(defun tp--pos-holds-layer-in-storage-only-p (pos layer-name)
"Return non-nil when POS holds LAYER-NAME only inside `tp-layers'.
True when the `tp-layers' stack-storage property at POS has an entry
whose `tp-name' equals LAYER-NAME while the direct `tp-name' at POS
is a different layer or absent (a hidden layer in all-hidden storage,
or a layer buried below another rendered layer)."
(and (not (equal (get-text-property pos 'tp-name) layer-name))
(cl-some (lambda (entry)
(equal (plist-get entry 'tp-name) layer-name))
(get-text-property pos 'tp-layers))
t))
(defun tp--replace-reactive-text-in-buffer (layer-name new-text props)
"Replace text in current buffer for reactive text with LAYER-NAME.
NEW-TEXT is the new text to replace with.
PROPS are the properties to apply to the new text.
Only the differing span of each region is edited: the common prefix
and suffix of the old and new text are left untouched, so point and
markers sitting in unchanged text keep their positions (point inside
the edited span ends up at the start of the edit). An identical-text
update touches no buffer text at all and does not mark the buffer as
modified.
Text properties embedded in NEW-TEXT are merged with PROPS per
embedded interval, so a multi-interval propertized reactive string
keeps its per-character styling. Existing text properties whose keys
are set neither by PROPS nor by NEW-TEXT's embedded props are
preserved, so one layer's text update does not erase other layers'
contributions on the same region.
Regions where the layer sits only inside `tp-layers' stack storage -
hidden (see `tp-hide-layer') or buried below another rendered layer -
are updated as well: text content is physical (hide/show toggles
properties, never text), so the model value still replaces the text
there, but the layer's props are not applied directly; instead its
stored stack entry, including the refreshed `tp-text', is written
through, so `tp-show-layer' or a reveal by a later stack operation
renders current values.
This function owns point restoration (callers must not wrap it in
`save-excursion', whose own marker would drift): point outside the
edits keeps tracking its character, and point inside an edited span
is clamped to the start of that edit."
(let ((plain-text (substring-no-properties new-text))
;; Remember where the user's point was; the marker tracks all
;; edits, and edits that swallow point clamp it explicitly.
(orig-point (copy-marker (point))))
(unwind-protect
(cl-flet ((edit-tracking-point (m-start m-end skip-props)
;; Run the minimal-diff edit; when the remembered
;; point sat inside the replaced span, clamp it to
;; the start of the edit (the documented
;; behavior).
(let* ((was (marker-position orig-point))
(span (tp--edit-region-minimal-diff
m-start m-end plain-text skip-props)))
(when (and span
(>= was (car span))
(< was (cdr span)))
(set-marker orig-point (car span))))))
(goto-char (point-min))
;; Pass 1: regions where the layer is the rendered top layer
;; (direct `tp-name').
(let ((match (text-property-search-forward 'tp-name
layer-name t)))
(while match
(let* ((m-start (prop-match-beginning match))
(m-end (prop-match-end match)))
(edit-tracking-point m-start m-end props)
;; Apply the layer's props, merged per embedded interval
;; of NEW-TEXT. Keys are replaced (not accumulated);
;; unrelated keys are untouched.
(tp--apply-reactive-text-props new-text props m-start)
;; Continue searching after the fully updated region: a
;; preserved suffix still carries the layer's `tp-name',
;; and restarting the search inside it would re-match
;; this region.
(goto-char (+ m-start (length plain-text))))
(setq match (text-property-search-forward 'tp-name
layer-name t))))
;; Pass 2: regions where the layer sits only inside stack
;; storage. Replace their text too, carrying ALL existing
;; properties (the visible top layer's render cache and the
;; `tp-layers' storage) over the edited span; the
;; hidden/buried layer's own props are not applied directly.
(let ((pos (point-min)))
(while (< pos (point-max))
(if (tp--pos-holds-layer-in-storage-only-p pos layer-name)
(let ((region-end pos))
(while (and (< region-end (point-max))
(tp--pos-holds-layer-in-storage-only-p
region-end layer-name))
(setq region-end (or (next-property-change
region-end)
(point-max))))
(edit-tracking-point pos region-end nil)
(setq pos (+ pos (length plain-text))))
(setq pos (or (next-property-change pos) (point-max))))))
;; Write the updated props - including the refreshed
;; `tp-text' - through to the layer's entries in stack
;; storage (HID-1).
(tp--write-layer-through-stack-storage layer-name props))
(goto-char orig-point)
(set-marker orig-point nil))))
(defun tp--reactive-apply-update (layer-name reactive-props symbol newval
where override-alist)
"Recompute LAYER-NAME's definition and re-render affected regions.
REACTIVE-PROPS are the layer's props that reference the changed
variable SYMBOL; NEWVAL is its new value. WHERE is the buffer for
`setq-local' changes, nil for global ones. OVERRIDE-ALIST maps SYMBOL
to NEWVAL (the watcher runs before the variable is actually set).
Buffer-local changes (WHERE a buffer) re-render only that buffer,
resolving the layer's props against the buffer-local values, and do
NOT touch the global layer definition, so `setq-local' cannot leak a
buffer's value into other buffers.
When `tp--batch-update-active' is non-nil the buffer update is queued
in `tp--batch-update-pending' instead of applied immediately. When
this function is re-entered from a nested variable write issued
inside an update (a computed variable being set, or the tp-text
two-way sync), the nested re-render is queued the same way and
flushed once the outermost update completes, instead of recursing.
This is the engine behind `tp--reactive-variable-watcher'; it is
installed as `tp--reactive-update-function'."
(ignore newval)
(let ((tp-text-affected (and (plist-member reactive-props 'tp-text) t)))
(if tp--reactive-updating
;; Nested change fired from within an update: queue, don't recurse.
(tp--queue-batch-update layer-name symbol where tp-text-affected)
(unwind-protect
(let ((tp--reactive-updating t))
;; Update computed properties for this layer
(let ((updated-override
(tp--update-layer-computed layer-name override-alist)))
;; Update only the reactive properties in the layer definition.
;; Buffer-local changes must not leak into the global definition;
;; the buffer re-render below resolves against the buffer-local
;; values instead.
(when (and reactive-props (not (bufferp where)))
(let ((resolved-props (tp--resolve-reactive-symbols
reactive-props updated-override))
(current-props (cdr (assoc layer-name tp-layer-alist))))
(when current-props
;; Deep merge the resolved reactive props into the current
;; layer props to preserve nested plist values (like face)
(tp--set-layer-props
layer-name
(tp--deep-merge-plist current-props resolved-props)))))
;; Update text regions with this layer (or defer if batching)
(if tp--batch-update-active
;; Batching: defer the buffer update
(progn
(tp-debug-log " Deferring buffer update for %s (batch mode)"
layer-name)
(tp--queue-batch-update layer-name symbol where
tp-text-affected))
;; Normal: update immediately
(tp-debug-log " Updating layer %s (tp-text affected: %s)"
layer-name (if tp-text-affected "yes" "no"))
(if tp-text-affected
(tp--update-reactive-text layer-name where updated-override)
(tp--update-layer-regions layer-name where updated-override)))))
;; Re-renders queued by nested variable writes during this update
;; are flushed now that the outermost update has finished. The
;; flush runs under unwind-protect so an error escaping the
;; re-render (for example from a modification hook) cannot strand
;; queued entries in the global queue (ARCH-4); the reentrancy
;; guard has been unbound by now, so the flush re-renders
;; normally.
(unless tp--batch-update-active
(when tp--batch-update-pending
(tp--flush-batch-updates)))))))
(defun tp--reactive-flush-entry (layer-name where tp-text-affected)
"Re-render LAYER-NAME's regions in WHERE (or all buffers when nil).
TP-TEXT-AFFECTED non-nil means the layer's `tp-text' changed and the
text itself must be replaced. Runs after the changed variables have
actually been set, so layer props re-resolve against current
\(buffer-local aware) values. This is the per-entry worker of
`tp--flush-batch-updates'."
(if tp-text-affected
(tp--update-reactive-text layer-name where)
(tp--update-layer-regions layer-name where)))
(defun tp--flush-batch-updates ()
"Flush all pending batch updates.
This processes all updates collected during a `tp-with-batch-updates' form."
(tp-debug-log "Flushing %d pending batch updates" (length tp--batch-update-pending))
(let ((processed-layers nil))
;; Process each pending update, avoiding duplicate layer updates
(dolist (pending (nreverse tp--batch-update-pending))
(let ((layer-name (car pending))
(where (caddr pending))
(tp-text-affected (cadddr pending)))
(unless (memq layer-name processed-layers)
(push layer-name processed-layers)
(tp-debug-log " Batch updating layer %s (tp-text: %s)"
layer-name (if tp-text-affected "yes" "no"))
(tp--reactive-flush-entry layer-name where tp-text-affected)))))
(setq tp--batch-update-pending nil))
(defmacro tp-with-batch-updates (&rest body)
"Execute BODY with reactive updates batched.
Multiple variable changes within BODY are collected and applied
together at the end, avoiding redundant buffer modifications.
This is useful when changing multiple reactive variables simultaneously:
(tp-with-batch-updates
(setq my-color \"red\")
(setq my-size 14)
(setq my-text \"Hello\"))
Without batching, each `setq' would trigger a separate buffer update.
With batching, all updates are consolidated and applied once at the end."
(declare (indent 0) (debug t))
`(let ((tp--batch-update-active t)
(tp--batch-update-pending nil))
(tp-debug-log "Starting batch updates")
(unwind-protect
(progn ,@body)
(tp-debug-log "Ending batch updates")
(tp--flush-batch-updates))))
;; Install the engine into the lower modules.
(setq tp--reactive-update-function #'tp--reactive-apply-update)
(setq tp--layer-refresh-function #'tp--update-layer-regions)
(provide 'tp-render)
;;; tp-render.el ends here

102
tp-search.el
View File

@ -20,7 +20,6 @@
(require 'cl-lib)
(require 'text-property-search)
(require 'tp-core)
(require 'tp-reactive)
(require 'tp-layer)
(require 'tp-ops)
@ -31,33 +30,16 @@ Omitting VALUE selects this sentinel automatically. Pass the variable
and any present direct value should match. An explicit nil VALUE is
therefore available for exact, presence-aware nil matching.")
(defun tp--search-register-layer-buffer (props object)
"Record OBJECT in the reactive buffer registry for PROPS's layers.
When OBJECT is a buffer or nil (the current buffer) and the applied
PROPS carry a `tp-name' - directly, or inside a `tp-layers' entry
from a group application - register that buffer under each layer name
via `tp-reactive--register-layer-buffer', so reactive updates keep
visiting buffers written through the pattern-apply paths. String
OBJECTs are not registered; see `tp-reactive-layer-buffers' for that
gap."
(when (or (null object) (bufferp object))
(let ((buf (or object (current-buffer))))
(when-let ((name (plist-get props 'tp-name)))
(tp-reactive--register-layer-buffer name buf))
(dolist (layer (plist-get props 'tp-layers))
(when-let ((name (plist-get layer 'tp-name)))
(tp-reactive--register-layer-buffer name buf))))))
(defun tp--pattern-apply-single (pattern properties apply-fn object literal
&optional start end subexp)
"Apply APPLY-FN to matches of single PATTERN in OBJECT.
"Apply PROPERTIES with APPLY-FN to matches of single PATTERN in OBJECT.
When LITERAL is non-nil, PATTERN is matched literally; otherwise it
is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for
each match.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
are swapped (matching the buffer path's historical narrow-to-region
are swapped (matching the buffer path's historical `narrow-to-region'
behavior, now uniform across object types). Matching behaves as if
OBJECT consisted only of that portion (the buffer path narrows, the
string path matches against the substring), so no match crosses the
@ -148,7 +130,7 @@ position past them, so the search always terminates."
(defun tp--pattern-apply (pattern properties apply-fn object literal
&optional start end subexp)
"Apply APPLY-FN to matches of PATTERN (one pattern or a list).
"Apply PROPERTIES with APPLY-FN to matches of PATTERN.
When LITERAL is non-nil, patterns are matched literally; otherwise
they are regexps. APPLY-FN is called with (START END PROPS OBJECT)
for each match.
@ -180,14 +162,14 @@ For buffers, returns list of regions."
(defun tp--match-apply-single (pattern properties apply-fn object
&optional start end)
"Apply APPLY-FN to literal matches of single PATTERN in OBJECT.
"Apply PROPERTIES with APPLY-FN to literal matches of PATTERN in OBJECT.
START and END restrict matching to [START, END) in native coordinates.
For strings, returns a new string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(tp--pattern-apply-single pattern properties apply-fn object t start end))
(defun tp--match-apply (pattern properties apply-fn &optional object start end)
"Internal function to apply APPLY-FN to matches of PATTERN.
"Apply PROPERTIES with APPLY-FN to matches of PATTERN.
PATTERN can be a string or a list of strings (multiple patterns).
When PATTERN is a list, each element is a pattern to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
@ -198,7 +180,7 @@ For buffers, returns list of regions."
(defun tp--regexp-apply-single (pattern properties apply-fn object
&optional start end subexp)
"Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
"Apply PROPERTIES with APPLY-FN to regexp matches of PATTERN in OBJECT.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target.
@ -209,7 +191,7 @@ For buffers, modifies in-place and returns list of regions."
(defun tp--regexp-apply (pattern properties apply-fn
&optional object start end subexp)
"Internal function to apply APPLY-FN to regexp matches of PATTERN.
"Apply PROPERTIES with APPLY-FN to regexp matches of PATTERN.
PATTERN can be a string (single regexp) or a list of strings (multiple regexps).
When PATTERN is a list, each element is a regexp to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
@ -219,40 +201,6 @@ For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(tp--pattern-apply pattern properties apply-fn object nil start end subexp))
(defun tp--deep-merge-apply (start end props obj)
"Apply PROPS to OBJ from START to END with deep merge.
Merges nested plists instead of replacing them.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place."
(if (stringp obj)
;; For strings: create a new propertized string using tp--apply-props-to-string with :add mode
(tp--apply-props-to-string obj start end props :add)
;; For buffers: modify in-place. This path stamps `tp-name' for
;; resolved layer applications, so the buffer must be registered
;; in the reactive registry or later updates would skip it (REG-1).
(tp--search-register-layer-buffer props obj)
(let ((pos start))
(while (< pos end)
(let* ((current-props (text-properties-at pos obj))
(next-pos (or (next-property-change pos obj end) end)))
(cl-loop for (key val) on props by #'cddr
do (let* ((current-val (plist-get current-props key))
(new-val
(cond
;; Face-family properties merge with the
;; incoming face taking precedence, same as
;; the string path (:add mode).
((memq key tp-face-properties)
(tp--prepend-face val current-val))
((and (listp val) (keywordp (car-safe val))
(listp current-val)
(keywordp (car-safe current-val)))
(tp--deep-merge-plist current-val val))
(t val))))
(put-text-property pos next-pos key new-val obj)))
(setq pos next-pos))))
obj))
(defun tp-match-set (pattern plist &optional object start end)
"Set properties on all occurrences of PATTERN.
@ -274,7 +222,7 @@ Returns:
- For strings: a NEW string with properties applied (the original
string is not modified)
- For buffers: list of (START . END) pairs for all matches."
(tp--match-apply pattern (tp--ensure-props plist) #'tp-set object
(tp--match-apply pattern (tp--prepare-direct-properties plist) #'tp-set object
start end))
(defun tp-match-reset (pattern plist &optional object start end)
@ -297,22 +245,10 @@ Unlike `tp-match-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
(tp--match-apply pattern (tp--ensure-props plist)
(tp--match-apply pattern (tp--prepare-direct-properties plist)
#'tp--reset-apply
object start end))
(defun tp--reset-apply (start end props obj)
"Apply PROPS to OBJ from START to END, completely replacing existing properties.
For strings, returns a NEW string.
For buffers, modifies in-place."
(if (stringp obj)
(tp--apply-props-to-string obj start end props :reset)
(set-text-properties start end props obj)
;; A resolved layer application stamps `tp-name': register the
;; buffer so reactive updates keep visiting it (REG-1).
(tp--search-register-layer-buffer props obj)
obj))
(defun tp-match-add (pattern plist &optional object start end)
"Add/update properties on all occurrences of PATTERN.
@ -333,7 +269,7 @@ Unlike `tp-match-set', this deeply merges nested properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
(tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
(tp--match-apply pattern (tp--prepare-direct-properties plist) #'tp--deep-merge-apply
object start end))
(defun tp-regexp-set (pattern plist &optional object start end subexp)
@ -362,7 +298,7 @@ Returns:
- For strings: a NEW string with properties applied (the original
string is not modified)
- For buffers: list of (START . END) pairs for all matches."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object
(tp--regexp-apply pattern (tp--prepare-direct-properties plist) #'tp-set object
start end subexp))
(defun tp-regexp-reset (pattern plist &optional object start end subexp)
@ -389,7 +325,7 @@ Unlike `tp-regexp-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
(tp--regexp-apply pattern (tp--ensure-props plist)
(tp--regexp-apply pattern (tp--prepare-direct-properties plist)
#'tp--reset-apply
object start end subexp))
@ -417,7 +353,7 @@ Unlike `tp-regexp-set', this deeply merges nested properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
(tp--regexp-apply pattern (tp--prepare-direct-properties plist) #'tp--deep-merge-apply
object start end subexp))
(defun tp-search-forward (property &optional value predicate not-current)
@ -465,7 +401,7 @@ non-nil. `tp-any-value' matches every PROP-VALUE."
(equal value prop-value))))
(defun tp--property-matches (object start end property value predicate)
"Return matching direct PROPERTY runs in OBJECT between START and END.
"Collect direct PROPERTY matches in OBJECT between START and END.
Each result is a canonical `tp--match'. A run is eligible only when
PROPERTY is present in `text-properties-at', so an explicit nil value
is distinct from absence. Boundaries caused only by unrelated
@ -528,7 +464,8 @@ Only direct PROPERTY runs are candidates. VALUE and PREDICATE follow
(tp--match-to-prop-match found))))))
(defun tp--property-search-forward (property value predicate not-current)
"Search forward once for a direct PROPERTY run from point."
"Search forward for PROPERTY matching VALUE under PREDICATE.
When NOT-CURRENT is non-nil, skip the run containing point."
(let* ((origin (point))
(found
(seq-find
@ -553,7 +490,7 @@ Only direct PROPERTY runs are candidates. VALUE and PREDICATE follow
(tp--match-to-prop-match found)))))
(defun tp--search-result-value (object start end property value)
"Return public search matches for OBJECT between START and END."
"Return matches for PROPERTY and VALUE in OBJECT between START and END."
(let* ((range (tp--native-range-from-object object start end))
(request (tp--make-request
:operation :search :range range :property property
@ -750,7 +687,7 @@ Any non-string return value leaves OBJ untouched."
;; (truncation or residue); reject it clearly instead.
(let ((len (- m-end m-start)))
(unless (= (length new-text) len)
(error "tp: replacement %S is %d chars but the match is %d; \
(error "TP: replacement %S is %d chars but the match is %d; \
strings cannot change length in place -- use a buffer OBJECT for \
length-changing replacements" new-text (length new-text) len))
(store-substring obj m-start new-text)
@ -960,6 +897,9 @@ When VALUE is omitted, match every run where PROPERTY is directly
present. An explicit nil matches only directly present nil values.
Use `tp-any-value' explicitly when OBJECT must also be supplied.
START-OR-STRING selects the range start or complete string. END-OR-PROPERTY,
PROPERTY-OR-VALUE, VALUE, and OBJECT complete the selected calling convention.
Returns a list of (START END VALUE) lists for all matching regions.
Each element contains the start position, end position, and property value."
(cond

1554
tp-stack.el
View File

File diff suppressed because it is too large Load Diff

1039
tp-style.el
View File

File diff suppressed because it is too large Load Diff

249
tp-surface.el
View File

@ -42,6 +42,9 @@
(define-error 'tp-dead-surface "Dead TP surface" 'tp-surface-error)
(define-error 'tp-invalid-range-anchor "Invalid TP range anchor"
'tp-surface-error)
(define-error 'tp-producer-buffer-mutation
"TP producer mutated a live surface buffer during prepare"
'tp-surface-error)
(define-error 'tp-scope-mismatch "Scoped TP update changed outside its objects"
'tp-surface-error)
@ -105,10 +108,12 @@
(defvar tp--surfaces (make-hash-table :test #'eql :weakness 'value))
(defvar tp--current-prepare-context nil)
(defvar tp--surface-publishing nil)
(defvar tp--surface-guarding-prepare nil)
(defvar tp--surface-publication-step-function nil)
(defvar-local tp--buffer-surfaces nil)
(defvar-local tp--surface-character-tick 0)
(defvar-local tp--surface-before-change-state nil)
(defconst tp--surface-producer-key '(tp/surface . producer))
(defconst tp--surface-extension-key 'tp-surface)
@ -119,17 +124,6 @@
(zerop (% (length value) 2))
(cl-loop for (key _value) on value by #'cddr always (symbolp key))))
(defun tp--copy-opaque-value (value)
"Defensively copy conses, vectors, and strings in VALUE."
(cond ((functionp value) value)
((stringp value) (copy-sequence value))
((consp value)
(cons (tp--copy-opaque-value (car value))
(tp--copy-opaque-value (cdr value))))
((vectorp value)
(apply #'vector (mapcar #'tp--copy-opaque-value value)))
(t value)))
(defun tp--validate-plan-fields (kind text props children capability)
"Validate plan KIND, TEXT, PROPS, CHILDREN, and CAPABILITY."
(unless kind
@ -160,17 +154,16 @@
(signal 'wrong-type-argument (list 'tp-surface-plan-p plan)))
(let* ((children (mapcar #'tp--copy-surface-plan
(tp-surface-plan-children plan)))
(kind (tp--copy-opaque-value (tp-surface-plan-kind plan)))
(text (and (tp-surface-plan-text plan)
(copy-sequence (tp-surface-plan-text plan))))
(props (tp--copy-opaque-value (tp-surface-plan-props plan)))
(kind (tp--copy-property-value (tp-surface-plan-kind plan)))
(text (tp--copy-property-value (tp-surface-plan-text plan)))
(props (tp--copy-property-value (tp-surface-plan-props plan)))
(capability (tp-surface-plan-capability plan)))
(tp--validate-plan-fields kind text props children capability)
(tp--validate-sibling-keys children)
(tp--make-surface-plan
:key (tp--copy-opaque-value (tp-surface-plan-key plan))
:key (tp--copy-property-value (tp-surface-plan-key plan))
:kind kind :text text :props props :children children
:tags (tp--copy-opaque-value (tp-surface-plan-tags plan))
:tags (tp--copy-property-value (tp-surface-plan-tags plan))
:capability capability)))
(cl-defun tp-surface-plan-create
@ -188,6 +181,20 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
"Return a producer result containing PLAN and opaque CLIENT-STATE."
(tp--make-surface-result (tp--copy-surface-plan plan) client-state))
(defun tp--property-value-equal-p (property left right)
"Return non-nil when PROPERTY values LEFT and RIGHT are policy-equal."
(funcall (tp-property-policy-equality (tp-register-text-property property))
left right))
(defun tp--plan-props-equal-p (left right)
"Return non-nil when text property plists LEFT and RIGHT are policy-equal."
(and (= (length left) (length right))
(cl-loop for (property value) on left by #'cddr
for cell = (plist-member right property)
always (and cell
(tp--property-value-equal-p
property value (cadr cell))))))
(defun tp--plan-equal-p (left right)
"Return non-nil when LEFT and RIGHT plans are semantically equal."
(and (equal (tp-surface-plan-key left) (tp-surface-plan-key right))
@ -197,7 +204,8 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
(if (and (stringp a) (stringp b))
(equal-including-properties a b)
(equal a b)))
(equal (tp-surface-plan-props left) (tp-surface-plan-props right))
(tp--plan-props-equal-p (tp-surface-plan-props left)
(tp-surface-plan-props right))
(equal (tp-surface-plan-tags left) (tp-surface-plan-tags right))
(eq (tp-surface-plan-capability left)
(tp-surface-plan-capability right))
@ -235,7 +243,7 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
position))
(defun tp--object-path-segment (context parent key kind)
"Return the candidate path segment for KEY and KIND below PARENT."
"Return CONTEXT's candidate path segment for KEY and KIND below PARENT."
(if key
(let ((seen (tp--context-child-table context parent)))
(when (gethash key seen)
@ -262,11 +270,11 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
(signal 'tp-invalid-prepare-context (list context))))
(defun tp--new-candidate-object (context parent key kind path)
"Create a candidate object in CONTEXT below PARENT at PATH."
"Create a candidate object for KEY and KIND in CONTEXT below PARENT at PATH."
(let ((object (tp--make-surface-object
:id (cl-incf tp--object-id-counter)
:surface (tp--context-surface context) :parent parent
:key (tp--copy-opaque-value key) :kind kind :path path
:key (tp--copy-property-value key) :kind kind :path path
:candidate-context context)))
(push object (tp--context-new-objects context))
object))
@ -313,7 +321,8 @@ remain private so callers cannot mutate TP's publication coordinates."
(lambda (mount)
(list :start (marker-position (tp--surface-mount-start mount))
:end (marker-position (tp--surface-mount-end mount))
:tags (tp--copy-opaque-value (tp--surface-mount-tags mount))))
:tags (tp--copy-property-value
(tp--surface-mount-tags mount))))
mounts)))
(defun tp--make-context (surface &optional ephemeral)
@ -343,7 +352,7 @@ When EPHEMERAL is non-nil, no identity may be promoted."
(signal 'tp-stale-object (list object))))
(defun tp-object-retain (context object)
"Declare candidate OBJECT live even when it owns no output fragment."
"Retain candidate OBJECT in CONTEXT even when it owns no output fragment."
(tp--validate-context-object context object)
(puthash object t (tp--context-retained context))
object)
@ -362,7 +371,7 @@ marker-backed mounts after publication."
(when (assq object attachments)
(signal 'tp-surface-error (list :duplicate-fragment object fragment)))
(puthash fragment
(cons (cons object (tp--copy-opaque-value tags)) attachments)
(cons (cons object (tp--copy-property-value tags)) attachments)
(tp--context-fragment-attachments context)))
(tp-object-retain context object))
@ -377,9 +386,11 @@ marker-backed mounts after publication."
(defun tp--plist-overlay (parent child)
"Return a fresh plist where CHILD values override PARENT values."
(let ((result (copy-tree parent)))
(let ((result (tp--copy-property-value parent)))
(cl-loop for (property value) on child by #'cddr
do (setq result (plist-put result property value)))
do (setq result
(plist-put result property
(tp--copy-property-value value))))
result))
(defun tp--plan-segment (plan position)
@ -445,7 +456,7 @@ marker-backed mounts after publication."
(nreverse paths)))
(defun tp--validate-context-tree (context plan)
"Validate CONTEXT's planned, retained, and fragment object paths."
"Validate PLAN and CONTEXT's retained and fragment object paths."
(let ((expected (make-hash-table :test #'equal))
(actual (make-hash-table :test #'equal)))
(dolist (path (tp--plan-paths plan)) (puthash path t expected))
@ -552,7 +563,7 @@ marker-backed mounts after publication."
"Return one content mount spec for OBJECT over RECORD with TAGS."
(list :object object :start (plist-get record :start)
:end (plist-get record :end)
:tags (tp--copy-opaque-value
:tags (tp--copy-property-value
(if tags tags (plist-get record :tags)))))
(defun tp--content-mount-specs (records context)
@ -579,12 +590,12 @@ marker-backed mounts after publication."
(tp--properties-mount-specs records context)))
(defun tp--ranges-overlap-p (left-start left-end right-start right-end)
"Return non-nil when the two nonempty half-open ranges overlap."
"Return non-nil when LEFT-START..LEFT-END overlaps RIGHT-START..RIGHT-END."
(and (< left-start left-end) (< right-start right-end)
(< left-start right-end) (< right-start left-end)))
(defun tp--candidate-ranges (surface mount-specs rendered)
"Return absolute candidate ranges for SURFACE."
"Return SURFACE ranges described by MOUNT-SPECS and RENDERED."
(if (eq (tp--surface-capability surface) 'content)
(let ((start (marker-position (tp--surface-start surface))))
(list (cons start (+ start (length rendered)))))
@ -593,7 +604,7 @@ marker-backed mounts after publication."
mount-specs)))
(defun tp--validate-cross-surface-ranges (surface mount-specs rendered)
"Reject overlapping ownership between SURFACE and other live surfaces."
"Reject MOUNT-SPECS and RENDERED when SURFACE overlaps another surface."
(let ((ranges (tp--candidate-ranges surface mount-specs rendered)))
(with-current-buffer (tp--surface-buffer surface)
(dolist (other tp--buffer-surfaces)
@ -620,6 +631,23 @@ marker-backed mounts after publication."
(tp--ensure-plan-objects context plan)
(tp--producer-result plan surface options)))))
(defun tp--call-with-prepare-buffer-guard (surface function)
"Call FUNCTION while rejecting producer edits to SURFACE's buffer."
(let* ((buffer (tp--surface-buffer surface))
(before-tick (with-current-buffer buffer
(buffer-modified-tick)))
(group (tp--prepare-change-group-for-buffers (list buffer)))
(tp--surface-guarding-prepare t))
(unwind-protect
(let ((result (funcall function)))
(unless (= before-tick
(with-current-buffer buffer
(buffer-modified-tick)))
(signal 'tp-producer-buffer-mutation
(list (tp--surface-id surface))))
result)
(tp--cancel-change-group-safely group))))
(defun tp--normalize-surface-scopes (surface objects)
"Return validated retained OBJECTS owned by SURFACE."
(unless (and (proper-list-p objects) objects)
@ -720,7 +748,7 @@ When RELATIVE is non-nil, return offsets from the surface start."
(nreverse pairs)))
(defun tp--scope-patches-between-anchors (old new anchors)
"Return changes between equal outside ANCHORS in OLD and NEW."
"Return patches between equal outside ANCHORS in OLD and NEW."
(let ((old-position 0) (new-position 0) patches)
(dolist (anchor (append anchors
(list (list (length old) (length old)
@ -739,7 +767,8 @@ When RELATIVE is non-nil, return offsets from the surface start."
(nreverse patches)))
(defun tp--scope-replacement-analysis (old new old-ranges new-ranges)
"Return scoped replacement metadata from OLD to NEW, or nil on mismatch."
"Compare OLD-RANGES and NEW-RANGES from OLD to NEW.
Return scoped replacement metadata, or nil on mismatch."
(let* ((old-outside (tp--complement-ranges (length old) old-ranges))
(new-outside (tp--complement-ranges (length new) new-ranges)))
(when (equal-including-properties
@ -815,7 +844,11 @@ OPTIONS configure the mount and INITIAL is non-nil for first publication."
(success nil)
result)
(unwind-protect
(let* ((normalized (tp--prepare-input surface input options context))
(let* ((normalized
(tp--call-with-prepare-buffer-guard
surface
(lambda ()
(tp--prepare-input surface input options context))))
(plan (car normalized))
(client-state (cdr normalized))
(_capability (tp--validate-plan-capability
@ -918,7 +951,8 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
:start (marker-position (tp--anchor-start anchor))
:end (marker-position (tp--anchor-end anchor))
:props (plist-get record :props)
:tags (tp--copy-opaque-value (plist-get record :tags)))
:tags (tp--copy-property-value
(plist-get record :tags)))
specs))))
(maphash
(lambda (object _anchor)
@ -940,6 +974,12 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(and (eq (car left) (car right))
(equal (cdr left) (cdr right))))
(defun tp--property-state-policy-equal-p (property left right)
"Return non-nil when PROPERTY states LEFT and RIGHT are policy-equal."
(and (eq (car left) (car right))
(or (not (car left))
(tp--property-value-equal-p property (cdr left) (cdr right)))))
(defun tp--ledger-position (marker)
"Return live MARKER position or signal a stale-mount error."
(or (marker-position marker)
@ -965,24 +1005,31 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
properties))
(defun tp--property-boundaries (buffer mount-specs surface properties)
"Return sorted candidate interval boundaries in BUFFER."
(let (boundaries)
"Return sorted interval boundaries in BUFFER.
MOUNT-SPECS and SURFACE provide ranges for PROPERTIES."
(let (boundaries intervals)
(dolist (spec mount-specs)
(push (plist-get spec :start) boundaries)
(push (plist-get spec :end) boundaries))
(let ((start (plist-get spec :start))
(end (plist-get spec :end)))
(push start boundaries)
(push end boundaries)
(push (cons start end) intervals)))
(dolist (entry (tp--surface-ledger surface))
(push (tp--ledger-position (tp--property-ledger-start entry)) boundaries)
(push (tp--ledger-position (tp--property-ledger-end entry)) boundaries))
(let ((start (tp--ledger-position (tp--property-ledger-start entry)))
(end (tp--ledger-position (tp--property-ledger-end entry))))
(push start boundaries)
(push end boundaries)
(push (cons start end) intervals)))
(setq boundaries (sort (delete-dups boundaries) #'<))
(when boundaries
(let ((minimum (car boundaries)) (maximum (car (last boundaries))))
(with-current-buffer buffer
(dolist (interval (tp--coalesce-ranges intervals))
(dolist (property properties)
(let ((position minimum))
(let ((position (car interval))
(maximum (cdr interval)))
(while (< position maximum)
(setq position (next-single-property-change
position property buffer maximum))
(push position boundaries)))))))
(push position boundaries))))))
(sort (delete-dups boundaries) #'<)))
(defun tp--covering-contributions (mount-specs start end property)
@ -997,7 +1044,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(defun tp--merge-property-contributions (baseline contributions property)
"Merge PROPERTY CONTRIBUTIONS over BASELINE property state."
(let ((state baseline)
(merge (tp-property-schema-merge
(merge (tp-property-policy-merge
(tp-register-text-property property))))
(dolist (spec contributions)
(let ((value (plist-get (plist-get spec :props) property)))
@ -1023,14 +1070,14 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(defun tp--property-segment-result
(surface mount-specs start end property)
"Prepare one PROPERTY segment from START to END for SURFACE."
"Prepare one PROPERTY segment from START to END for SURFACE and MOUNT-SPECS."
(let* ((buffer (tp--surface-buffer surface))
(current (tp--property-state-at buffer start property))
(old (tp--old-ledger-at surface start property))
(contributions
(tp--covering-contributions mount-specs start end property)))
(when (and old (not (tp--property-state-equal-p
current (tp--ledger-published-state old))))
(when (and old (not (tp--property-state-policy-equal-p
property current (tp--ledger-published-state old))))
(signal 'tp-property-conflict
(list (tp--surface-id surface) start end property current)))
(let* ((baseline (tp--ledger-baseline-state old current))
@ -1040,7 +1087,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(mapcar (lambda (spec) (plist-get spec :anchor))
contributions))))
(list :operation
(unless (tp--property-state-equal-p current target)
(unless (tp--property-state-policy-equal-p property current target)
(list :start start :end end :property property
:present (car target) :value (cdr target)))
:ledger
@ -1052,7 +1099,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
:published-value (cdr target) :anchors anchors))))))
(defun tp--prepare-property-ledger (surface mount-specs)
"Return candidate ledger specs and property operations for SURFACE."
"Return ledger specs and property operations for SURFACE and MOUNT-SPECS."
(let* ((buffer (tp--surface-buffer surface))
(properties (tp--contribution-properties mount-specs surface))
(boundaries (tp--property-boundaries
@ -1117,7 +1164,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(cons start end)))
(defun tp--create-surface (buffer capability options)
"Create an unmounted surface candidate for BUFFER."
"Create an unmounted BUFFER surface with CAPABILITY and OPTIONS."
(unless (memq capability '(content properties))
(signal 'tp-capability-error (list capability)))
(when (buffer-base-buffer buffer)
@ -1131,14 +1178,15 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(tp--make-surface
:id (cl-incf tp--surface-id-counter) :buffer buffer
:capability capability :start (copy-marker (car range) nil)
:end (copy-marker (cdr range) t) :options (copy-tree options)
:end (copy-marker (cdr range) t)
:options (tp--copy-property-value options)
:objects (make-hash-table :test #'equal) :mounts nil :index nil
:mount-index (make-hash-table :test #'eq)
:ledger nil :revision 0 :live nil :stale nil
:observers (copy-sequence (plist-get options :observers)))))
(defun tp--surface-compute-function (surface input options initial)
"Return the producer binding function for SURFACE and INPUT."
"Return SURFACE's producer binding for INPUT, OPTIONS, and INITIAL state."
(lambda ()
(tp--prepare-surface
surface input options (and initial (not (tp--surface-live surface))))))
@ -1242,37 +1290,63 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
surface objects (list :on-mismatch on-mismatch)))))
(tp-surface-report surface))
(defun tp--edit-touches-span-p (beg old-length start end)
"Return non-nil when an external edit at BEG touches START..END."
(if (zerop old-length)
(defun tp--edit-touches-span-p (beg edit-end start end)
"Return non-nil when BEG..EDIT-END touches the old START..END span."
(if (= beg edit-end)
(and (> beg start) (< beg end))
(and (>= beg start) (< beg end))))
(and (< beg end) (> edit-end start))))
(defun tp--mark-anchor-after-edit (anchor beg old-length)
"Apply ANCHOR's boundary policy after an edit at BEG."
(let ((start (marker-position (tp--anchor-start anchor)))
(end (marker-position (tp--anchor-end anchor))))
(when (and start end (tp--edit-touches-span-p beg old-length start end))
(defun tp--surface-before-change (beg end)
"Capture retained ranges before a BUFFER edit from BEG to END."
(setq tp--surface-before-change-state nil)
(unless (or tp--surface-publishing tp--surface-guarding-prepare)
(let ((anchors (make-hash-table :test #'eq)) content anchor-ranges)
(dolist (surface tp--buffer-surfaces)
(when (tp-surface-live-p surface)
(if (eq (tp--surface-capability surface) 'content)
(pcase-let ((`(,start . ,finish) (tp--surface-range surface)))
(push (list surface start finish) content))
(dolist (mount (tp--surface-mounts surface))
(when-let ((anchor (tp--surface-mount-anchor mount)))
(unless (gethash anchor anchors)
(puthash anchor t anchors)
(push (list anchor
(marker-position (tp--anchor-start anchor))
(marker-position (tp--anchor-end anchor)))
anchor-ranges)))))))
(setq tp--surface-before-change-state
(list :beg beg :end end
:content content :anchors anchor-ranges)))))
(defun tp--mark-anchor-from-old-range (entry beg end)
"Apply ENTRY anchor policy for an old edit range BEG..END."
(pcase-let ((`(,anchor ,start ,finish) entry))
(when (and start finish
(tp--edit-touches-span-p beg end start finish))
(pcase (tp--anchor-boundary-policy anchor)
('shorten nil)
('remove (setf (tp--anchor-stale anchor) 'remove))
(_ (setf (tp--anchor-stale anchor) t))))))
(defun tp--surface-after-change (beg _end old-length)
"Maintain retained mount staleness after a host edit at BEG."
(defun tp--surface-after-change (_beg _end _old-length)
"Maintain mount staleness after a host text edit."
(let* ((tick (buffer-chars-modified-tick))
(character-change (/= tick tp--surface-character-tick)))
(character-change (/= tick tp--surface-character-tick))
(state tp--surface-before-change-state))
(setq tp--surface-character-tick tick)
(when (and character-change (not tp--surface-publishing))
(dolist (surface tp--buffer-surfaces)
(when (tp-surface-live-p surface)
(if (eq (tp--surface-capability surface) 'content)
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
(when (tp--edit-touches-span-p beg old-length start end)
(setf (tp--surface-stale surface) t)))
(dolist (mount (tp--surface-mounts surface))
(when-let ((anchor (tp--surface-mount-anchor mount)))
(tp--mark-anchor-after-edit anchor beg old-length)))))))))
(setq tp--surface-before-change-state nil)
(when (and character-change state
(not tp--surface-publishing)
(not tp--surface-guarding-prepare))
(let ((old-beg (plist-get state :beg))
(old-end (plist-get state :end)))
(dolist (entry (plist-get state :content))
(pcase-let ((`(,surface ,start ,end) entry))
(when (and (tp-surface-live-p surface)
(tp--edit-touches-span-p old-beg old-end start end))
(setf (tp--surface-stale surface) t))))
(dolist (entry (plist-get state :anchors))
(tp--mark-anchor-from-old-range entry old-beg old-end))))))
(defun tp--surface-buffer-killed ()
"Dispose every retained surface owned by the current buffer."
@ -1286,6 +1360,7 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
(with-current-buffer (tp--surface-buffer surface)
(cl-pushnew surface tp--buffer-surfaces :test #'eq)
(setq tp--surface-character-tick (buffer-chars-modified-tick))
(add-hook 'before-change-functions #'tp--surface-before-change nil t)
(add-hook 'after-change-functions #'tp--surface-after-change nil t)
(add-hook 'kill-buffer-hook #'tp--surface-buffer-killed nil t)))
@ -1317,7 +1392,8 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
(defun tp--set-surface-scope-request (surface objects options)
"Set SURFACE's one-shot scope request to OBJECTS and OPTIONS."
(puthash surface
(list :objects (copy-sequence objects) :options (copy-tree options))
(list :objects (copy-sequence objects)
:options (tp--copy-property-value options))
(tp--surface-scope-table t)))
(defun tp--surface-prepared-table ()
@ -1376,7 +1452,7 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
(tp--prepared-surface-rendered prepared))))))))
(defun tp--prepared-changed-p (prepared)
"Return non-nil when PREPARED changes its committed surface."
"Return non-nil when PREPARED differs from its committed surface."
(let ((surface (tp--prepared-surface-surface prepared)))
(or (tp--prepared-surface-initial prepared)
(not (tp--plan-equal-p (tp--surface-plan surface)
@ -1440,9 +1516,11 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
(if (equal old new) 0 1)))
(defun tp--string-property-run-diff-p (buffer start rendered from to)
"Return non-nil when BUFFER differs from RENDERED on FROM..TO."
"Return non-nil when BUFFER at START differs from RENDERED on FROM..TO."
(cl-loop for offset from from below to
thereis (not (equal (text-properties-at (+ start offset) buffer)
thereis
(not (tp--plan-props-equal-p
(text-properties-at (+ start offset) buffer)
(text-properties-at offset rendered)))))
(defun tp--content-property-operations-in-range
@ -1590,7 +1668,7 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set."
table))
(defun tp--surface-report-value (prepared text-ops property-ops)
"Build PREPARED's generic commit report."
"Build PREPARED's report from TEXT-OPS and PROPERTY-OPS."
(let* ((surface (tp--prepared-surface-surface prepared))
(old-revision (tp--surface-revision surface))
(new-revision (1+ old-revision))
@ -1874,6 +1952,7 @@ Return the number of text operations."
(with-current-buffer (tp--surface-buffer surface)
(setq tp--buffer-surfaces (delq surface tp--buffer-surfaces))
(unless tp--buffer-surfaces
(remove-hook 'before-change-functions #'tp--surface-before-change t)
(remove-hook 'after-change-functions #'tp--surface-after-change t)
(remove-hook 'kill-buffer-hook #'tp--surface-buffer-killed t)))))
@ -2053,7 +2132,7 @@ Return the number of text operations."
(defun tp--record-observer-error (surface observer failure)
"Record OBSERVER FAILURE in SURFACE's latest report."
(let ((report (copy-tree (tp--surface-report surface))))
(let ((report (tp--copy-property-value (tp--surface-report surface))))
(setq report
(plist-put report :observer-errors
(append (plist-get report :observer-errors)
@ -2075,7 +2154,7 @@ Return the number of text operations."
(lambda () (tp--run-surface-observers surface observers report)))))
(defun tp--surface-commit-transaction ()
"Accept buffer changes and finalize every transaction surface."
"Commit buffer edits and finalize every transaction surface."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let ((group (gethash 'change-group state)))
(accept-change-group group))
@ -2162,7 +2241,7 @@ Return the number of text operations."
anchor)
(defun tp--unmount-ledger-segments (surface entry)
"Return restoration operations and conflicts for one ledger ENTRY."
"Return SURFACE restoration operations and conflicts for ledger ENTRY."
(let* ((buffer (tp--surface-buffer surface))
(start (tp--ledger-position (tp--property-ledger-start entry)))
(end (tp--ledger-position (tp--property-ledger-end entry)))
@ -2322,7 +2401,7 @@ owns the property; conflicting host values are preserved and reported."
"Return a defensive copy of SURFACE's latest generic commit report."
(unless (tp-surface-p surface)
(signal 'wrong-type-argument (list 'tp-surface-p surface)))
(copy-tree (tp--surface-report surface)))
(tp--copy-property-value (tp--surface-report surface)))
(defun tp-surface-inspect (surface)
"Return read-only retained diagnostics for SURFACE."

30
tp.el
View File

@ -1,11 +1,11 @@
;;; tp.el --- Text Properties manipulation library for Emacs Lisp -*- lexical-binding: t -*-
;;; tp.el --- Retained reactive text runtime -*- lexical-binding: t -*-
;; Copyright (C) 2024-2026 Geekinney
;; Version: 0.3.0
;; Version: 1.0.0
;; Keywords: convenience text-properties
;; Author: Geekinney (kinneyzhang666@gmail.com)
;; Package-Requires: ((emacs "28.1") (dash "2.19.1"))
;; Package-Requires: ((emacs "28.1"))
;; URL: https://github.com/Kinneyzhang/tp
;; This program is free software; you can redistribute it and/or
@ -15,28 +15,26 @@
;;; Commentary:
;; tp.el is a comprehensive text property manipulation library.
;; TP projects declarative properties, reactive data, and retained text
;; objects onto Emacs strings and buffers.
;;
;; It is organized as a stack of modules, each depending only on the
;; ones before it:
;;
;; 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 Exact signals, bindings, transactions, scoped variable
;; adapters, plus temporary legacy layer watcher state.
;; tp-core.el Foundation: ranges, intervals, plist/face merge,
;; canonical requests/results, and debug logging.
;; tp-style.el Native property policies, contribution composition,
;; named declarations, and explicit computed values.
;; tp-reactive.el Exact signals, bindings, transactions, and scoped variable
;; adapters.
;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes,
;; and atomic buffer publication.
;; tp-layer.el Layer registry: `define-tp', `define-tps',
;; layer/group resolution and expansion.
;; tp-layer.el Named declaration recipes: `define-tp', `define-tps',
;; and direct property expansion.
;; tp-ops.el Core primitives: `tp-set', `tp-reset', `tp-add',
;; `tp-get', `tp-at', `tp-remove', `tp-clear'.
;; tp-search.el Pattern matching (`tp-match-*', `tp-regexp-*') and
;; property search/navigation (`tp-search', ...).
;; tp-render.el Reactive re-rendering engine (installs itself into
;; tp-reactive and tp-ops).
;; tp-stack.el Layer stack operations: push/pop/move/merge/...
;; tp-query.el Native lookup/change wrappers and mutation policy.
;; tp-palette.el Color palette data (light/dark aware).
;; tp-builtins.el Built-in layers (tp-fg, tp-link, tp-action, ...)
@ -60,8 +58,6 @@
(require 'tp-layer)
(require 'tp-ops)
(require 'tp-search)
(require 'tp-render)
(require 'tp-stack)
(require 'tp-query)
(require 'tp-palette)
(require 'tp-builtins)