Compare commits

..

No commits in common. "main" and "dev/0.3.0" have entirely different histories.

63 changed files with 24426 additions and 21746 deletions

View File

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

1
.gitignore vendored
View File

@ -1,6 +1,5 @@
# Dependencies # Dependencies
dash.el dash.el
postmortem
# Emacs compiled files # Emacs compiled files
*.elc *.elc

View File

@ -2,51 +2,6 @@
All notable changes to the tp library are documented here. All notable changes to the tp library are documented here.
## 2.0.0 (Unreleased)
### Added
- 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.
- Transaction protocol v2: transaction-scoped publication batches, structured
participants, bounded opaque final-accept markers using the closed
`tp-vector-slots/v1` primitive, immutable tagged outcomes, and one live writer.
- `tp-runtime-manifest`, advertising `tp-transaction-protocol-v2` and package
version 2.0.0.
- Public `tp-transaction-participate-v2` registration for cross-package
structured participants.
- 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
- Structured publication batches own the single live surface-entry loop,
participant stage/precommit/commit vector, and candidate-bound final accept.
- Package metadata now identifies the v2-only breaking transaction contract.
- `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
- The public `tp-transaction-participate` v1 facade. Replace
`(tp-transaction-participate KEY PUBLISH ROLLBACK)` with
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`.
- The v1 publication writer, execution-route kill switch, artifact-mode switch,
and their runtime manifest claims.
- `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) ## 0.3.0 (2026-07-27)
### Added ### Added

View File

@ -3,63 +3,31 @@
# Usage: # Usage:
# make test # run all ERT test suites # make test # run all ERT test suites
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces) # make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
# make test-m0a # run current TP completion characterization
# make test-m1a # run additive transaction contract + fault gates
# make test-c1b # run the v2-only transaction regression gate
# make doctest # execute README examples against the code # make doctest # execute README examples against the code
# make benchmark # run reproducible correctness-first benchmarks
# make compile # byte-compile the library modules # make compile # byte-compile the library modules
# make compile-all # byte-compile modules + tests + dev scripts # 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 # make clean # remove compiled files
# #
# WERROR=t turns byte-compile warnings into errors (used in CI). # WERROR=t turns byte-compile warnings into errors (used in CI).
# LOAD_EXTRA can add optional development-tool load paths such as package-lint. # 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"
EMACS ?= emacs EMACS ?= emacs
LOAD_EXTRA ?= LOAD_EXTRA ?=
WERROR ?= nil WERROR ?= nil
TEST_DIR = tests LOADPATH = -L . $(LOAD_EXTRA)
LOADPATH = -L . -L $(TEST_DIR) -L examples $(LOAD_EXTRA)
SRC = tp-core.el tp-style.el tp-transaction.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.el \ SRC = tp-core.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \
tp-query.el tp-palette.el tp-builtins.el tp.el tp-render.el tp-stack.el tp-palette.el tp-builtins.el tp.el
TESTS = $(wildcard $(TEST_DIR)/*-tests.el) TESTS = $(wildcard *-tests.el)
TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el DEV = tp-doctest.el tp-run-shuffled.el
EXAMPLES = $(wildcard examples/*.el)
DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el
.PHONY: test test-m0a test-m1a test-c1b test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean .PHONY: test test-shuffled doctest compile compile-all clean
test: test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
-f ert-run-tests-batch-and-exit -f ert-run-tests-batch-and-exit
test-m0a:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
-l $(TEST_DIR)/tp-binding-tests.el \
-l $(TEST_DIR)/tp-surface-tests.el \
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
--eval '(ert-run-tests-batch-and-exit "tp-m0a-characterization-test-\\|tp-binding-test-signal-commit-journal-rolls-back-every-write\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-global-signal-update-is-multi-surface-atomic\\|tp-surface-test-full-and-scoped-precommit-stages-roll-back\\|tp-surface-test-full-and-scoped-final-accept-roll-back")'
test-m1a:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
-l $(TEST_DIR)/tp-binding-tests.el \
-l $(TEST_DIR)/tp-surface-tests.el \
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
-l $(TEST_DIR)/tp-transaction-tests.el \
--eval '(ert-run-tests-batch-and-exit "tp-transaction-test-\\|tp-m0a-characterization-test-\\|tp-binding-test-signal-commit-journal-rolls-back-every-write\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-global-signal-update-is-multi-surface-atomic\\|tp-surface-test-full-and-scoped-precommit-stages-roll-back\\|tp-surface-test-full-and-scoped-final-accept-roll-back")'
test-c1b:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
-l $(TEST_DIR)/tp-binding-tests.el \
-l $(TEST_DIR)/tp-surface-tests.el \
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
-l $(TEST_DIR)/tp-transaction-tests.el \
--eval '(ert-run-tests-batch-and-exit "tp-transaction-test-\\|tp-m0a-characterization-test-participant-failure-preserves-condition\\|tp-binding-test-participant-key-is-owned-by-transaction\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-transaction-participant\\|tp-surface-test-failing-participant")'
test-shuffled: test-shuffled:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
-l tp-run-shuffled.el -l tp-run-shuffled.el
@ -67,9 +35,6 @@ test-shuffled:
doctest: doctest:
$(EMACS) -Q --batch $(LOADPATH) -l tp-doctest.el $(EMACS) -Q --batch $(LOADPATH) -l tp-doctest.el
benchmark:
$(EMACS) -Q --batch $(LOADPATH) -l tp-benchmark.el -f tp-benchmark-run
compile: clean compile: clean
$(EMACS) -Q --batch $(LOADPATH) \ $(EMACS) -Q --batch $(LOADPATH) \
--eval "(setq byte-compile-error-on-warn $(WERROR))" \ --eval "(setq byte-compile-error-on-warn $(WERROR))" \
@ -80,14 +45,5 @@ compile-all: clean
--eval "(setq byte-compile-error-on-warn $(WERROR))" \ --eval "(setq byte-compile-error-on-warn $(WERROR))" \
-f batch-byte-compile $(SRC) $(TESTS) $(DEV) -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: clean:
rm -f *.elc $(TEST_DIR)/*.elc examples/*.elc rm -f *.elc

4307
README.md

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -1,646 +0,0 @@
# TP 2.0 公共 API 与用法参考
本文是 TP 当前实现的完整公共入口索引。它以 tp.el 加载的模块为准;带
tp-- 前缀的函数、变量和结构体是内部实现,不属于本文的稳定 API。
- 快速开始与能力边界:[README](../README.md)、[中文 README](../README_CN.md)
- 语义合同:[API-SEMANTICS.md](API-SEMANTICS.md)
- 当前架构:[ARCHITECTURE.md](ARCHITECTURE.md)
- 可运行示例:[examples/](../examples/)
## 1. 运行边界
TP 只负责 Emacs text properties、响应式 signal/binding、retained object、
marker-backed mount、diff、事务和 Buffer publication。它不实现 CSS selector、
stylesheet、specificity、cascade、Box、Flex、Grid、测量或布局也不依赖
Ebox/ECSS。
所有坐标都遵循 Emacs 原生对象的坐标规则:
- string 使用从 0 开始的 [start, end)
- buffer 使用从 1 开始的 [start, end)
- tp-surface-plan 中的 content leaf range 是相对于该 leaf 文本的
0-based offset不是 Buffer position。
普通函数值、callback、keymap command 和 list 都是 literal data。只有显式的
tp-computed source 会被执行。显式存在且值为 nil 与属性不存在始终不同。
## 2. 先选入口
| 目标 | 入口 | 是否建立 live state |
| --- | --- | --- |
| 创建带属性的 string | tp-propertize | 否 |
| 一次性改已有范围 | tp-apply、tp-set、tp-reset、tp-add、tp-remove、tp-clear | 否 |
| 查询属性和区间 | tp-get、tp-at、tp-member、tp-lookup | 否 |
| 按文字或属性搜索 | tp-match-*、tp-regexp-*、tp-search*、tp-forward/backward | 否 |
| 让已有 host text 响应变化 | tp-watch | 是properties |
| 管理 TP 自己拥有的文字 | tp-surface-mount / tp-surface-update | 是content |
| 检查或卸载 publication | tp-surface-inspect / tp-surface-report / tp-surface-unmount | 是 |
| 定义可复用声明 | define-tp、define-tps | 只建立 recipe不建立 live state |
| 定义主题颜色 | define-tp-palette | 只更新 palette registry |
安装只需要把仓库加入 load-path
~~~elisp
(add-to-list 'load-path "/path/to/tp")
(require 'tp)
~~~
tp.el 会加载所有运行时模块。单独加载模块只适合包开发或测试。
## 3. 一次性文本属性操作
### 3.1 创建和应用
~~~elisp
(tp-propertize
"Hello"
'(face bold help-echo "greeting" keymap nil))
(with-current-buffer (get-buffer-create "*tp-demo*")
(erase-buffer)
(insert "abcdef")
(tp-apply (current-buffer) 2 5 '(face italic)))
~~~
tp-propertize 返回原 string 的副本tp-apply 保留范围内未出现在
declarations 中的其他属性,并返回 (START . END)。
declarations 可以是原生 property plist、define-tp recipe、recipe call
或包含 recipe key 的 plist。tp-apply 和下面的直接操作不会创建 object、
binding、marker、subscription 或 surface。
### 3.2 set/reset/add/remove/clear
对完整 string 的形式会返回新 string对 Buffer 范围的形式会原地修改,并
返回 (START . END)tp-remove 和 tp-clear 的 Buffer 形式返回 nil
~~~elisp
;; stringproperty/value 形式,原 string 不变
(tp-set "item" 'face 'bold)
(tp-reset "item" 'face 'italic)
(tp-add "item" 'face 'underline)
(tp-remove (tp-set "item" 'face 'bold) 'face)
;; buffer 或 string 范围:一个 direct property plist可选 OBJECT
(tp-set start end '(face bold help-echo "tip") buffer)
(tp-reset start end '(face italic) buffer)
(tp-add start end '(face (:weight bold)) buffer)
(tp-remove start end 'help-echo buffer)
(tp-clear start end buffer)
~~~
- tp-set 替换所指定的顶层属性;
- tp-reset 用 declarations 完全替换范围内所有属性;
- tp-add 合并属性face、font-lock-face、mouse-face 支持 contribution
合成和嵌套 plist 合并;
- tp-remove 支持移除顶层属性,也支持 (property sub-key) 或
(property sub-key nested-key...)
- tp-clear 移除范围内全部 text properties。
## 4. 声明、property policy 和 recipe
### 4.1 Property policy
~~~elisp
(tp-define-property-policy
'text/my-property
:normalizer #'identity
:validator (lambda (_value) t)
:equality #'equal
:merge (lambda (_old new) new)
:projector #'identity)
(tp-property-policy 'text/my-property)
(tp-register-text-property 'help-echo)
(tp-text-property-id 'help-echo)
(tp-text-declarations '(face bold help-echo "tip"))
~~~
tp-define-property-policy 的 id 必须是包含 / 的 canonical symbol。可选策略
为 :normalizer、:validator、:equality、:merge、:projector。注册是原子的
无效策略不会替换旧定义。
- tp-register-text-property 为原生 Emacs property 安装默认 policy
- tp-text-property-id 把原生 property 映射为 text/PROPERTY
- tp-text-declarations 把原生 plist 转成 canonical declarations
- tp-merge-declarations 按参数顺序合并 direct declaration groups后者
覆盖前者,并保留显式 nil
- tp-computed 把一个函数标记为唯一允许执行的 value source
- tp-resolve-value 解析 literal 或显式 computed value
- tp-define-style、tp-style-declarations、tp-undefine-style 管理已归一化的
命名 direct style。
### 4.2 静态 recipe
~~~elisp
(define-tp link-style (color)
(list 'face (list :foreground color :weight 'bold)
'mouse-face 'highlight))
(define-tps status-group ()
link-style
'(help-echo "status"))
(tp-set 1 5 '(link-style "#58a6ff") buffer)
(tp-layer-props-with-arg 'link-style "#58a6ff")
(tp-group-props 'status-group)
~~~
入口及别名:
- define-tp别名 tp-define-layer定义一个返回原生 property plist 的 recipe
- define-tps别名 define-tp-group、tp-define-group定义由多个 recipe、
recipe call、原生 plist 或命名元素组成的 declaration group
- tp-layer-parameterized-p、tp-layer-arglist、tp-layer-props、
tp-layer-props-with-args、tp-layer-props-with-arg 查询或展开 layer
- tp-group-parameterized-p、tp-group-props、tp-group-props-with-args、
tp-group-props-with-arg 查询或展开 group
- tp-undefine-layer、tp-undefine-group、tp-layer-reset 删除 recipe
- tp-describe-layer 返回 recipe 的声明式诊断数据。
recipe 是 definition-time convenience不是 mounted layer也不会向文本
写入 identity、provenance、tp-name 或 tp-layers。旧的 $variable reactive
syntax 会被拒绝。
tp-layer-alist 和 tp-layer-groups 是 recipe registry通常通过上面的 query、
undefine 和 reset API 访问,不要直接修改 registry。
## 5. Reactive signal 和 binding
### 5.1 Signal
~~~elisp
(let ((online (tp-signal-create nil)))
(tp-signal-read online) ; 在 binding/producer 中收集依赖
(tp-signal-peek online) ; 读取但不收集依赖
(tp-signal-set online t)
(tp-signal-subscriber-count online)
(tp-signal-live-p online)
(tp-signal-dispose online))
~~~
tp-signal-create 的关键字选项:
- :equality默认 equal相等写入是 no-op
- :scope默认 global也可以是一个 live buffer。Buffer kill 会释放该范围
内 signal。
tp-signal-read 只在当前 computation 中登记 dependencytp-signal-peek 不会
登记。disposed signal 的读取会报错。
### 5.2 Binding
~~~elisp
(let* ((source (tp-signal-create 0))
(owner (list 'owner))
(binding
(tp-bind owner 'value
(lambda () (tp-signal-read source))
:lifecycle 'delete)))
(tp-binding-read binding)
(tp-binding-live-p binding)
(tp-binding-dependency-count binding)
(tp-binding-subscriber-count binding)
(tp-binding-owner-bindings owner)
(tp-binding-dispose binding)
(tp-signal-dispose source))
~~~
tp-bind 按 OWNER + KEY 幂等安装 computation。KEY 应使用调用者自己的命名空间;
:equality 默认 equal:lifecycle 为 delete 或 retain。binding 依赖集合按每次
实际读取重建,因此条件分支会自动断开不再使用的 source。tp-binding-read
会在需要时计算并把 binding-to-binding 依赖登记到当前 computation。
tp-binding-dispose-owner 释放 owner 的全部 binding返回释放数量
tp-binding-dispose 释放单个 binding。
### 5.3 Transaction 和变量适配器
~~~elisp
(let ((left (tp-signal-create 0))
(right (tp-signal-create 0)))
(tp-with-transaction
(tp-signal-set left 1)
(tp-signal-set right 2))
(tp-signal-dispose left)
(tp-signal-dispose right))
(tp-with-transaction
(tp-transaction-participate-v2
:key 'my-structured-state
:stage (lambda () (my-stage))
:rollback (lambda () (my-rollback))))
(tp-transaction-active-p)
(tp-runtime-manifest)
(tp-variable-signal 'my-variable)
(tp-variable-signal 'my-buffer-variable some-buffer)
(tp-reactive-counters)
(tp-reactive-reset-counters)
(tp-reactive-reset)
~~~
tp-with-transaction 将 signal、binding、surface 和注册的 transaction
participant 一起原子处理。participant 必须在 active transaction 内注册;
stage 在 surface publication 后、source commit 前运行,失败时按逆序
rollback。consumer 使用 `tp-transaction-participate-v2`;它
返回 key不暴露内部 participant 对象。tp-variable-signal 用 Emacs variable
watcher 适配全局或指定
Buffer 的变量,不是旧的 $variable API。
tp-transaction-active-p 是只读边界查询:只在当前 dynamic extent 已进入
或加入 TP transaction 时返回严格的 t否则返回 nil。它不暴露 transaction
对象、participant 或内部状态,调用方只能用它在 mutation 前拒绝不支持的
嵌套事务边界。
tp-runtime-manifest 返回防御性 capability snapshot本版本的
`:transaction-protocol``tp-transaction-protocol-v2``:version` 为
`"2.0.0"`。`:structured-participant-api` 指向
`tp-transaction-participate-v2``:batch-execute`、`:batch-artifacts` 和
`:single-live-writer` 均为 non-nil。manifest 不再发布 execution route、
v1 adapter 或 v1 rollback route。
从 TP 1.x 迁移时,把 `(tp-transaction-participate KEY PUBLISH ROLLBACK)`
精确替换为 `(tp-transaction-participate-v2 :key KEY :stage PUBLISH
:rollback ROLLBACK)`。删除所有对 `tp-transaction-execution-route`
`tp--transaction-artifact-mode` 的设置。
ETAF registers one opaque participant for its immutable generation and Ebox
client state. Its publish is paired with rollback across TP final accept; the
ETAF runtime separately records effect input/version tuples and reports a
bounded non-converging flush instead of spinning.
## 6. Retained surface
### 6.1 Plan、result 和 object
~~~elisp
(tp-surface-plan-create
:key 'label :kind 'text :text "Ready"
:props '(face bold) :tags '(:role status)
:capability 'content)
~~~
Plan 字段为 key、kind、text、props、children、tags、capability。leaf 使用
text容器使用 children同一层的 key 必须唯一。capability 是 content 或
properties。
- tp-surface-plan-create 防御性复制 caller-owned 数据;
- tp-surface-plan-create-owned 直接接收 candidate-local 数据;调用者必须
转移所有权,之后不得修改或向其他 owner 暴露;
- tp-surface-result-create 返回携带 plan 和 opaque client-state 的 producer
result
- tp-surface-result-create-owned 只可对当前 active prepare context 使用,
结果只消费一次。
- tp-surface-retained-content-result-create 用于对象拓扑不变的 content
candidate最后一个可选 `property-contributions` 参数接受按顺序排列的
`(:start N :end N :props PLIST)` 相对范围。TP 使用已注册 property merge
policy 在 prepare 内组合这些贡献,再通过同一个 content surface 原子 diff、
发布和回滚;调用者不需要创建重叠的 properties surface也不应预先压平
Theme/状态/inline face。
producer 接收一个 prepare context并应返回 plan 或 result
~~~elisp
(lambda (context)
(let ((object (tp-object-ensure context nil 'row 'text)))
(tp-surface-plan-create
:key 'row :kind 'text :text "row"
:props '(face italic)
:capability 'content)))
~~~
producer 不得在 prepare 阶段直接修改 live surface bufferplan 不携带
position、marker、patch operation、producer closure 或 continuation。
对象入口:
- tp-object-ensure 按 parent、sibling key、kind 返回或创建当前 candidate 的
稳定 opaque object
- tp-object-live-p、tp-object-mounted-p 检查 object 状态;
- tp-object-resolve 用 key path 从 surface side index 取得 object不扫描文本
- tp-object-mounts 返回 :start、:end、:tags 的数值快照;
- tp-object-retain 保留没有输出 fragment 的 object
- tp-object-retain-subtree 保留已证明未删除的 object 子树;
- tp-object-reuse-subtree 复用已证明完全不变的 object 子树;
- tp-object-attach-fragment 把一个 object 绑定到 content fragment
- tp-object-attach-content-range 把 object 绑定到 leaf 的相对字符范围;
- tp-object-attach-content-ranges 批量绑定 range并复制 tags
- tp-object-attach-content-ranges-owned 批量绑定 candidate-owned tags。
retain-subtree/reuse-subtree 不会替调用者证明 candidate 完整或输出未变化;
producer 仍须提交完整 plan并承担“不变”证明。
### 6.2 Mount、update、scope 和 report
~~~elisp
(let* ((surface
(tp-surface-mount
buffer producer
'(:capability content
:start 1 :end 1
:client-state initial-state
:inhibit-read-only t
:observers (my-after-commit)))))
(tp-surface-update surface producer)
(tp-surface-update-scoped
surface
(list object)
producer
'(:on-mismatch error :return-report t))
(tp-surface-report surface)
(tp-surface-report-summary surface)
(tp-surface-inspect surface)
(tp-surface-unmount surface))
~~~
tp-surface-mount 的 plan-or-producer 可以是 plan、result 或 producer
producer 的调用上下文由 TP 管理。properties surface 只能写属性content
surface 才能拥有和更新文字。可用 mount options
:capability、:start、:end、:inhibit-read-only、:coordinate-mounts、
:client-state、:observers。
tp-surface-update 发布下一份完整 candidate。tp-surface-update-scoped 仍要求
producer 生成完整 candidate但只授权指定 object 当前 mount 范围;
:on-mismatch 默认报 tp-scope-mismatch设为 root 才允许显式 root fallback
:return-report 控制是否返回 report。
其他 surface API
- tp-surface-live-p、tp-surface-revision、tp-surface-client-state
- tp-surface-materialize-string 使用相同 producer/plan 语义生成一次性 string
但不保留 surface、object、binding、subscription 或 anchor
- tp-surface-at-point 通过 side index 返回当前位置的 live objects
- tp-surface-report 返回完整 defensive report
- tp-surface-report-summary 只返回 scalar commit metrics
- tp-surface-inspect 返回 surface、capability、revision、object/mount 数量、
client state 和 report
- tp-surface-unmount 卸载并返回 report。Content 会删除自己的 span
properties 只撤销仍由 TP 拥有的 contribution。
Report 的常用字段包括:
:transaction-id、:surface-id、:old-revision、:new-revision、
:candidate-source-writes、:invalidated-bindings、:recomputed-bindings、
:skipped-bindings、:reconciled-objects、:created-objects、:removed-objects、
:moved-objects、:text-operations、:property-operations、
:touched-characters、:full-root、:scope-count、:scope-range-count、
:scope-fallback、:property-conflicts、:rolled-back、:failure、
:observer-errors、:timing。
已经精确计算出变更区间的 producer 可以使用 `tp-commit-batch-create` 构造
批次,再由 `tp-commit-batch-result-create` 绑定当前 prepare context发布和
回滚仍使用相同 surface 事务。批次绑定前后 revision、extent 和坐标映射。
每个 patch 的 `:replacement` 是完整属性文本,也可以携带局部
`:property-contributions`:其中 `:start`/`:end` 相对于该 replacement按列表
顺序使用已注册的 property merge policy 合成。策略在**构造批次时**求值;
批次只保留合成后的文本快照,不保留贡献列表,之后的调用方修改或策略替换
不会重新计算这份批次。函数、record 等 opaque 属性身份按既有 snapshot 规则保留。
producer 只有在证明整个挂载拓扑、tags 和坐标均与已提交版本相同时,才能向
`tp-commit-batch-result-create``:reuse-mount-projection t`。它不能与显式
`:mount-specs` 同时使用;数量相同或对象没有增删都不能替代完整的不变证明。
### 6.3 Host range 和 tp-watch
~~~elisp
(let ((anchor
(tp-range-anchor-create
buffer start end
:start-insertion-type nil
:end-insertion-type t
:boundary-policy 'shorten)))
;; 在 producer 的 context 中:
(tp-object-attach-range context object anchor)
(tp-range-anchor-live-p anchor)
(tp-range-rebase anchor))
~~~
boundary-policy 可为 stale、shorten、remove。anchor 是 marker-backed opaque
rangehost text 编辑由 marker 跟随TP 不扫描附近文字猜测位置。
tp-range-rebase 明确接受当前 host properties 作为新 baseline。
tp-watch 是 properties-only surface 的便捷入口:
~~~elisp
(let ((surface
(tp-watch
buffer start end
(lambda ()
(list 'face
(if enabled 'success 'shadow))))))
(tp-surface-report surface))
~~~
compute 是零参数函数,返回原生 declarations。文字由 host 所有;返回值是
底层 properties surface可交给 update/report/inspect/unmount。
## 7. 属性查询、区间和 mutation policy
### 7.1 Direct query
- tp-get 返回范围内的 (START END PROPS) property intervals指定 property
或 nested path 时只返回对应区间;
- tp-at 返回某一位置的完整 plist或指定 property/nested path 的值;
- tp-member 只在 property 存在时返回 (PROPERTY VALUE),因此可区分 present
nil 和 absent
- tp-intervals 返回对象范围的 property intervals可用 absolute 请求 Buffer
原生坐标;
- tp-intervals-map 对每个 interval 调用函数;
- tp-plist 返回位置或 string range 的合并 property plist
- tp-empty-p 判断对象是否为空;
- tp-text-snapshot 返回 string 和 text properties 的防御性快照。
### 7.2 Native query
~~~elisp
(tp-lookup position 'face
:object buffer
:mode :text-effective)
(tp-property-change position :property 'face :direction :next)
(tp-property-any start end 'face 'bold buffer)
(tp-property-not-all start end 'face 'bold buffer)
(tp-with-mutation-policy '(:modified :silent :read-only :inhibit)
(tp-apply buffer start end '(face bold)))
~~~
tp-lookup 返回 tp-lookup-resultmode 可为:
- :text-direct直接 text property
- :text-effective考虑 category/default 等 text-property 继承;
- :text-source返回实际 text source
- :char使用 get-char-property-and-overlay 的字符属性;
- :char-source字符属性的实际来源overlay 会记录为 :overlay。
result 的 present-p 区分显式 niltp-property-change 的 direction 为 :next
或 :previousproperty 为 nil 时观察任意属性变化。
tp-with-mutation-policy 的 :modified 可为 :ordinary 或 :silent
:read-only 可为 :respect 或 :inhibit。支持 ordinary/respect、
ordinary/inhibit、silent/inhibitsilent/respect 会报错。
## 8. Match、regexp、search 和 navigation
所有 search 都是 presence-aware省略 VALUE 或显式传入 tp-any-value 匹配
所有存在的值;显式 nil 只匹配“存在且值为 nil”。
### 8.1 按文字匹配并修改
- tp-match-setliteral pattern 的所有匹配上设置属性;
- tp-match-resetliteral pattern 的所有匹配上重置属性;
- tp-match-addliteral pattern 的所有匹配上合并属性;
- tp-regexp-set、tp-regexp-reset、tp-regexp-addregexp 匹配,可用 subexp
只操作 capture group。
Pattern 可以是一个 string 或 string 列表。String object 返回新 string
Buffer object 原地修改并返回匹配范围列表。start > end 时边界会交换,
匹配不会跨出指定范围。
### 8.2 查找和批量处理
~~~elisp
(tp-search string 'status)
(tp-search start end 'status 'ready buffer)
(tp-forward 'status tp-any-value buffer 2)
(tp-backward 'status nil buffer)
(tp-search-map
(lambda (text _start _end _index) (upcase text))
'status tp-any-value buffer)
~~~
- tp-search 返回所有匹配的 (START END VALUE)
- tp-forward / tp-backward 在 Buffer 中从 point 搜索并返回 prop-match
在 string 中返回 0-based 区间列表;
- tp-forward-do / tp-backward-do 找到第 N 个匹配后只对最后一个执行
function不是 for-each
- tp-search-map 对每个匹配执行 function。function 可返回替换 string、
修改 text 后的 string或 nil 跳过。String 替换必须保持长度不变;
Buffer 替换可以改变长度;
- tp-search-forward / tp-search-backward 只是 Emacs
text-property-search-* 的 obsolete raw wrapper新增代码使用
tp-forward / tp-backward 或直接使用 Emacs primitive。
## 9. Palette、内置 recipe 和显示辅助
~~~elisp
(define-tp-palette status
:fg ("#22863a" . "#3fb950")
:bg ("#f0fff4" . "#1a2e1f"))
(tp-palette-color 'status :fg)
(tp-palette-fg-color 'status)
(tp-palette-bg-color 'status)
(tp-palette-border-color 'status)
(tp-palette-has-p 'status :fg)
(tp-palette-pure 'status-fg)
(tp-set "Ready" 'tp-palette 'status-fg)
~~~
define-tp-palette别名 tp-define-palette注册 :fg、:bg、:border。颜色
可以是 string、(LIGHT . DARK) 或 (:light LIGHT :dark DARK)。查询和主题工具:
tp-palette-alist 是 palette lookup 的单一来源;使用
define-tp-palette/tp-define-palette 更新它。
- tp-theme-dark-p、tp-theme-light-p、tp-parse-color
- tp-palette-color、tp-palette-fg-color、tp-palette-bg-color、
tp-palette-border-color
- tp-palette-has-p 判断 palette 或 key 是否存在;
- tp-palette-p 判断 palette 名;
- tp-palette-fg-p、tp-palette-bg-p、tp-palette-fbg-p、tp-palette-border-p
判断 NAME-* variant
- tp-palette-pure 去掉 variant suffix
- tp-palette-show 打开 *tp-palette-gallery*,按 q 退出。
TP 自带的 recipe 包括:
tp-palette、tp-fg、tp-bg、tp-button、tp-underline、tp-delete、tp-link、
tp-space、tp-headline、tp-action。
显示辅助:
- tp-pop-to-buffer清空并填充 buffer 后 pop-to-buffer最后设为只读
- tp-switch-to-buffer同样的填充和只读行为但使用 switch-to-buffer
- tp-display-buffer-mode为 TP 显示 buffer 提供 buffer-local 的 q 退出键,
不修改共享 major-mode map。
tp-display-buffer-mode-map 是该 minor mode 的 keymap默认只绑定 q 到
quit-window。
## 10. Debug 和公共 record
Debug 入口:
- tp-debug-mode、tp-debug-echo 控制日志行为;
- tp-debug-log 记录格式化消息;
- tp-debug-clear 清空日志;
- tp-debug-show 显示日志;
- tp-with-current-buffer 在指定 Buffer 中执行 body
- tp-face-properties 列出 face family properties。
以下公共结果类型由 cl-defstruct 提供 predicate 和字段 accessor。调用者不应
直接调用内部 constructor优先使用前文的 create/query API
- tp-property-policyid、normalizer、validator、equality、merge、projector
- tp-signalid、committed-value、equality、scope、revision 等运行时字段;
- tp-bindingid、owner、key、compute、last-value、dependencies、lifecycle
等运行时字段;
- tp-surface-plankey、kind、text、props、children、tags、capability
- tp-surface-resultplan、client-state 及 owned/consumed 状态;
- tp-lookup-resultproperty、value、present-p、source、mode、object、
position、overlay。
## 11. 错误、生命周期和已删除 API
重要错误类型:
- coretp-unsupported-buffer
- propertytp-property-error、tp-invalid-property-policy、
tp-invalid-declaration
- recipetp-invalid-layer-definition、tp-unresolved-layer
- reactivetp-reactive-error、tp-invalid-signal-scope、tp-disposed-signal、
tp-disposed-binding、tp-binding-cycle
- surfacetp-surface-error、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-invalid-content-range、tp-producer-buffer-mutation、
tp-publication-mismatch、tp-owned-result-error、tp-scope-mismatch。
Live object、binding、surface、anchor 或 signal 被 dispose、unmount 或
Buffer kill 后,继续使用会报相应 stale/disposed 错误。Observer 只在成功
commit 后运行observer error 会记录在 report不会回滚已提交 publication。
TP 1.0 已删除并且不应在新代码中使用:
- tp-render.el、tp-stack.el、managed stack mutation
- tp-text、$variable、inline tp-name/tp-layers/tp-meta runtime database
- layer-to-buffer registry、scan-driven refresh、managed attach/detach
- tp-with-batch-updates 和旧 CSS/ECSS runtime integration。
因此,当前正确的组合是:静态声明用 recipe/direct API已有文字的响应式
属性用 tp-watchTP 自己拥有的响应式文字用 content surface。
## 12. 完整模块索引
| 模块 | 当前公共入口 |
| --- | --- |
| tp-core.el | tp-debug-*、tp-with-current-buffer、tp-intervals、tp-intervals-map、tp-empty-p、tp-plist、tp-text-snapshot |
| tp-style.el | tp-define-property-policy、tp-property-policy、tp-text-property-id、tp-register-text-property、tp-text-declarations、tp-computed、tp-resolve-value、tp-merge-declarations、tp-define-style、tp-style-declarations、tp-undefine-style |
| tp-layer.el | define-tp/tp-define-layer、define-tps/define-tp-group/tp-define-group、layer/group query、tp-layer-reset、tp-undefine-*、tp-describe-layer |
| tp-transaction.el | structured batch/entry、final-marker 与 tagged-outcome 内部合同 |
| tp-reactive.el | signal、binding、transaction coordinator、variable adapter、counter 和 reset API |
| tp-surface.el | plan/result、object、range anchor、surface lifecycle、scoped update、report、tp-watch |
| tp-ops.el | tp-propertize、tp-apply、tp-set、tp-reset、tp-add、tp-remove、tp-clear、tp-get、tp-at、tp-member |
| tp-search.el | tp-match-*、tp-regexp-*、tp-search、tp-search-map、tp-forward*、tp-backward*、tp-any-value |
| tp-query.el | tp-lookup、tp-property-change、tp-property-any、tp-property-not-all、tp-with-mutation-policy |
| tp-palette.el | palette definition、theme/color lookup、palette predicates |
| tp-builtins.el | built-in recipes、tp-palette-show、display-buffer macros/mode |
Makefile 提供 make test、make test-shuffled、make doctest、make compile-all WERROR=t、
make checkdoc、make package-lint、make diff-check 和 make benchmark。实现细节
和测试合同以 source、tests/、[API semantics](API-SEMANTICS.md) 和
[architecture](ARCHITECTURE.md) 为准。

View File

@ -1,268 +0,0 @@
# TP 2.0 API Semantics
本文记录 TP 2.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
完整的公共符号、参数形状、返回值和示例见 [API reference](API-REFERENCE.md)。
## 1. 产品边界
TP 负责最终 Emacs text property policy/contribution、signals/bindings、stable objects、marker-backed mounts、surface diff、transaction、rollback 和 Buffer publication。
TP 不实现 selector、stylesheet、specificity、origin/importance、CSS cascade layers、CSS-wide values、custom properties 或 Box/Flex/Grid。需要 CSS cascade 的调用者先通过独立 ECSS 获得 final declarations再交给 TP。
## 2. 普通值、显式 nil 与 computed source
普通 Elisp value 始终是 literal包括 function object、keymap command、`help-echo` callback 和 list。TP 不会因为一个值可调用就执行它。
需要求值的 declaration 必须显式使用:
```elisp
(tp-computed (lambda () ...))
```
`tp-resolve-value` 只执行这种 tagged source。compute result 只 normalize/project 一次不会被隐式二次调用。compute error 直接终止 candidate transaction。
TP 严格区分:
- absentproperty plist 中没有该 key
- present nilproperty key 存在value 为 `nil`
`tp-member` 和底层 contribution ledger 使用 presence-aware 语义。properties mount 的显式 nil contribution 可以覆盖 baseline但 unmount 仍只撤销 TP 自己拥有的 contribution。
## 3. Property policy 与 direct declarations
`tp-define-property-policy` 为一个 canonical native property id 注册:
- normalizer
- validator
- equality
- merge
- projector。
注册是原子的:无效 options 或 function 会报 `tp-invalid-property-policy`,旧 definition 保持不变。
`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。
`tp-merge-declarations` 按输入顺序合并 direct declaration groups并防御性复制 caller-owned value。它只做 TP contribution composition不实现 CSS winner selection。
`tp-define-style`、`tp-style-declarations` 和 `tp-undefine-style` 管理 named direct declarations。registry getter 返回防御性副本。
## 4. Declaration recipes
`define-tp` 定义一个返回 native property plist 的 recipe`define-tps` 定义一组有序 recipe elements。`tp-define-layer`、`define-tp-group` 与 `tp-define-group` 是同一静态 declaration workflow 的命名入口。
Recipe 可以是静态或参数化的,可以组合其他 recipes。展开结果经过同一 direct property policy/projector。Recipe application 不建立 live identity不写 `tp-name`、`tp-layers` 或 `tp-meta`
`$variable` syntax 会报 `tp-invalid-layer-definition`。响应式值必须使用 `tp-computed` 加 signal/binding不能建立第二套 watcher runtime。
Recipe/group definition 与 redefinition 是原子的definition body、generated named elements 或 compiled style 任一步失败时,不留下半个新 definition已有 definition 保持可用。
## 5. 一次性 façade
### 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 自动 disposeglobal 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 |
| --- | --- |
| `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 metadataTP 不解释其业务含义 |
| `capability` | `content``properties` |
Plan 不允许 marker、buffer position、patch op、producer closure 或 binding closure。Constructor 防御性复制 caller 提供的 key、kind、text、props、children list 与 tags使 caller 后续 mutation 不改变 committed plan。`tp-surface-result-create` 只携带 plan 与 opaque client stateTP 在 prepare transaction 内从该 plan 生成唯一的 authoritative rendered output不接受第二份 caller-provided text 或 traversal records。Result 与 producer normalization 会在各自边界建立防御性 plan snapshot。Producer 如果为当前 candidate freshly allocate 了完整 plan tree并且之后不再 mutation 或 expose可使用 `tp-surface-plan-create-owned``tp-surface-result-create-owned` 将 plan 所有权转给 TP跳过重复 snapshotowned result 必须绑定当前 active prepare context并且只允许被 prepare normalization 消费一次;普通 caller-owned plan 必须使用复制入口。
producer 在 prepare 阶段接收 context并在产生 plan 前调用:
```elisp
(tp-object-ensure CONTEXT PARENT KEY KIND)
```
Object identity 只在所属 surface 中有效。显式 key 按 parent/key/kind reconcileunkeyed object 按 position/kind reconcile。duplicate sibling key、stale parent、orphan object 或 cross-surface handle 在 prepare 中失败。
Candidate object 只有成功 publication 后才变为 live。失败 candidate handle 必须不可解析。`tp-object-resolve` 按 surface/key path 查询 live handle不创建 identity。
无可见字符但需要保留的 logical object 使用 `tp-object-retain`。一个 logical object 可以通过 `tp-object-attach-fragment` 关联多个离散 plan fragmentsattachment 保存在 prepare side state不进入 plan。
当 producer 已经证明一个现有 logical subtree 在本次 candidate 中保持不变,可以使用 `tp-object-retain-subtree` 复用当前 live root 下已知的 object path。该 API 会把 subtree objects 标记为 touched/retained并保留其 live bindings它不创建缺失对象也不替 producer 验证 candidate plan、输出范围或布局不变性。调用方仍必须提交完整 candidate plan并在不满足证明时回退到普通 `tp-object-ensure` 路径。若完整 candidate 仍会重新提交这些对象的 output attachment但已证明它们的 identity、lifecycle 和 output 不变,可使用 `tp-object-reuse-subtree`:对象保留在 candidate 中但不进入 touched/reconcile 集合。
Content range ownership 有两个入口:`tp-object-attach-content-ranges` 对每个 `:tags` 建立防御性快照;只有当 producer 为当前 candidate 新建了 tags、之后不会再修改或暴露它们时才可使用 `tp-object-attach-content-ranges-owned` 转移这些值的所有权并跳过复制。转移入口不改变失败 candidate 的 rollback 语义;未成功 publication 的值会随 candidate 一起丢弃。普通 caller-owned tags 必须使用复制入口。
`tp-surface-report` 始终返回完整的防御性 report snapshot。只需要 transaction、operation、scope 或 object reconciliation 计数等提交标量的 integration caller 应使用 `tp-surface-report-summary`,它不暴露 nested report payload也不为读取这些标量复制整份 report。
## 8. Surface lifecycle
### 8.1 Materialize
```elisp
(tp-surface-materialize-string PLAN-OR-PRODUCER)
```
以 ephemeral prepare context 生成 propertized string不建立 live surface。函数返回前释放 candidate objects、bindings、subscriptions 和 anchors。
### 8.2 Mount/update
```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)
```
Mount options 支持 `:capability`、`:start`、`:end`、`:inhibit-read-only`、`:client-state` 和 `:observers`
`content` surface 拥有其 span 的 text 和 properties可以插入、删除、替换或移动输出。`properties` surface 只能贡献声明的 properties不能替换 host text。
`tp-surface-update-scoped` 仍接收完整 candidate。TP 从 object-to-mount index 得到授权范围,验证 candidate 没有改变范围外输出,再在同一 transaction 发布。默认 mismatch 报 `tp-scope-mismatch``(:on-mismatch root)` 显式允许 full-root fallback。默认返回 defensive report snapshot调用方如果只通过 `tp-surface-report-summary` 读取标量提交指标,可传 `(:return-report nil)` 避免构造完整 report snapshot。
相等 candidate 不产生 publicationsurface revision 和 buffer modified state 保持不变。
### 8.3 Unmount
`tp-surface-unmount` 释放 surface、objects、bindings、mounts、markers、subscriptions、indexes 和 opaque client state并返回 generic report。content surface 删除自己拥有的 spanproperties surface 只撤销仍由 TP 拥有的 contributions。
kill-buffer cleanup 以 buffer 死亡为权威结果,释放 runtime state不尝试复活 buffer。
## 9. Range anchors 与 property conflicts
`tp-range-anchor-create` 接受 buffer、start/end、marker insertion policy 与 `stale`/`shorten`/`remove` boundary policy返回 opaque handle。raw marker 和 position 不进入 surface plan。
producer 使用 `tp-object-attach-range` 把 object 绑定到 anchor。一个 properties surface 的重叠 mounts 通过 property policy 合成 contributions。
TP 为每个 interval 保存:
- host baseline presence/value
- ordered TP contributions
- last published presence/value。
如果当前 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。
## 10. `tp-watch`
```elisp
(tp-watch BUFFER START END COMPUTE)
```
`COMPUTE` 返回 native direct declarations。`tp-watch` 组合 range anchor、properties surface、stable object 和 binding返回 underlying surface handle。COMPUTE 中读取的 signals/bindings进入正常 dependency graph更新与 unmount 使用同一 conflict和rollback合同。
## 11. Transactions
`tp-with-transaction` 的顺序是:
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. 默认从 publication batch 的 exact entry bindings 按稳定 surface id publish
7. 从 batch 绑定的同一 participant vector 按声明顺序 stage participant再执行
declared precommit
8. commit signal journal
9. 在 candidate 绑定的 single final accept 内按顺序 apply bounded opaque markers再 accept
change groupmarker 只能使用 closed `tp-vector-slots/v1` fixed-write
primitive不能注册 callbackpartial apply 或 accept failure 先逆序
restore markers
10. final accept 成功后固定写入 tagged success再运行 contained
committed/observer work。
嵌套 transaction 加入最外层。一个 global signal 可以原子触达多个 buffers任一 surface 失败时,已发布 surfaces 和 source/binding state 全部回滚。
`tp-transaction-participate-v2` 允许 client side state 在 surfaces 发布后、
source commit 前加入同一 rollback boundary。调用方通过 `:key`、`:stage` 和
`:rollback` 注册 structured participant返回值仍是 key内部 participant
identity、state 与 journal 不暴露。participant key 在一个 outer transaction
中必须唯一。它不是 observer失败会回滚 transaction。Observer failure 只记录,
不回滚已提交结果。
publication batch、structured participant、final marker 与 tagged outcome 共享
现有 journal/change-group不复制第二份 live state。publication batch 是唯一
live writersurface 从 candidate entries 执行participant 从 candidate
绑定的同一 identity vector 执行final accept 从 candidate binding 执行;任何
binding/order 漂移都会 fail-fast 并回滚。TP 2.0 不再提供 alternate writer、
execution route 或 artifact-mode switch。`tp-with-transaction` 的返回值仍是 body result
success/failure outcome 只走内部 side channel。zero-surface 与 output-equal
operation 不创建 publication batch。
ETAF uses this API with one opaque participant for its immutable generation and
Ebox client state. The participant is published only after candidate
preparation, and its paired rollback is still required when TP final accept
fails. This keeps ETAF generation visibility, Ebox publication, signals, and
client state on one commit boundary; ETAF's own flush guard is responsible for
detecting repeated input/version tuples and bounded non-convergence.
## 12. Diagnostics 与 reports
`tp-surface-report` 返回最近一次成功 publication 的防御性 reportequal/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。
`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。
## 13. Error ownership
Surface publication 还会使用 `tp-invalid-content-range`
`tp-producer-buffer-mutation`、`tp-publication-mismatch` 和
`tp-owned-result-error`;它们分别归属于 content range 校验、prepare
buffer guard、publication journal 和 owned producer result 合同。
主要错误类型:
- 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-surface-error`、`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-invalid-content-range`、`tp-producer-buffer-mutation`、`tp-publication-mismatch`、`tp-owned-result-error`、`tp-scope-mismatch`。
内部 computation 不吞错或返回貌似合理的 fallback。只有用户入口和 batch test runner等外层边界负责把错误转换为展示信息。
## 14. 1.0 删除项
TP 1.0 删除了不能诚实映射到统一 retained runtime 的 0.3 managed behavior
- `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 不提供 hidden compatibility engine也不根据文本是否含旧 metadata 自动切换执行语义。静态 recipe、`tp-watch` 和 retained surface 分别承担复用声明、已有文本响应式属性与 retained content 的清晰职责。

View File

@ -1,263 +1,620 @@
# TP 2.0 Current Architecture # tp 代码架构文档
本文描述 TP 2.0 当前实现的模块边界、权威状态、数据流和事务模型。公共行为合同见 [API semantics](API-SEMANTICS.md),设计背景见 [retained runtime architecture](retained-runtime-target-architecture.md) 本文档描述 tp 库的模块分层结构与函数调用层次,从底层基础模块到上层功能模块的分层组织
按功能查找公共入口和用法时,使用 [API reference](API-REFERENCE.md)。 自 0.2.0 起,原来的单文件 tp.el 已拆分为九个分层模块,`tp.el` 只作为总入口(`(require 'tp)` 依次加载全部模块用户接口不变。0.3.0 进一步收紧了模块边界:`tp-text` 处理链下沉至 tp-ops、批量更新上收至 tp-render、层栈存储编解码与匿名层机制归位 tp-layer钩子变量从四个减少到两个。各变更的缘由见 [CHANGELOG.md](../CHANGELOG.md)。
## 1. 定位 ## 目录
TP 是通用 retained/reactive text runtime - [架构概述](#架构概述)
- [模块分层](#模块分层)
- [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-palette.el调色板数据](#tp-paletteel调色板数据)
- [tp-builtins.el内置层与辅助工具](#tp-builtinsel内置层与辅助工具)
- [钩子变量:唯一许可的反向调用](#钩子变量唯一许可的反向调用)
- [可变状态清单](#可变状态清单)
- [函数调用关系图](#函数调用关系图)
- [设计原则](#设计原则)
```text ---
application state
→ signals/bindings ## 架构概述
→ prepare context + stable objects
→ pure surface plan tp 采用严格的线性分层:**每个模块只允许 `require` 并调用排在它前面的模块**,字节编译器强制检查这一依赖顺序。加载顺序即依赖顺序:
→ reconcile/diff
→ atomic Buffer publication ```
tp-core → tp-reactive → tp-layer → tp-ops → tp-search
→ tp-render → tp-stack → tp-palette → tp-builtins
``` ```
TP 负责文本属性 contribution、响应式依赖、身份、位置、变化和提交。调用者负责业务含义以及期望显示结果。 注意加载顺序是依赖顺序的**上界**:并非每个模块都依赖它前面的全部模块。各模块实际 `require` 的 tp- 模块如下(逐一核对自源码头部):
TP 不依赖 Ebox 或 ECSS不包含 selector、stylesheet、CSS cascade、Box/Flex/Grid、measurement、layout owner 或 viewport dirty semantics。 | 模块 | require 的 tp- 模块 |
|------|--------------------|
| tp-core | —(仅 cl-lib、dash、seq |
| tp-reactive | tp-core |
| tp-layer | tp-core、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-palette | —(不依赖任何 tp- 模块,仅 subr-x |
| tp-builtins | tp-core、tp-layer、tp-ops、tp-palette |
## 2. 模块图 ```
┌────────────────────────────────────────────────────────────────┐
│ tp.el —— 总入口,按序 require 全部模块 │
└────────────────────────────────────────────────────────────────┘
┌────────────────────────────────────────────────────────────────┐
│ tp-builtins.el 内置层tp-link, tp-space, tp-headline …)、 │
│ tp-palette-show、显示缓冲辅助宏 │
├────────────────────────────────────────────────────────────────┤
│ tp-palette.el 明/暗主题调色板数据、tp-parse-color │
│ (独立叶模块,不依赖任何 tp- 模块) │
├────────────────────────────────────────────────────────────────┤
│ 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-core.el 区间遍历、plist/face 合并引擎、 │
│ 调试日志、$var 符号工具(无可变状态) │
└────────────────────────────────────────────────────────────────┘
```text 实线层级上层模块调用下层模块require 依赖)。
tp-core 虚线(◁╌╌):钩子变量 —— 下层模块预留的函数变量,
├─ tp-style 由 tp-render.el 在加载时安装实现(见下文)。
├─ tp-transaction
│ └─ tp-reactive
│ └─ tp-surface
├─ tp-layer
├─ tp-ops
├─ tp-search
├─ tp-query
├─ tp-palette
└─ tp-builtins
tp.el loads the public package surface
``` ```
真实 require 关系按源码为准;上图表达责任层次,不要求每个 consumer 经过所有中间模块。 需要"向上调用"的逻辑全部收拢在 `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
| 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-transaction.el` | structured batch/entry validators、one-shot states、opaque final-marker descriptors、tagged outcomes | live buffer writer、consumer semantics、parallel journals |
| `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 ### tp-core.el基础工具
Direct declarations are native property/value pairs. `tp-style.el` resolves them through one policy pipeline: 最底层模块,不依赖任何其他 tp 模块提供区间遍历、合并引擎与调试能力。0.3.0 起 tp-core **不再持有任何可变状态**(匿名层计数器已迁至 tp-layer仅剩 `tp-debug-mode` / `tp-debug-echo` 两个 defcustom 用户选项)。
```text #### 区间操作
native declarations | 函数 | 描述 | 主要调用者 |
→ canonical text/PROPERTY ids |------|------|--------|
→ explicit computed-source resolution | `tp-intervals` | 获取区域内文本属性区间列表(裁剪到 [START, END);可选 ABSOLUTE 参数返回缓冲区原生坐标,默认仍为相对坐标) | tp-intervals-map, tp-get |
→ normalize | `tp-intervals-map` | 对区间应用函数(同样支持 ABSOLUTE | 多个属性/层操作函数 |
→ validate | `tp--map-intervals` | 共享的裁剪式区间遍历引擎 | tp-intervals-map, tp-ops/tp-stack 的区域操作, tp-reactive 的缓冲区扫描 |
→ merge contributions | `tp-plist` | 获取区域中合并后的所有属性 | 用户 API |
→ project to final Emacs properties | `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--merge-string-props-into-plist` | 将字符串内嵌属性并入 plist | tp-ops 的 tp-text 处理链 |
| `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-reactive.el响应式基础设施
只依赖 tp-core。维护响应式依赖注册表、变量监听器、批量更新队列与 0.3.0 新增的**层→缓冲区注册表****不包含任何渲染逻辑**,重渲染通过钩子变量委托给 tp-render.el。批量更新的队列`tp--batch-update-pending`、`tp--queue-batch-update`)定义在这里,但 `tp-with-batch-updates` 宏与刷新逻辑自 0.3.0 起位于 tp-render.el。
#### 依赖注册与管理
| 函数/变量 | 描述 |
|------|------|
| `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 |
#### 匿名层机制与 GC0.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--stack-props-to-list` | 原始属性 → 有序层列表(顶层在前,含隐藏层)。有隐藏层时 `tp-layers` 持有完整栈,直接属性只是最顶可见层的渲染缓存 |
| `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` 是它的调用入口,层重定义后经它触发已应用区域的重渲染。
---
### 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-ops0.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 次并移动点0.3.0 起接受 PREDICATE 与 NOT-CURRENT默认保持 0.2.0 的对称 `equal` 匹配契约) | text-property-search-forward |
| `tp-backward` | 向后搜索 N 次并移动点(与向前语义对称,同样新增 PREDICATE/NOT-CURRENT | tp--property-search-backward |
| `tp--property-search-backward` | 带谓词的向后搜索引擎 | text-property-search-backward |
| `tp--property-match-p` | 谓词归一化nil/t → `equal`;函数 → `(funcall PRED VALUE PROP-VALUE)` | - |
| `tp--string-property-matches` | 字符串路径的按段匹配收集器 | - |
| `tp-search` | 收集所有匹配区间 | tp-intervals 等 |
| `tp-search-forward` / `tp-search-backward` | **已废弃0.3.0make-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` | 重渲染携带某层的所有文本区域(替换该层自己的属性键,保留其他来源属性),并**写穿**到 `tp-layers` 栈存储 | tp--layer-render-props, tp-search-map, tp--write-layer-through-stack-storage |
| `tp--write-layer-through-stack-storage` | 把新属性写进栈存储里该层的条目(被覆盖或被隐藏的副本也保持最新,`tp-show-layer` 后渲染当前值而非陈旧快照;值未变的段不触碰缓冲区) | tp--stack-props-to-list, tp--stack-build-props [tp-layer] |
| `tp--merge-props-into-stack-entry` | 更新栈条目的键,保留其 `tp-hidden` 标志与栈位置 | - |
| `tp--update-layer-computed` | 更新 `:compute` 计算属性nil 值可正常传播) | tp--resolve-reactive-symbols, tp--set-layer-props |
| `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)
``` ```
Ordinary functions are literal. Only a tagged `tp-computed` source runs. Explicit nil remains distinguishable from absence throughout projection and retained contribution ownership. ---
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-stack.el属性层栈操作
## 4. Static façade and declaration recipes 依赖 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 均有警示)。
`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`. #### 内部助手
| 函数 | 描述 | 依赖 |
|------|------|------|
| `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 |
`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. #### 层操作(公开 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 |
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-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 |
No recipe application writes `tp-name`, `tp-layers`, or `tp-meta` to text. No `$variable` parser remains. #### 层属性操作
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-add-to-layers` | 向特定层添加属性 | tp--deep-merge-plist, tp--stack-map-region |
| `tp-add-to-all-layers` | 向所有层添加属性 | tp-add-to-layers |
## 5. Reactive graph ---
The authoritative graph lives in `tp-reactive.el`: ### tp-palette.el调色板数据
```text **不依赖任何 tp- 模块**(仅 subr-x是独立的叶模块。明/暗主题双值调色板系统,`tp-palette-alist` 是唯一数据源。
signal ──subscribers──> binding ──subscribers──> binding
| 函数/宏/变量 | 描述 |
└── owner object/surface |------|------|
| `define-tp-palette` | 定义调色板(重定义立即生效);别名 `tp-define-palette` |
| `tp-palette-alist` | 调色板注册表(唯一数据源) |
| `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`/nil0.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-reactive | `tp-reactive-deps` | 变量 → 依赖层 注册表 | `tp-reactive-reset` |
| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` | `:watch` / `:compute` / `:data` 注册表 | `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-propertyEmacs 原生,区域形式)
└── 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. ### tp-add 调用链
```
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. tp-add [tp-ops]
├── tp--parse-args [tp-ops]
The graph contains no layer-to-buffer registry. A source reaches surfaces through binding owners, not by scanning `buffer-list` or searching text properties. ├── tp--handle-tp-text-property [tp-ops](直接调用)
├── text-properties-atEmacs 原生)
## 6. Prepare context and identity ├── tp--prepend-face [tp-core]face 家族属性)
│ └── tp--deep-merge-plist [tp-core]
Every materialize/mount/update creates a short-lived prepare context. A producer calls `tp-object-ensure` before producing the corresponding plan node. ├── tp--deep-merge-plist [tp-core](其他嵌套属性)
├── put-text-propertyEmacs 原生)
Object identity is scoped to one surface and derived from: └── tp--ops-register-layer-buffer [tp-ops]
└── tp-reactive--register-layer-buffer [tp-reactive]
- 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`. Content ranges normally use `tp-object-attach-content-ranges`, which defensively snapshots opaque tags. A producer that freshly allocates candidate-local tags and never mutates or exposes them may use `tp-object-attach-content-ranges-owned` to transfer those snapshots without another copy. The same candidate-local ownership rule applies to `tp-surface-plan-create-owned` and `tp-surface-result-create-owned`; an owned result is bound to the active prepare context and consumed once, while normal plan/result constructors remain defensive boundaries.
## 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. Callers that only need scalar commit metrics may request no report snapshot and read `tp-surface-report-summary` after publication.
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.
The v2 contract uses those exact owners. It does not copy participant,
scheduler, snapshot, journal, or change-group state. The publication batch is
the sole writer and validates its canonical entries against the committed
property and revision state after commit or rollback.
```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
→ run precommit validators
→ commit signals
→ apply bounded opaque final markers
→ invoke the single final accept
→ finalize tagged success evidence
→ run observers
``` ```
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. ### 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-watcherEmacs 原生)
├── 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
```
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. ### 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-propertiesEmacs 原生)
└── tp--stack-register-layers [tp-stack]
└── tp-reactive--register-layer-buffer [tp-reactive]
```
`tp-transaction-participate-v2` 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. ### 响应式更新调用链
```
(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]
(最小差异、先插入后删除;文本相同则完全不动缓冲区)
Each structured participant has one stable key, registration order, stage, 批量模式tp-with-batch-updates [tp-render]/ 更新中的嵌套写入:
rollback, optional declared precommit, contained after-commit work, owner └── tp--queue-batch-update [tp-reactive](入队,不递归)
journal, and one-shot state. Final markers are not └── tp--flush-batch-updates [tp-render](退出批量/最外层更新结束时;
participants. TP treats their values as opaque and accepts only predeclared, 置于 unwind-protect 清理段,重渲染抛错也会排空队列)
fixed-bound operations. M1a's closed `tp-vector-slots/v1` primitive accepts └── tp--reactive-flush-entry [tp-render]0.3.0 起同模块直接调用,不再经钩子)
only prebuilt vector-slot expectations and writes; marker registration cannot ├── tp--update-layer-regions
inject callbacks. Partial apply or final-accept failure restores markers in └── tp--update-reactive-text
reverse order before the existing participant/surface/signal rollback. ```
If publication kills a target buffer, kill teardown is authoritative. Other surfaces and source state roll back; TP never recreates the killed buffer. ---
### ETAF participant contract ## 设计原则
ETAF is a consumer of this public boundary, not a second TP runtime. It stages 1. **严格分层**:模块只允许 `require` 并调用排在它前面的模块字节编译器强制检查依赖顺序且只声明真实存在的依赖0.3.0 移除了 tp-stack→tp-ops 的幻影依赖tp-palette 不依赖任何 tp- 模块)
an immutable semantic generation and an Ebox candidate, then registers one 2. **钩子反转**:唯一许可的"向上调用"是两个钩子变量(`tp--reactive-update-function`、`tp--layer-refresh-function`),由 tp-render.el 统一安装实现能改写为下行调用的反转tp-text 链、批量刷新)已在 0.3.0 改写掉
opaque participant. The participant publishes the generation only after TP 3. **单一职责**:每个模块(和函数)只负责一件事;一个子系统的完整生命周期住在一个模块里(匿名层的铸造/驻留/注销/GC 全在 tp-layer层栈存储格式知识全在 tp-layer 的编解码器)
preparation succeeds; TP final accept is the last fallible operation. Failure 4. **复用优先**:共享引擎(`tp--map-intervals`、`tp--stack-map-region`、`tp--pattern-apply`、`tp--replace-match-text`、`tp-reactive--buffer-layer-names`)承载重复逻辑,高层函数复用而非复制
restores the old generation, client state, and Ebox publication together. 5. **统一接口**:所有核心属性函数支持相同的调用约定(整串/区域形式、层名、`$var`、多参数层)
ETAF's outer flush records effect input/version tuples and applies a graph-size 6. **响应式解耦**tp-reactive/tp-layer/tp-ops 不依赖渲染引擎;不加载 tp-render 时钩子为 nil各模块优雅降级`tp-text` 替换自 0.3.0 起随 tp-ops 即可用);重渲染只访问层→缓冲区注册表登记的缓冲区,未知层才回退全扫描
derived step bound, so a repeated tuple or monotonic cycle becomes a
diagnostic instead of an unbounded dispatch.
## 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.
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.

View File

@ -1,69 +0,0 @@
# Reproducible benchmark guide
This document describes the benchmark runner shipped with TP 1.0. It measures
the current retained/reactive runtime; it is not a historical TP 0.3 stack
benchmark and it does not impose a release threshold.
## Run
Use the Makefile entry point:
~~~sh
make benchmark
~~~
The equivalent batch command is:
~~~sh
emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run
~~~
The runner uses fixed seeds 1, 7, 42, 747555 and generated seed 8675309. Each
scenario performs a correctness assertion before timing the operation. Record
the Emacs version, machine, seed, and full output when comparing runs.
## Scenarios
For every seed, the runner executes:
| Scenario | Fixtures |
| --- | --- |
| large-text | strings of 100,000 and 1,000,000 characters; set and presence-aware search |
| fragmented | 1,000, 10,000, and 50,000 alternating property intervals |
| retained-keyed-reconcile | retained content with 10, 100, and 1,000 stable keyed entries |
| signal-sparse-update | one target binding beside 1, 100, and 10,000 unrelated bindings |
| transaction-batch | 1, 100, and 10,000 writes to one retained surface |
| equal-write-noop | the same write counts, all equal to the committed value |
The retained scenarios verify stable object reconciliation, correct published
text, dependency-local recomputation, one publication for a batch, and no
revision change for equal writes. A failed assertion aborts the run instead of
producing misleading timing evidence.
## Output
Each row is a whitespace-separated key/value record. The stable fields are:
scenario, status, fixture, seed, requested, actual, operations, objects,
subscribers, invalidated, recomputed, skipped, text-operations,
property-operations, touched, revision, published, elapsed, gcs, and note.
The output is deliberately machine-readable enough for local comparison, but
it is not a compatibility format. Interpret it together with the scenario
source in tp-benchmark.el.
## Interpretation
These measurements are advisory. Runtime, garbage collection, Emacs build,
machine load, and buffer implementation details affect absolute timings.
Compare like-for-like runs, inspect correctness failures first, and use the
reports/counters to explain a regression:
- fragmented measures expose interval-run scaling;
- retained-keyed-reconcile measures keyed object reuse and publication work;
- signal-sparse-update checks that unrelated bindings are not recomputed;
- transaction-batch measures deduplicated recomputation and one surface commit;
- equal-write-noop checks that equal values do not publish a new revision.
For the contracts behind these scenarios, read [API semantics](API-SEMANTICS.md),
[architecture](ARCHITECTURE.md), and the [public API reference](API-REFERENCE.md).

View File

@ -1,12 +1,803 @@
# Code analysis历史归档 # tp.el 代码分析报告
这是早期 TP 0.1/0.3 的代码分析快照。它描述的 tp-render、tp-stack、tp-text、 > **历史文档说明2026-07 更新)**:本报告分析的是拆分前的单文件 tp.el0.1.0)。
inline metadata 和 managed registry 已被 TP 1.0 删除,因此本文不再是当前 > 自 0.2.0 起代码库已模块化为九个分层模块tp-core.el → tp-reactive.el → tp-layer.el →
实现的说明,也不应被用来推断可用 API。 > 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)。
> 下文的调用堆栈与问题分析保留为历史分析;"文件结构"与"关键代码位置"表已更新为当前模块位置。
当前代码的功能、用法和模块边界请阅读: 本报告旨在帮助想要参与 tp.el 开发的开发者快速了解项目结构、核心功能实现、以及潜在的优化方向。
- [TP 1.0 公共 API 参考](API-REFERENCE.md) ## 目录
- [API 语义合同](API-SEMANTICS.md)
- [当前架构](ARCHITECTURE.md) - [项目概述](#项目概述)
- [README](../README_CN.md) - [文件结构](#文件结构)
- [核心功能函数调用堆栈](#核心功能函数调用堆栈)
- [1. 文本属性设置 tp-set](#1-文本属性设置-tp-set)
- [2. 深度合并属性 tp-add](#2-深度合并属性-tp-add)
- [3. 属性层推送 tp-push-layer](#3-属性层推送-tp-push-layer)
- [4. 响应式层定义 define-tp](#4-响应式层定义-define-tp)
- [5. 响应式更新触发](#5-响应式更新触发)
- [6. 模式匹配 tp-match-set](#6-模式匹配-tp-match-set)
- [7. 搜索与遍历 tp-search-map](#7-搜索与遍历-tp-search-map)
- [关键数据结构](#关键数据结构)
- [潜在问题分析](#潜在问题分析)
- [架构优化建议](#架构优化建议)
- [开发入门指南](#开发入门指南)
---
## 项目概述
tp.el 是一个 Emacs Lisp 文本属性操作库,拆分前的单文件版本采用概念上的 **五层架构设计**
```
┌─────────────────────────────────────────────────────────────────┐
│ 第五层:高级 API │
│ tp-match-set, tp-regexp-set, tp-forward-do, tp-search-map │
├─────────────────────────────────────────────────────────────────┤
│ 第四层:响应式系统 │
│ define-tp, define-tps, tp--reactive-variable-watcher │
├─────────────────────────────────────────────────────────────────┤
│ 第三层:属性层系统 │
│ tp-push-layer, tp-pop-layer, tp-rotate-layer │
├─────────────────────────────────────────────────────────────────┤
│ 第二层:核心属性操作 │
│ tp-set, tp-reset, tp-add, tp-get, tp-at, tp-remove │
├─────────────────────────────────────────────────────────────────┤
│ 第一层:基础工具函数 │
│ tp--parse-args, tp--deep-merge-plist, tp-intervals │
└─────────────────────────────────────────────────────────────────┘
```
0.2.0 的模块拆分大体沿用了这一分层思路,并把"响应式系统向上调用高级 API"的
矛盾收拢为 tp-render.el 安装的钩子变量,详见 [ARCHITECTURE.md](ARCHITECTURE.md)。
---
## 文件结构
当前0.2.0)文件结构:
```
tp/
├── tp.el # 总入口按序加载全部模块62 行)
├── tp-core.el # 区间遍历、plist/face 合并引擎、调试、$var 工具781 行)
├── tp-reactive.el # 响应式依赖注册表、变量监听、批量队列370 行)
├── tp-layer.el # define-tp / define-tps、层注册表与解析1295 行)
├── tp-ops.el # 核心属性操作 tp-set/get/at/remove/...916 行)
├── tp-search.el # 模式匹配、搜索与导航810 行)
├── tp-render.el # 响应式重渲染引擎501 行)
├── tp-stack.el # 属性层栈操作709 行)
├── tp-palette.el # 明/暗主题调色板数据351 行)
├── tp-builtins.el # 内置层与辅助工具193 行)
├── tp-tests.el # 综合 ERT 测试套件4123 行280 个测试)
├── tp-*-tests.el # 各模块回归测试套件7 个文件159 个测试;全套共 439 个测试)
├── Makefile # test / compile / clean
├── docs/
│ ├── ARCHITECTURE.md # 架构文档
│ ├── CODE-ANALYSIS.md # 代码分析报告(本文档)
│ ├── reactive-text-properties.md # 响应式功能文档(中文)
│ ├── reactive-text-properties-en.md # 响应式功能文档(英文)
│ ├── reactive-optimization.md # 优化文档(中文)
│ └── reactive-optimization-en.md # 优化文档(英文)
├── README.md # 英文说明文档
└── README_CN.md # 中文说明文档
```
---
## 核心功能函数调用堆栈
### 1. 文本属性设置 tp-set
`tp-set` 是最核心的属性设置函数,支持三种调用方式。
#### 调用堆栈
```
tp-set (用户调用入口)
├─→ tp--parse-args (解析参数格式)
│ │
│ └─→ tp--resolve-props (解析属性,包括层名称)
│ │
│ ├─→ tp-layer-props (获取层定义的属性)
│ ├─→ tp--collect-reactive-symbols (收集 $var 符号)
│ ├─→ tp--resolve-reactive-symbols (解析为实际值)
│ └─→ tp--register-reactive-deps (注册响应式依赖)
├─→ tp--handle-tp-text-property (处理 tp-text 特殊属性)
│ │
│ └─→ (替换文本内容,如果 tp-text 存在)
└─→ put-text-property / propertize (Emacs 原生 API)
```
#### 关键代码位置
0.2.0 模块化后按"函数 → 模块文件"定位;文件内具体行号请用 `M-x xref-find-definitions` 查找。)
| 函数 | 模块文件 | 作用 |
|------|----------|------|
| `tp-set` | tp-ops.el | 主入口函数 |
| `tp--parse-args` | tp-ops.el | 解析多种调用格式 |
| `tp--resolve-props` | tp-layer.el | 展开层名称和响应式变量 |
| `tp--handle-tp-text-property` | tp-render.el | 处理 tp-text 文本替换(经钩子 `tp--tp-text-handler-function` 安装到 tp-ops |
| `tp-add` | tp-ops.el | 深度合并属性 |
| `tp-push-layer` | tp-stack.el | 推送层到栈顶 |
| `tp-put-layer` | tp-stack.el | 在指定位置放置层 |
| `define-tp` | tp-layer.el | 定义自定义层(宏)|
| `define-tps` | tp-layer.el | 定义层组(宏)|
| `tp--reactive-variable-watcher` | tp-reactive.el | 响应式变量监听器回调 |
| `tp--update-layer-regions` | tp-render.el | 更新使用层的文本区域 |
| `tp-search-map` | tp-search.el | 搜索并应用函数 |
| `tp--match-apply` | tp-search.el | 模式匹配内部实现 |
---
### 2. 深度合并属性 tp-add
`tp-add` 实现属性的深度合并,特别是 face 属性的智能合并。
#### 调用堆栈
```
tp-add (用户调用入口)
├─→ tp--parse-args (解析参数)
├─→ tp--handle-tp-text-property (处理 tp-text)
├─→ text-properties-at (获取现有属性)
├─→ tp--prepend-face (智能合并 face 属性)
│ │
│ └─→ tp--deep-merge-plist (递归合并 plist)
├─→ tp--deep-merge-plist (合并其他嵌套属性)
└─→ put-text-property (设置合并后的属性)
```
#### Face 合并逻辑
```elisp
;; 输入
(tp-add 1 10 '(face (:foreground "red"))) ; 已存在
(tp-add 1 10 '(face bold)) ; 新增
;; 结果: face 是 (bold (:foreground "red"))
;; - 符号 face 被前置到列表
;; - plist face 被深度合并
```
---
### 3. 属性层推送 tp-push-layer
`tp-push-layer` 将属性层推送到栈顶,实现多层属性的堆叠管理。
#### 调用堆栈
```
tp-push-layer (用户调用入口)
└─→ tp-put-layer (在指定索引放置层)
├─→ tp--normalize-layer-spec (规范化层规格)
│ │
│ └─→ tp-layer-props (获取层属性,添加 tp-name)
├─→ tp-group-props (如果是层组,获取所有层属性)
├─→ tp-empty-p (检查是否为空)
├─→ tp--get-layer-stack (获取现有层栈)
├─→ tp--build-layer-props (构建包含 tp-layers 的属性)
└─→ tp-intervals-map (遍历区间应用属性)
└─→ set-text-properties / put-text-property
```
#### 层栈存储结构
```elisp
;; 可见层属性直接存储为文本属性
;; 隐藏层存储在 tp-layers 属性中
;; 例如:两层栈
'(face (:foreground "red") ; 顶层(可见)属性
tp-name layer1 ; 顶层名称
tp-layers ; 下层列表
((face (:background "blue") ; 第一个隐藏层
tp-name layer2)))
```
---
### 4. 响应式层定义 define-tp
`define-tp` 宏定义支持响应式变量的自定义层。
#### 宏展开流程
```
define-tp (宏调用)
├─→ tp--parse-define-layer-args (解析 :props, :data, :compute, :watch, :transform)
├─→ tp--collect-reactive-symbols (收集所有 $var 符号)
├─→ tp--unregister-reactive-deps (如果重新定义,先清除旧依赖)
├─→ tp--ensure-reactive-variables (确保 $var 对应的变量已定义)
├─→ tp--register-layer-data (注册 :data 变量)
│ │
│ └─→ add-variable-watcher (为每个变量添加监听器)
├─→ tp--register-layer-computed (注册 :compute 计算属性)
├─→ tp--apply-initial-computed (计算初始值)
├─→ tp--register-reactive-deps (注册响应式依赖)
├─→ tp--register-layer-watchers (注册 :watch 回调)
├─→ tp--resolve-reactive-symbols (解析 $var 为当前值)
└─→ tp--set-layer-props (存储到 tp-layer-alist)
```
#### 关键数据结构
```elisp
;; 层定义存储
tp-layer-alist
;; => ((layer-name arglist body-form) ...)
;; 或 ((layer-name nil resolved-props) ...) ; 非参数化层
;; 响应式依赖
tp-reactive-deps
;; => ((my-color . ((my-layer . '(face (:foreground $my-color)))))
;; (my-bg . ((my-layer . '(face (:background $my-bg))))))
;; 计算属性
tp-layer-computed
;; => ((my-layer . ((full-name . (lambda () (concat first last))))))
;; 数据变量
tp-layer-data
;; => ((my-layer . (first-name last-name)))
;; 监听回调
tp-layer-watchers
;; => ((my-layer . ((first-name . (lambda (new old layer) ...)))))
;; 转换函数
tp-layer-transforms
;; => ((my-layer . (lambda (text) (upcase text))))
```
---
### 5. 响应式更新触发
当响应式变量通过 `setq` 改变时,自动触发更新。
#### 调用堆栈
```
(setq my-color "blue") ; 用户改变变量
└─→ tp--reactive-variable-watcher (由 add-variable-watcher 注册)
├─→ (检查是否在批量更新模式)
│ └─→ 如果是,添加到 tp--batch-update-pending 并返回
├─→ tp--invoke-layer-watchers (调用 :watch 回调)
├─→ tp--update-layer-computed (更新计算属性)
│ │
│ ├─→ (调用计算函数)
│ ├─→ tp--resolve-reactive-symbols (解析新值)
│ └─→ tp--set-layer-props (更新层定义)
├─→ tp--update-layer-regions (更新文本区域)
│ │
│ ├─→ tp-layer-props (获取新属性)
│ │
│ └─→ tp-search-map (遍历所有使用该层的区域)
│ │
│ └─→ tp-add (合并新属性)
└─→ tp--update-reactive-text (如果 tp-text 依赖该变量)
└─→ tp--replace-reactive-text-in-buffer
└─→ (删除旧文本,插入新文本)
```
#### 批量更新优化
```elisp
(tp-with-batch-updates
(setq my-color "red") ; 不立即更新
(setq my-bg "blue")) ; 不立即更新
;; 退出时一次性更新所有变化
;; 内部实现:
;; 1. 设置 tp--batch-update-active = t
;; 2. 变量变化被记录到 tp--batch-update-pending
;; 3. 退出时调用 tp--flush-batch-updates
```
---
### 6. 模式匹配 tp-match-set
`tp-match-set` 在字符串匹配处设置属性。
#### 调用堆栈
```
tp-match-set (用户调用入口)
└─→ tp--match-apply (内部实现)
├─→ (如果 OBJECT 是字符串copy-sequence 创建副本)
├─→ (循环搜索 PATTERN)
│ │
│ ├─→ search-forward / string-match
│ │
│ └─→ tp-set (在匹配区域设置属性)
└─→ (返回匹配区域列表或带属性字符串)
```
#### 支持多模式
```elisp
(tp-match-set '("TODO" "FIXME") '(face warning))
;; => 匹配所有 TODO 和 FIXME
```
---
### 7. 搜索与遍历 tp-search-map
`tp-search-map` 对所有匹配属性的区域应用转换函数。
#### 调用堆栈
```
tp-search-map (用户调用入口)
└─→ tp--search-do (内部搜索实现)
├─→ (区分字符串和缓冲区处理)
├─→ (对于字符串)
│ │
│ ├─→ text-property-search-forward (搜索)
│ │
│ └─→ (调用 FUNCTION传入 text, start, end, idx)
│ │
│ └─→ (替换匹配文本为函数返回值)
└─→ (对于缓冲区)
├─→ text-property-search-forward
└─→ (相同处理,但修改缓冲区)
```
#### 函数签名
```elisp
(tp-search-map
(lambda (text &optional start end idx)
(upcase text)) ; 返回值替换原文本
'marker ; 搜索的属性名
nil ; 值nil 表示不匹配值)
my-string ; 目标对象
0 ; 起始位置(可选)
100) ; 结束位置(可选)
```
---
## 关键数据结构
### 1. tp-layer-alist
存储所有层定义。
```elisp
;; 非参数化层
((highlight nil '(face (:background "yellow")))
(error nil '(face (:foreground "red"))))
;; 参数化层
((tp-space (pixel) `(display (space :width (,pixel)))))
```
### 2. tp-layer-groups
存储层组定义。
```elisp
((status-colors . (highlight error info))
(moon-phases . (moon-phases-new moon-phases-full)))
```
### 3. tp-reactive-deps
存储响应式依赖关系。
```elisp
;; 变量 -> ((层名 . 使用该变量的属性列表) ...)
((my-color . ((my-layer . '(face (:foreground $my-color)))
(other-layer . '(face (:background $my-color)))))
(my-size . ((size-layer . '(display (space :width $my-size))))))
```
### 4. 层栈结构
文本区域的层栈通过 `tp-name``tp-layers` 属性存储。
```elisp
;; 位置 1-10 的属性
'(face (:foreground "red") ; 可见属性
tp-name layer1 ; 顶层名称
help-echo "tip" ; 可见属性
tp-layers ; 隐藏层列表
((face (:background "blue") tp-name layer2)
(face (:underline t) tp-name layer3)))
```
---
## 潜在问题分析
### 1. 性能问题
#### 问题 1.1:响应式更新可能导致性能瓶颈
**现象**:当一个响应式变量被多个层使用,且这些层被应用到大量文本区域时,变量变化会触发大量更新。
**代码位置**`tp--update-layer-regions` 函数
**问题代码**
```elisp
(defun tp--update-layer-regions (var layer-name)
;; 遍历所有缓冲区
(dolist (buf (buffer-list))
;; 在每个缓冲区中搜索所有使用该层的区域
(tp-search-map (lambda (txt) ...) 'tp-name layer-name nil buf)))
```
**建议**
- 添加缓冲区级别的响应式依赖跟踪
- 只更新实际使用该层的缓冲区
- 考虑使用惰性更新策略
#### 问题 1.2tp-intervals 可能在大文件中变慢
**现象**`object-intervals` 返回整个对象的所有区间,然后过滤。
**建议**:对于大文件,考虑使用 `next-property-change` 进行增量遍历。
---
### 2. 内存问题
#### 问题 2.1:匿名层名称无限增长
**现象**`tp--anonymous-layer-counter` 只增不减,匿名层名称永不重用。
**代码位置**`tp--generate-anonymous-layer-name`
**建议**
- 使用弱引用跟踪匿名层
- 当层不再被使用时自动清理
#### 问题 2.2:响应式依赖可能泄漏
**现象**:如果缓冲区被杀死,但响应式依赖未清理,可能导致内存泄漏。
**建议**
- 添加 `kill-buffer-hook` 来清理缓冲区相关的依赖
- 定期检查并清理无效依赖
---
### 3. 功能问题
#### 问题 3.1:层栈深度无限制
**现象**:没有限制层栈的最大深度,可能导致性能问题。
**建议**:添加可配置的最大深度限制。
#### 问题 3.2:参数化层的参数验证不足
**现象**:参数化层不验证传入参数的类型和数量。
```elisp
(define-tp tp-space (pixel)
`(display (space :width (,pixel))))
;; 错误调用不会报错
(tp-set "test" 'tp-space) ; 缺少参数
```
**建议**:在层调用时添加参数验证。
---
### 4. 代码质量问题
#### 问题 4.1:部分函数过长
**现象**:某些函数超过 100 行,如 `tp--parse-args`、`tp-set`。
**建议**:拆分为更小的辅助函数。
#### 问题 4.2:文档字符串不一致
**现象**:部分内部函数缺少文档字符串。
**建议**:为所有公开函数和重要内部函数添加文档。
#### 问题 4.3:错误处理不完善
**现象**:某些边界情况没有清晰的错误消息。
```elisp
;; 调用未定义的层
(tp-set 1 10 'undefined-layer)
;; 可能静默失败或产生不明确的错误
```
**建议**:添加清晰的错误检查和消息。
---
### 5. 测试覆盖问题
#### 问题 5.1:某些边界情况未测试
**现象**:测试主要覆盖正常流程,边界情况覆盖不足。
**需要补充的测试**
- 空字符串/空缓冲区处理
- 极端层栈深度
- 循环依赖检测
- 并发修改场景
---
## 架构优化建议
### 1. 短期优化(低成本高收益)
#### 1.1 添加错误边界
```elisp
(defun tp-set (...)
"..."
(condition-case err
(tp--set-internal ...)
(error
(tp-debug-log "Error in tp-set: %s" err)
(signal (car err) (cdr err)))))
```
#### 1.2 添加性能日志
```elisp
(defmacro tp--with-timing (name &rest body)
"Execute BODY and log timing if tp-debug-mode is enabled."
`(let ((start (float-time)))
(prog1 (progn ,@body)
(when tp-debug-mode
(tp-debug-log "%s took %.3fms"
,name
(* 1000 (- (float-time) start)))))))
```
#### 1.3 参数验证
```elisp
(defun tp-layer-props (name &optional include-tp-name)
"Get properties for layer NAME."
(unless (symbolp name)
(error "Layer name must be a symbol: %S" name))
...)
```
### 2. 中期优化(改进用户体验)
#### 2.1 层定义的本地化
当前所有层定义是全局的。考虑支持缓冲区本地层:
```elisp
(define-tp-local my-local-layer ()
'(face bold))
```
#### 2.2 层的命名空间
避免层名冲突:
```elisp
(define-tp (my-package . highlight) ()
'(face (:background "yellow")))
```
#### 2.3 属性继承
允许层继承其他层:
```elisp
(define-tp error-highlight ()
:inherit 'base-highlight
:props '(face (:foreground "red")))
```
### 3. 长期优化(架构改进)
#### 3.1 响应式系统优化
考虑采用脏标记 + 批量更新模式:
```elisp
;; 标记脏数据
(defvar tp--dirty-layers nil)
;; 在 idle 时更新
(run-with-idle-timer 0.1 t #'tp--flush-dirty-layers)
```
#### 3.2 层栈优化
使用更高效的数据结构:
```elisp
;; 当前:列表
tp-layers -> ((props1) (props2) (props3))
;; 优化:使用向量
tp-layers -> [props1 props2 props3]
```
#### 3.3 增量更新
对于大区域,考虑增量更新:
```elisp
(defun tp--update-region-incremental (start end new-props)
"Update region incrementally using property change boundaries."
(let ((pos start))
(while (< pos end)
(let ((next (next-single-property-change pos 'tp-name nil end)))
(tp--update-single-interval pos next new-props)
(setq pos next)))))
```
---
## 开发入门指南
### 1. 开发环境设置
```elisp
;; 加载开发版本
(add-to-list 'load-path "/path/to/tp")
(require 'tp)
;; 启用调试模式
(setq tp-debug-mode t)
(setq tp-debug-echo t)
;; 运行测试(全套 439 个 ERT 测试)
;; make test
```
### 2. 添加新功能的步骤
1. **理解分层架构**
- 确定新功能属于哪个模块(见 [ARCHITECTURE.md](ARCHITECTURE.md)
- 遵循模块间调用规则(只调用前置模块的函数)
2. **编写测试用例**
- 在对应模块的 `tp-*-tests.el`(或综合套件 `tp-tests.el`)中添加测试
- 覆盖正常流程和边界情况
3. **实现功能**
- 添加必要的辅助函数
- 添加文档字符串
- 处理错误情况
4. **更新文档**
- 更新 README.md / README_CN.md
- 如果涉及架构变化,更新 ARCHITECTURE.md
### 3. 调试技巧
```elisp
;; 查看层定义
tp-layer-alist
;; 查看响应式依赖
tp-reactive-deps
;; 查看位置属性
(tp-at 5)
(tp-at 5 'face)
(tp-at 5 '(face :foreground))
;; 查看区间
(tp-intervals 1 100)
;; 查看调试日志
(tp-debug-show)
```
### 4. 常见开发任务
#### 添加新的核心属性函数
1. 在 `tp-ops.el` 添加函数
2. 使用 `tp--parse-args` 解析参数
3. 调用 Emacs 原生 API
4. 添加测试用例
#### 添加新的层栈操作函数
1. 在 `tp-stack.el` 添加函数
2. 使用 `tp--stack-map-region` 遍历区域内层栈
3. 使用 `tp--get-layer-stack` 获取层栈
4. 添加测试用例
#### 扩展响应式系统
1. 注册/监听逻辑放在 `tp-reactive.el`,渲染逻辑放在 `tp-render.el`
2. 使用 `add-variable-watcher` 注册监听
3. 在适当位置调用 `tp--update-layer-regions`(下层模块经钩子变量触发)
4. 添加测试用例
---
## 总结
tp.el 是一个设计精良的文本属性操作库,其核心创新包括:
1. **统一的 API 设计**:同一函数支持多种调用方式
2. **属性层系统**:实现了类似图层的属性管理
3. **响应式更新**:借鉴前端框架思想,实现数据驱动 UI
主要的改进方向:
1. **性能优化**:响应式更新的效率、大文件处理
2. **错误处理**:参数验证、清晰的错误消息
3. **代码质量**:函数拆分、文档完善、测试覆盖
对于想要参与开发的贡献者,建议:
1. 从理解测试用例开始
2. 使用调试模式跟踪执行流程
3. 遵循分层架构原则
4. 先写测试,后写实现
---
*报告生成时间: 2026-01-10分析对象拆分前的单文件 tp.el 0.1.0*
*文件结构与"关键代码位置"表更新于 2026-07-26tp 0.2.0 模块化后)*

View File

@ -1,11 +0,0 @@
# Repository audit历史归档
这是 TP 0.3 的仓库审计快照,不是当前实现的功能清单。快照中的旧 stack、
renderer、tp-text、扫描刷新和 registry 结论不能用于 TP 1.0。
当前仓库提供的功能和用法以以下文档及 source 为准:
- [TP 1.0 公共 API 参考](API-REFERENCE.md)
- [API 语义合同](API-SEMANTICS.md)
- [当前架构](ARCHITECTURE.md)
- [中文 README](../README_CN.md)

View File

@ -1,12 +1,212 @@
# Reactive optimization (historical archive) # tp.el Reactive System Optimization Documentation
This page is a TP 0.3 performance note. Its stack, tp-text, batch-update, 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.
legacy reactive bookkeeping, and scan-renderer discussion is not part of TP 1.0.
It is not a current performance baseline or implementation guide.
For the current runtime, read: ## Optimization Suggestions Evaluation
- [TP 1.0 public API reference](API-REFERENCE.md) The following evaluates and documents the implementation status of six optimization suggestions for the tp.el reactive system:
- [Current architecture](ARCHITECTURE.md)
- [Current benchmark guide](BENCHMARKS.md) ### 1. Granular Reactive Updates
- [README](../README.md)
**Suggestion**: Support partial updates within a region - only updating the reactive portion while preserving surrounding text properties.
**Evaluation**: Already implemented. tp.el uses `tp-search-map` over `tp-name`-tagged regions and interval-based update mechanisms to support fine-grained property updates. Updates only affect regions with specific `tp-name` properties, and only the layer's own property keys are replaced — properties contributed by other sources are left untouched.
### 2. Reactive Symbol Cleanup ✅ Already Implemented
**Suggestion**: Add a mechanism to unregister reactive symbols when widgets are destroyed.
**Evaluation**: Already implemented. The `tp--unregister-reactive-deps` function handles cleanup:
- Called automatically when a layer is redefined
- Called automatically when a layer is undefined (`tp-undefine-layer`)
- Cleans up variable watchers, computed properties, and data variables
**Key functions**:
- `tp--unregister-reactive-deps`
- `tp--unregister-layer-watchers`
- `tp--unregister-layer-computed`
- `tp--unregister-layer-data`
### 3. Scoped Reactivity ✅ Already Implemented
**Suggestion**: Add instance/context scoping for reactive variables.
**Evaluation**: Already implemented. The `where` parameter supports buffer-local updates in:
- `tp--update-layer-regions`
- `tp--update-reactive-text`
When using `setq-local`, updates only affect the specific buffer.
### 4. Batched Updates 🆕 New Feature
**Suggestion**: When multiple reactive values change simultaneously, batch updates to avoid redundant buffer modifications.
**Implementation**: Added `tp-with-batch-updates` macro:
```elisp
;; Using batch updates
(tp-with-batch-updates
(setq my-color "red")
(setq my-size 14)
(setq my-text "Hello"))
;; All updates applied to buffer once at the end
```
**Key functions and variables**:
- `tp-with-batch-updates` - Batch update macro
- `tp--batch-update-active` - Flag indicating batch mode
- `tp--batch-update-pending` - List of pending updates
- `tp--flush-batch-updates` - Apply all pending updates
### 5. Value Transformation 🆕 New Feature
**Suggestion**: Allow registering transformation functions that run when tp-text updates.
**Implementation**: Added `:transform` option:
```elisp
;; Define a layer with transformation
(define-tp currency-display ()
:props '(face bold tp-text $amount)
:data '((amount . "100"))
:transform (lambda (text)
(format "$%s.00" text)))
;; After application, 100 displays as $100.00
```
**Key functions and variables**:
- `tp-layer-transforms` - Stores layer transform functions
- Transforms applied in `tp--handle-tp-text-property` and `tp--update-reactive-text`
### 6. Debug Mode 🆕 New Feature
**Suggestion**: Add a debug mode to trace reactive updates.
**Implementation**: Added debug functionality:
```elisp
;; Enable debug mode
(setq tp-debug-mode t)
;; Also show debug info in minibuffer
(setq tp-debug-echo t)
;; View debug log
(tp-debug-show)
;; Clear debug log
(tp-debug-clear)
```
**Key functions and variables**:
- `tp-debug-mode` - Enable/disable debug mode
- `tp-debug-echo` - Whether to echo debug info to minibuffer
- `tp-debug-log` - Log debug information
- `tp-debug-show` - Show debug buffer
- `tp-debug-clear` - Clear debug log
Debug log includes:
- Variable change notifications (old → new value)
- Layer update tracking
- Batch update start/end
- Transform application info
## New Features in Detail
### Batch Updates (tp-with-batch-updates)
When modifying multiple reactive variables simultaneously, use batch updates to avoid multiple buffer updates:
```elisp
(define-tp themed-text ()
:props '(face (:foreground $fg-color :background $bg-color))
:data '((fg-color . "white") (bg-color . "black")))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 12 'themed-text)
;; Without batching: each setq triggers a buffer update
(setq fg-color "yellow") ; First update
(setq bg-color "navy") ; Second update
;; With batching: all changes applied once at the end
(tp-with-batch-updates
(setq fg-color "red")
(setq bg-color "blue"))) ; Only one update
```
### Value Transformation (:transform)
Transform functions allow processing tp-text values before display:
```elisp
;; Number formatting
(define-tp price-display ()
:props '(tp-text $price)
:data '((price . "99.9"))
:transform (lambda (text)
(format "$%.2f" (string-to-number text))))
;; Date formatting
(define-tp date-display ()
:props '(tp-text $timestamp)
:data '((timestamp . "1703865600"))
:transform (lambda (text)
(format-time-string "%Y-%m-%d"
(seconds-to-time (string-to-number text)))))
;; Uppercase conversion
(define-tp uppercase-text ()
:props '(tp-text $content)
:data '((content . "hello"))
:transform #'upcase)
```
### Debug Mode
Debug mode helps developers understand the reactive update flow:
```elisp
;; Enable full debugging
(setq tp-debug-mode t)
(setq tp-debug-echo t)
;; Define and use a reactive layer
(define-tp test-layer ()
:props '(face (:foreground $my-color))
:data '((my-color . "red")))
(with-temp-buffer
(insert "Test")
(tp-set 1 5 'test-layer)
(setq my-color "blue"))
;; Example debug output:
;; [12:34:56.789] Variable my-color changed: "red" -> "blue" (where: global)
;; [12:34:56.790] Updating layer test-layer (tp-text affected: no)
```
## Architecture Notes
These optimizations follow tp.el's layered architecture principles:
1. **Debug Mode** - Basic utility layer functionality (`tp-core.el`)
2. **Batch Updates** - Implemented in the reactive system layer (`tp-reactive.el`)
3. **Value Transformation** - Implemented in layer definition and reactive text handling (`tp-layer.el` / `tp-render.el`)
All new features integrate seamlessly with the existing reactive system without breaking existing APIs.
## Function Reference
| Function/Variable | Description |
|------------------|-------------|
| `tp-debug-mode` | Enable debug mode |
| `tp-debug-echo` | Enable minibuffer debug output |
| `tp-debug-log` | Log debug information |
| `tp-debug-show` | Show debug buffer |
| `tp-debug-clear` | Clear debug log |
| `tp-with-batch-updates` | Batch update macro |
| `tp-layer-transforms` | Layer transform function storage |
| `:transform` | Transform option in layer definition |

View File

@ -1,12 +1,212 @@
# Reactive optimization历史归档 # tp.el 响应式系统优化文档
本文是 TP 0.3 的性能分析记录,所讨论的 stack、tp-text、batch update、 本文档基于 [twidget](https://github.com/Kinneyzhang/twidget.git) 项目的实践经验,对 tp.el 的响应式系统进行了优化和增强。
旧 reactive bookkeeping 和扫描式 renderer 已不属于 TP 1.0。它不提供当前
性能基线,也不应作为实现指导。
当前行为和 API 见: ## 优化建议评估
- [TP 1.0 公共 API 参考](API-REFERENCE.md) 以下是针对 tp.el 响应式系统的六项优化建议的评估和实现情况:
- [当前架构](ARCHITECTURE.md)
- [当前 benchmark 说明](BENCHMARKS.md) ### 1. 细粒度响应式更新Granular Reactive Updates
- [README](../README_CN.md)
**建议**:支持区域内的部分更新,只更新响应式部分,保留周围文本属性。
**评估**已经实现。tp.el 通过在带 `tp-name` 标记的区域上使用 `tp-search-map`,以及基于区间的更新机制,已经支持细粒度的属性更新。更新只影响具有特定 `tp-name` 的区域,并且只替换该层自身的属性键——由其他来源贡献的属性保持不变。
### 2. 响应式符号清理Reactive Symbol Cleanup✅ 已实现
**建议**:当 widget 销毁时,添加注销响应式符号的机制。
**评估**:已经实现。`tp--unregister-reactive-deps` 函数负责清理:
- 当层被重新定义时自动调用
- 当层被取消定义(`tp-undefine-layer`)时自动调用
- 清理变量监听器、计算属性和数据变量
**关键函数**
- `tp--unregister-reactive-deps`
- `tp--unregister-layer-watchers`
- `tp--unregister-layer-computed`
- `tp--unregister-layer-data`
### 3. 作用域响应式Scoped Reactivity✅ 已实现
**建议**:为响应式变量添加实例/上下文作用域。
**评估**:已经实现。`where` 参数在以下函数中支持缓冲区局部更新:
- `tp--update-layer-regions`
- `tp--update-reactive-text`
当使用 `setq-local` 时,更新只影响特定缓冲区。
### 4. 批量更新Batched Updates🆕 新增
**建议**:当多个响应式值同时变化时,批量处理更新以避免冗余的缓冲区修改。
**实现**:新增 `tp-with-batch-updates` 宏:
```elisp
;; 使用批量更新
(tp-with-batch-updates
(setq my-color "red")
(setq my-size 14)
(setq my-text "Hello"))
;; 所有更新在批量结束后一次性应用到缓冲区
```
**关键函数和变量**
- `tp-with-batch-updates` - 批量更新宏
- `tp--batch-update-active` - 标记是否在批量更新中
- `tp--batch-update-pending` - 待处理的更新列表
- `tp--flush-batch-updates` - 应用所有待处理更新
### 5. 值转换Value Transformation🆕 新增
**建议**:允许注册转换函数,在 tp-text 更新时运行。
**实现**:新增 `:transform` 选项:
```elisp
;; 定义带转换的层
(define-tp currency-display ()
:props '(face bold tp-text $amount)
:data '((amount . "100"))
:transform (lambda (text)
(format "$%s.00" text)))
;; 使用后100 会显示为 $100.00
```
**关键函数和变量**
- `tp-layer-transforms` - 存储层转换函数
- 转换在 `tp--handle-tp-text-property``tp--update-reactive-text` 中应用
### 6. 调试模式Debug Mode🆕 新增
**建议**:添加调试模式以追踪响应式更新。
**实现**:新增调试功能:
```elisp
;; 启用调试模式
(setq tp-debug-mode t)
;; 同时在 minibuffer 显示调试信息
(setq tp-debug-echo t)
;; 查看调试日志
(tp-debug-show)
;; 清除调试日志
(tp-debug-clear)
```
**关键函数和变量**
- `tp-debug-mode` - 启用/禁用调试模式
- `tp-debug-echo` - 是否在 minibuffer 显示调试信息
- `tp-debug-log` - 记录调试信息
- `tp-debug-show` - 显示调试缓冲区
- `tp-debug-clear` - 清除调试日志
调试日志包含:
- 变量变化通知(旧值 → 新值)
- 层更新追踪
- 批量更新开始/结束
- 转换应用信息
## 新增功能详解
### 批量更新 (tp-with-batch-updates)
当需要同时修改多个响应式变量时,使用批量更新可以避免多次缓冲区更新:
```elisp
(define-tp themed-text ()
:props '(face (:foreground $fg-color :background $bg-color))
:data '((fg-color . "white") (bg-color . "black")))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 12 'themed-text)
;; 不使用批量更新:每个 setq 都会触发一次缓冲区更新
(setq fg-color "yellow") ; 第一次更新
(setq bg-color "navy") ; 第二次更新
;; 使用批量更新:所有变化在结束时一次性应用
(tp-with-batch-updates
(setq fg-color "red")
(setq bg-color "blue"))) ; 只更新一次
```
### 值转换 (:transform)
转换函数允许在显示前处理 tp-text 的值:
```elisp
;; 数字格式化
(define-tp price-display ()
:props '(tp-text $price)
:data '((price . "99.9"))
:transform (lambda (text)
(format "$%.2f" (string-to-number text))))
;; 日期格式化
(define-tp date-display ()
:props '(tp-text $timestamp)
:data '((timestamp . "1703865600"))
:transform (lambda (text)
(format-time-string "%Y-%m-%d"
(seconds-to-time (string-to-number text)))))
;; 大写转换
(define-tp uppercase-text ()
:props '(tp-text $content)
:data '((content . "hello"))
:transform #'upcase)
```
### 调试模式
调试模式帮助开发者理解响应式更新流程:
```elisp
;; 启用完整调试
(setq tp-debug-mode t)
(setq tp-debug-echo t)
;; 定义和使用响应式层
(define-tp test-layer ()
:props '(face (:foreground $my-color))
:data '((my-color . "red")))
(with-temp-buffer
(insert "Test")
(tp-set 1 5 'test-layer)
(setq my-color "blue"))
;; 调试输出示例:
;; [12:34:56.789] Variable my-color changed: "red" -> "blue" (where: global)
;; [12:34:56.790] Updating layer test-layer (tp-text affected: no)
```
## 架构说明
这些优化遵循 tp.el 的分层架构原则:
1. **调试模式** - 作为基础工具层功能(`tp-core.el`
2. **批量更新** - 在响应式系统层实现(`tp-reactive.el`
3. **值转换** - 在层定义和响应式文本处理中实现(`tp-layer.el` / `tp-render.el`
所有新功能都与现有的响应式系统无缝集成,不破坏现有 API。
## 相关函数一览
| 函数/变量 | 描述 |
|----------|------|
| `tp-debug-mode` | 启用调试模式 |
| `tp-debug-echo` | 启用 minibuffer 调试输出 |
| `tp-debug-log` | 记录调试信息 |
| `tp-debug-show` | 显示调试缓冲区 |
| `tp-debug-clear` | 清除调试日志 |
| `tp-with-batch-updates` | 批量更新宏 |
| `tp-layer-transforms` | 层转换函数存储 |
| `:transform` | 层定义中的转换选项 |

View File

@ -1,17 +1,507 @@
# Reactive text properties (historical archive) # tp.el Complete Guide to Reactive Text Properties
This page records TP 0.3-era design and implementation work. It is not a TP 1.0 > Bringing modern frontend framework reactive programming paradigms to the Emacs text properties world
usage guide. The old tp-text, tp-render, tp-stack, $variable, inline metadata,
and scan-driven refresh behavior described by the historical material was
removed from the current runtime. Do not copy its APIs or examples.
Read the current documentation instead: ## Introduction
- [TP 1.0 public API reference](API-REFERENCE.md) In traditional Emacs development, managing text properties has always been a tedious task. Whenever you want to change a property value, you need to manually find all related text regions and update them one by one. This approach is not only error-prone but also difficult to maintain.
- [API semantics](API-SEMANTICS.md)
- [Current architecture](ARCHITECTURE.md)
- [README](../README.md)
In TP 1.0, use direct property APIs/recipes for static declarations, tp-watch **Reactive Text Properties** is one of the most innovative features in the tp.el library. It borrows the reactive programming concepts from modern frontend frameworks like Vue.js and React, allowing Emacs text properties to **automatically respond to variable changes**.
for reactive properties on host-owned text, and a content surface for text
owned by TP. Imagine: you define the relationship between a variable and a property once, and from then on, whenever you change the variable's value, all text regions using that variable will **automatically update**. This is the magic of reactive text properties!
## From Traditional to Reactive
### Pain Points of the Traditional Approach
Let's first look at how the traditional approach handles dynamic text properties:
```lisp
;; Traditional approach: define a color variable
(defvar my-color "red")
(tp-pop-to-buffer "*tp-test*"
(insert "Hello World")
(tp-set 1 12 `(face (:foreground ,my-color)))
;; Here comes the problem: when you want to change the color...
(setq my-color "blue")
;; The text doesn't update automatically! You must manually reapply:
(tp-set 1 12 `(face (:foreground ,my-color))))
```
The problems with this approach are obvious:
1. **Manual tracking**: You need to remember which text regions use which variables
2. **Easy to miss**: In complex applications, it's easy to forget to update some regions
3. **Code redundancy**: Update logic is scattered throughout the code
### The Elegance of Reactive Approach
Now let's see how the reactive approach solves these problems:
```lisp
;; Reactive approach: define a color variable
(defvar my-color "red")
;; Define a reactive layer using $my-color to reference the variable
(define-tp my-highlight ()
'(face (:foreground $my-color)))
;; Apply to text
(tp-pop-to-buffer "*tp-test*"
(insert "Hello World")
(tp-set 1 12 'my-highlight)
;; Now, just change the variable!
(setq my-color "blue")
;; Magic happens: the text automatically turns blue!
)
```
Isn't that amazing? Let's dive deep into how this powerful feature works.
## Core Concepts
### Reactive Variables
In tp.el, any symbol starting with `$` is treated as a **reactive variable**. For example:
- `$my-color` → references variable `my-color`
- `$font-size` → references variable `font-size`
- `$theme-background` → references variable `theme-background`
When you use these `$`-prefixed symbols in property definitions, tp.el will:
1. Automatically resolve the variable's current value
2. Register a watcher to monitor variable changes
3. When the variable changes, automatically update all related text regions
## Basic Usage
### Your First Reactive Layer
Let's start with a simple example:
```lisp
;; Define a global variable
(defvar highlight-bg "yellow")
;; Define a reactive layer
(define-tp simple-highlight ()
'(face (:background $highlight-bg)))
;; Create a test buffer and apply the layer
(tp-pop-to-buffer "*tp-test*"
(insert "This is text that needs highlighting")
(tp-set 1 (point-max) 'simple-highlight)
;; => "Initial background color: yellow"
;; Change the variable
(setq highlight-bg "cyan")
;; => "Updated background color: cyan"
)
```
### Multiple Reactive Variables
A layer can reference multiple reactive variables:
```lisp
;; Define multiple variables
(defvar fg-color "white")
(defvar bg-color "darkGreen")
(defvar underline-color "red")
;; Define a layer using multiple variables
(define-tp multi-var-layer ()
'(face ( :foreground $fg-color
:background $bg-color
:underline (:color $underline-color))))
;; Test
(tp-pop-to-buffer "*tp-test*"
(insert "Multi-variable reactive example")
(tp-set 1 (point-max) 'multi-var-layer)
;; Changing any variable triggers an update
(setq fg-color "yellow") ; Foreground turns yellow
(setq bg-color "navy") ; Background turns navy
(setq underline-color "lime") ; Underline turns lime green
)
```
## Advanced Features: :data, :compute, and :watch
tp.el's reactive system borrows from Vue's API, providing three powerful keywords:
### :data - Define Additional Reactive State
Sometimes you need reactive variables that aren't directly used in `:props`. This is where `:data` comes in.
Main uses of `:data`:
1. Define auxiliary variables that don't appear directly in properties
2. Provide initial values for variables
3. Work together with `:compute`
### :compute - Computed Properties
`:compute` lets you define **derived values**—their values are computed from other variables:
```lisp
;; Complete computed properties example
(define-tp computed-greeting ()
:props '(display $full-greeting face (:foreground $status-color))
:data '((user-name . "John")
(greeting-prefix . "Hello"))
:compute '((full-greeting (lambda ()
(format "%s, %s! Welcome back."
greeting-prefix user-name)))
(status-color (lambda ()
(if (string= user-name "Admin")
"red"
"green")))))
;; Test
(tp-pop-to-buffer "*tp-test*"
(insert "Test text")
(tp-set 1 (point-max) 'computed-greeting)
;; Initial state
(message "full-greeting = %s" full-greeting)
;; => "Hello, John! Welcome back."
(message "status-color = %s" status-color)
;; => "green"
;; Change user-name
(setq user-name "Admin")
;; Computed properties update automatically!
(message "full-greeting = %s" full-greeting)
;; => "Hello, Admin! Welcome back."
(message "status-color = %s" status-color)
;; => "red"
;; Change greeting-prefix
(setq greeting-prefix "Hi")
(message "full-greeting = %s" full-greeting))
;; => "Hi, Admin! Welcome back."
```
### :watch - Watch Variable Changes
`:watch` lets you execute **side effect** operations when variables change:
```lisp
;; Layer with watchers
(define-tp watched-layer ()
:props '(face (:foreground $status-color))
:data '((status-color . "green"))
:watch '((status-color
(lambda (new-val old-val layer-name)
(message "[%s] Color changed from %s to %s"
layer-name old-val new-val)))))
;; Test
(tp-pop-to-buffer "*tp-test*"
(insert "Test text")
(tp-set 1 (point-max) 'watched-layer)
;; Change color - triggers watcher
(setq status-color "yellow")
;; Message: "[watched-layer] Color changed from green to yellow"
(setq status-color "red"))
;; Message: "[watched-layer] Color changed from yellow to red"
```
Typical uses for `:watch`:
- Logging
- Updating external state
- Triggering notifications
- Performing cleanup operations
## Complete Practical Examples
### Example 1: Dynamic Color Status Indicator
This example shows how to create an indicator that automatically changes color based on status:
```lisp
(tp-layer-reset)
;; Define status color variables
(defvar status-color "gray")
(defvar status-text "Not Started")
;; Define status indicator layer
(define-tp status-indicator ()
'(face (:background $status-color) display $status-text))
;; Define status update function
(defun set-status (status)
"Set status, automatically update color and text"
(pcase status
('pending (setq status-color "gray" status-text "Pending"))
('running (setq status-color "blue" status-text "Running"))
('success (setq status-color "green" status-text "Success"))
('warning (setq status-color "orange" status-text "Warning"))
('error (setq status-color "red" status-text "Error"))))
;; Test the status indicator
(tp-pop-to-buffer "*tp-test*"
(insert "Status")
(tp-set 1 (point-max) 'status-indicator)
;; Simulate status changes
(set-status 'pending)
(message "Status: %s, Color: %s" status-text status-color)
;; => "Status: Pending, Color: gray"
(set-status 'running)
(message "Status: %s, Color: %s" status-text status-color)
;; => "Status: Running, Color: blue"
(set-status 'success)
(message "Status: %s, Color: %s" status-text status-color))
;; => "Status: Success, Color: green"
```
### Example 2: Theme Switching System
This example shows how to create a switchable theme system:
```lisp
(tp-layer-reset)
;; Define theme color variables
(defvar keyword-color nil)
(defvar string-color nil)
;; Define theme-related reactive layers
(define-tp themed-keyword ()
'(face (:foreground $keyword-color :weight bold)))
(define-tp themed-string ()
'(face (:foreground $string-color)))
;; Define theme switching functions
(defun switch-to-dark-theme ()
"Switch to dark theme"
(interactive)
(setq keyword-color "light blue"
string-color "green")
(message "Switched to dark theme"))
(defun switch-to-light-theme ()
"Switch to light theme"
(interactive)
(setq keyword-color "blue"
string-color "dark green")
(message "Switched to light theme"))
;; Test theme switching
(tp-pop-to-buffer "*tp-test*"
(insert "(defun hello () \"greeting\")")
;; Apply different theme layers
(tp-match-set "defun" 'themed-keyword)
(tp-regexp-set "\".+\"" 'themed-string)
(switch-to-dark-theme)
;; Initially using dark theme
(message "Keyword color: %s" keyword-color)
(message "String color: %s" string-color)
;; Switch to light theme
(switch-to-light-theme)
;; Text updates automatically!
(message "Keyword color: %s" keyword-color)
(message "String color: %s" string-color))
```
## Anonymous Reactive Layers
Besides using `define-tp` to define named layers, you can also use reactive variables directly in property lists. tp.el will automatically generate unique names for these anonymous layers:
```lisp
(tp-layer-reset)
(defvar inline-color "purple")
(tp-pop-to-buffer "*tp-test*"
(insert "Anonymous reactive layer example")
;; Use $inline-color directly, no need to pre-define a layer
(tp-set 1 (point-max) '(face (:foreground $inline-color)))
;; Text is now purple
(message "Color: %s" (plist-get (tp-at 1 'face) :foreground))
;; => "purple"
;; Change the variable
(setq inline-color "orange")
;; Text automatically turns orange
(message "Color: %s" (plist-get (tp-at 1 'face) :foreground)))
;; => "orange"
```
Anonymous reactive layers are suitable for simple scenarios where you don't need to reuse the same layer definition in multiple places.
## Reactive Text (tp-text)
Besides reactive text **properties**, tp.el also supports reactive **text content** itself. Through the special `tp-text` property, you can make the text content reactive too—when the bound variable changes, the text content automatically updates.
### Basic Usage
The `tp-text` property has two ways to use:
#### 1. Initialize with Current Text
When `tp-text` is `nil`, it will be automatically set to the current region's text content:
```lisp
(tp-pop-to-buffer "*tp-test*"
(insert "Hello World")
;; When tp-text is nil, auto-initialize to current text "Hello"
(tp-set 1 6 '(face bold tp-text nil))
;; Now tp-text value is "Hello"
(message "tp-text = %s" (tp-at 1 'tp-text)))
;; => "Hello"
```
#### 2. Replace Text Content
When `tp-text` is a string, it replaces the text in the region while preserving other text properties:
```lisp
(tp-pop-to-buffer "*tp-test*"
(insert "Hello World")
;; When tp-text is a string, replace the text content
(tp-set 1 6 '(face bold tp-text "Hi"))
;; Text becomes "Hi World", and "Hi" still has bold style
(message "buffer = %s" (buffer-string)))
;; => "Hi World"
```
### Reactive Text Layers
The real power of `tp-text` comes from combining it with reactive variables:
```lisp
;; Define a reactive variable
(defvar my-dynamic-text "Loading...")
;; Define a layer containing tp-text
(define-tp dynamic-content ()
:props '(face (:foreground "blue") tp-text $my-dynamic-text))
;; Apply to text
(tp-pop-to-buffer "*tp-test*"
(insert "placeholder")
(tp-set 1 12 'dynamic-content)
;; Text now shows "Loading..."
(message "Initial text: %s" (buffer-string))
;; => "Loading..."
;; Change the variable
(setq my-dynamic-text "Data loaded successfully!")
;; Text updates automatically!
(message "After update: %s" (buffer-string)))
;; => "Data loaded successfully!"
```
### Using :compute for Dynamic Text
`tp-text` can be combined with `:compute` to create dynamic text derived from other variables:
```lisp
(define-tp greeting-layer ()
:props '(face (:foreground "green") tp-text $full-greeting)
:data '((user-name . "Guest")
(greeting-prefix . "Welcome"))
:compute '((full-greeting
(lambda ()
(format "%s, %s!" greeting-prefix user-name)))))
;; Apply to text
(tp-pop-to-buffer "*tp-test*"
(insert "placeholder")
(tp-set 1 12 'greeting-layer)
;; Shows "Welcome, Guest!"
(message "Initial: %s" (buffer-string))
;; Change user name
(setq user-name "John")
;; Text automatically updates to "Welcome, John!"
(message "After update: %s" (buffer-string)))
```
### Anonymous Reactive Text
You can also use reactive `tp-text` directly in property lists without defining a layer:
```lisp
(defvar inline-text "Original content")
(tp-pop-to-buffer "*tp-test*"
(insert "placeholder")
;; Directly use reactive tp-text
(tp-set 1 12 '(face bold tp-text $inline-text))
;; Shows "Original content"
;; Change the variable
(setq inline-text "New content")
;; Text automatically updates to "New content"
)
```
### Important Notes
1. **tp-text on strings returns a new string**: Emacs strings cannot change length in place, so string-object calls return a new string instead of modifying the original. A sub-region `tp-text` replaces only that region and keeps the rest of the string; the whole-string form returns just the replacement text.
2. **Preserves existing properties**: When using `tp-set` or `tp-add` to set `tp-text`, existing text properties are preserved.
3. **Non-reactive properties don't add tp-name**: If there are no reactive variables (`$` prefix) in the text properties, `tp-name` and other reactive-specific properties won't be added, maintaining native text property behavior.
## Value Transformation with :transform
The `:transform` keyword allows you to register a transformation function that processes `tp-text` values before they are displayed. This is useful for formatting numbers, dates, or other values:
```lisp
;; Number formatting
(define-tp price-display ()
:props '(tp-text $price)
:data '((price . "99.9"))
:transform (lambda (text)
(format "$%.2f" (string-to-number text))))
;; 99.9 displays as $99.90
;; Date formatting
(define-tp date-display ()
:props '(tp-text $timestamp)
:data '((timestamp . "1703865600"))
:transform (lambda (text)
(format-time-string "%Y-%m-%d"
(seconds-to-time (string-to-number text)))))
;; Uppercase conversion
(define-tp uppercase-text ()
:props '(tp-text $content)
:data '((content . "hello"))
:transform #'upcase)
;; "hello" displays as "HELLO"
```
The transform function:
- Receives the raw `tp-text` string value
- Returns the transformed string for display
- Is applied both on initial display and reactive updates
- Errors in transform functions are caught and logged
> 📖 **For more optimization features like batched updates and debug mode, see [Reactive System Optimization](reactive-optimization-en.md)**
## Summary
tp.el's reactive text properties feature brings a modern reactive programming experience to Emacs development. By using `$`-prefixed reactive variables, `:data` to define state, `:compute` for derived values, `:watch` to monitor changes, and `:transform` for value formatting, you can build a more dynamic and maintainable text property system.
Key points:
1. **Reactive Variables**: Use `$` prefix to reference variables
2. **:props**: Define properties containing reactive variables
3. **:data**: Define additional reactive state and initial values
4. **:compute**: Define computed properties derived from other variables
5. **:watch**: Watch variable changes and execute side effects
6. **:transform**: Transform tp-text values before display
7. **Automatic Updates**: Change variable values, all related text updates automatically
8. **Reactive Text (tp-text)**: Make text content itself reactive

View File

@ -1,15 +1,507 @@
# Reactive text properties历史归档 # tp.el 响应式文本属性完全指南
本文是 TP 0.3 时代的设计/实现记录,不是 TP 1.0 用法文档。正文中出现的 > 将现代前端框架的响应式编程范式带入 Emacs 文本属性世界
tp-text、tp-render、tp-stack、$variable、inline metadata、扫描式刷新等
内容已经从当前运行时删除;不要复制其中的 API 或示例。
当前实现请阅读: ## 引言
- [TP 1.0 公共 API 参考](API-REFERENCE.md) 在传统的 Emacs 开发中文本属性text properties的管理一直是一个繁琐的任务。每当你想要改变某个属性值时你需要手动找到所有相关的文本区域然后逐一更新它们。这种方式不仅容易出错而且难以维护。
- [API 语义合同](API-SEMANTICS.md)
- [当前架构](ARCHITECTURE.md)
- [中文 README](../README_CN.md)
TP 1.0 中,静态声明使用 direct property API/recipe已有 host text 的响应式 **响应式文本属性**是 tp.el 库中最具创新性的功能之一。它借鉴了 Vue.js、React 等现代前端框架的响应式编程思想,让 Emacs 的文本属性能够**自动响应变量的变化**。
属性使用 tp-watchTP 自己拥有的响应式文字使用 content surface。
想象一下:你只需要定义一次变量与属性的关系,之后无论何时改变变量的值,所有使用该变量的文本区域都会**自动更新**。这就是响应式文本属性的魔力!
## 从传统方式到响应式方式
### 传统方式的痛点
让我们先看看传统方式如何处理动态文本属性:
```lisp
;; 传统方式:定义一个颜色变量
(defvar my-color "red")
(tp-pop-to-buffer "*tp-test*"
(insert "Hello World")
(tp-set 1 12 `(face (:foreground ,my-color)))
;; 问题来了:当你想改变颜色时...
(setq my-color "blue")
;; 文本不会自动更新!你必须手动重新应用:
(tp-set 1 12 `(face (:foreground ,my-color))))
```
这种方式的问题显而易见:
1. **手动追踪**:你需要记住哪些文本区域使用了哪些变量
2. **容易遗漏**:在复杂应用中很容易忘记更新某些区域
3. **代码冗余**:更新逻辑散落在代码各处
### 响应式方式的优雅
现在让我们看看响应式方式如何解决这些问题:
```lisp
;; 响应式方式:定义一个颜色变量
(defvar my-color "red")
;; 定义一个响应式层,使用 $my-color 引用变量
(define-tp my-highlight ()
'(face (:foreground $my-color)))
;; 应用到文本
(tp-pop-to-buffer "*tp-test*"
(insert "Hello World")
(tp-set 1 12 'my-highlight)
;; 现在,只需改变变量!
(setq my-color "blue")
;; 神奇的事情发生了:文本自动变成蓝色!
)
```
是不是很神奇?让我们深入了解这个强大功能的工作原理。
## 核心概念
### 响应式变量
在 tp.el 中,任何以 `$` 符号开头的符号都被视为**响应式变量**。例如:
- `$my-color` → 引用变量 `my-color`
- `$font-size` → 引用变量 `font-size`
- `$theme-background` → 引用变量 `theme-background`
当你在属性定义中使用这些 `$` 前缀的符号时tp.el 会:
1. 自动解析变量的当前值
2. 注册一个监听器,监视变量的变化
3. 当变量改变时,自动更新所有相关的文本区域
## 基础用法
### 第一个响应式层
让我们从一个简单的例子开始:
```lisp
;; 定义一个全局变量
(defvar highlight-bg "yellow")
;; 定义响应式层
(define-tp simple-highlight ()
'(face (:background $highlight-bg)))
;; 创建测试缓冲区并应用层
(tp-pop-to-buffer "*tp-test*"
(insert "这是一段需要高亮的文本")
(tp-set 1 (point-max) 'simple-highlight)
;; => "初始背景色: yellow"
;; 改变变量
(setq highlight-bg "cyan")
;; => "更新后背景色: cyan"
)
```
### 多个响应式变量
一个层可以引用多个响应式变量:
```lisp
;; 定义多个变量
(defvar fg-color "white")
(defvar bg-color "darkGreen")
(defvar underline-color "red")
;; 定义使用多个变量的层
(define-tp multi-var-layer ()
'(face ( :foreground $fg-color
:background $bg-color
:underline (:color $underline-color))))
;; 测试
(tp-pop-to-buffer "*tp-test*"
(insert "多变量响应式示例")
(tp-set 1 (point-max) 'multi-var-layer)
;; 改变任何一个变量都会触发更新
(setq fg-color "yellow") ; 前景色变黄
(setq bg-color "navy") ; 背景色变海军蓝
(setq underline-color "lime") ; 下划线变酸橙绿
)
```
## 进阶功能::data、:compute 和 :watch
tp.el 的响应式系统借鉴了 Vue 的 API提供了三个强大的关键字
### :data - 定义额外的响应式状态
有时候你需要一些响应式变量,但它们不直接用于 `:props` 中。这时可以使用 `:data`
`:data` 的主要用途:
1. 定义不直接出现在属性中的辅助变量
2. 为变量提供初始值
3. 与 `:compute` 配合使用
### :compute - 计算属性
`:compute` 让你可以定义**派生值**——它们的值由其他变量计算得出:
```lisp
;; 完整的计算属性示例
(define-tp computed-greeting ()
:props '(display $full-greeting face (:foreground $status-color))
:data '((user-name . "张三")
(greeting-prefix . "你好"))
:compute '((full-greeting (lambda ()
(format "%s, %s欢迎回来。"
greeting-prefix user-name)))
(status-color (lambda ()
(if (string= user-name "管理员")
"red"
"green")))))
;; 测试
(tp-pop-to-buffer "*tp-test*"
(insert "测试文本")
(tp-set 1 (point-max) 'computed-greeting)
;; 初始状态
(message "full-greeting = %s" full-greeting)
;; => "你好, 张三!欢迎回来。"
(message "status-color = %s" status-color)
;; => "green"
;; 改变 user-name
(setq user-name "管理员")
;; 计算属性自动更新!
(message "full-greeting = %s" full-greeting)
;; => "你好, 管理员!欢迎回来。"
(message "status-color = %s" status-color)
;; => "red"
;; 改变 greeting-prefix
(setq greeting-prefix "您好")
(message "full-greeting = %s" full-greeting))
;; => "您好, 管理员!欢迎回来。"
```
### :watch - 监听变量变化
`:watch` 让你可以在变量改变时执行**副作用**操作:
```lisp
;; 带监听器的层
(define-tp watched-layer ()
:props '(face (:foreground $status-color))
:data '((status-color . "green"))
:watch '((status-color
(lambda (new-val old-val layer-name)
(message "【%s】颜色从 %s 变为 %s"
layer-name old-val new-val)))))
;; 测试
(tp-pop-to-buffer "*tp-test*"
(insert "测试文本")
(tp-set 1 (point-max) 'watched-layer)
;; 改变颜色 - 触发监听器
(setq status-color "yellow")
;; 消息: "【watched-layer】颜色从 green 变为 yellow"
(setq status-color "red"))
;; 消息: "【watched-layer】颜色从 yellow 变为 red"
```
`:watch` 的典型用途:
- 记录日志
- 更新外部状态
- 触发通知
- 执行清理操作
## 完整实战示例
### 示例一:动态颜色状态指示器
这个示例展示如何创建一个根据状态自动变色的指示器:
```lisp
(tp-layer-reset)
;; 定义状态颜色变量
(defvar status-color "gray")
(defvar status-text "未开始")
;; 定义状态指示器层
(define-tp status-indicator ()
'(face (:background $status-color) display $status-text))
;; 定义状态更新函数
(defun set-status (status)
"设置状态,自动更新颜色和文本"
(pcase status
('pending (setq status-color "gray" status-text "待处理"))
('running (setq status-color "blue" status-text "运行中"))
('success (setq status-color "green" status-text "成功"))
('warning (setq status-color "orange" status-text "警告"))
('error (setq status-color "red" status-text "错误"))))
;; 测试状态指示器
(tp-pop-to-buffer "*tp-test*"
(insert "状态")
(tp-set 1 (point-max) 'status-indicator)
;; 模拟状态变化
(set-status 'pending)
(message "状态: %s, 颜色: %s" status-text status-color)
;; => "状态: 待处理, 颜色: gray"
(set-status 'running)
(message "状态: %s, 颜色: %s" status-text status-color)
;; => "状态: 运行中, 颜色: blue"
(set-status 'success)
(message "状态: %s, 颜色: %s" status-text status-color))
;; => "状态: 成功, 颜色: green"
```
### 示例二:主题切换系统
这个示例展示如何创建一个可切换的主题系统:
```lisp
(tp-layer-reset)
;; 定义主题颜色变量
(defvar keyword-color nil)
(defvar string-color nil)
;; 定义主题相关的响应式层
(define-tp themed-keyword ()
'(face (:foreground $keyword-color :weight bold)))
(define-tp themed-string ()
'(face (:foreground $string-color)))
;; 定义主题切换函数
(defun switch-to-dark-theme ()
"切换到深色主题"
(interactive)
(setq keyword-color "light blue"
string-color "green")
(message "已切换到深色主题"))
(defun switch-to-light-theme ()
"切换到浅色主题"
(interactive)
(setq keyword-color "blue"
string-color "dark green")
(message "已切换到浅色主题"))
;; 测试主题切换
(tp-pop-to-buffer "*tp-test*"
(insert "(defun hello () \"greeting\")")
;; 应用不同的主题层
(tp-match-set "defun" 'themed-keyword)
(tp-regexp-set "\".+\"" 'themed-string)
(switch-to-dark-theme)
;; 初始是深色主题
(message "关键字颜色: %s" keyword-color)
(message "字符串颜色: %s" string-color)
;; 切换到浅色主题
(switch-to-light-theme)
;; 文本自动更新!
(message "关键字颜色: %s" keyword-color)
(message "字符串颜色: %s" string-color))
```
## 匿名响应式层
除了使用 `define-tp` 定义命名层你还可以直接在属性列表中使用响应式变量。tp.el 会自动为这些匿名层生成唯一的名称:
```lisp
(tp-layer-reset)
(defvar inline-color "purple")
(tp-pop-to-buffer "*tp-test*"
(insert "匿名响应式层示例")
;; 直接使用 $inline-color无需预先定义层
(tp-set 1 (point-max) '(face (:foreground $inline-color)))
;; 文本现在是紫色的
(message "颜色: %s" (plist-get (tp-at 1 'face) :foreground))
;; => "purple"
;; 改变变量
(setq inline-color "orange")
;; 文本自动变成橙色
(message "颜色: %s" (plist-get (tp-at 1 'face) :foreground)))
;; => "orange"
```
匿名响应式层适用于简单的场景,当你不需要在多个地方复用同一个层定义时。
## 响应式文本 (tp-text)
除了响应式文本**属性**tp.el 还支持响应式**文本内容**本身。通过特殊的 `tp-text` 属性,你可以让文本内容也变成响应式的——当绑定的变量改变时,文本内容会自动更新。
### 基本用法
`tp-text` 属性有两种使用方式:
#### 1. 初始化当前文本
`tp-text` 的值为 `nil` 时,它会被自动设置为当前区域的文本内容:
```lisp
(tp-pop-to-buffer "*tp-test*"
(insert "Hello World")
;; tp-text 为 nil 时,自动初始化为当前文本 "Hello"
(tp-set 1 6 '(face bold tp-text nil))
;; 现在 tp-text 的值是 "Hello"
(message "tp-text = %s" (tp-at 1 'tp-text)))
;; => "Hello"
```
#### 2. 替换文本内容
`tp-text` 的值为字符串时,它会替换区域内的文本,同时保留其他文本属性:
```lisp
(tp-pop-to-buffer "*tp-test*"
(insert "Hello World")
;; tp-text 为字符串时,替换文本内容
(tp-set 1 6 '(face bold tp-text "Hi"))
;; 文本变为 "Hi World",且 "Hi" 仍然有 bold 样式
(message "buffer = %s" (buffer-string)))
;; => "Hi World"
```
### 响应式文本层
`tp-text` 的真正威力在于与响应式变量结合使用:
```lisp
;; 定义响应式变量
(defvar my-dynamic-text "Loading...")
;; 定义包含 tp-text 的响应式层
(define-tp dynamic-content ()
:props '(face (:foreground "blue") tp-text $my-dynamic-text))
;; 应用到文本
(tp-pop-to-buffer "*tp-test*"
(insert "placeholder")
(tp-set 1 12 'dynamic-content)
;; 文本现在显示 "Loading..."
(message "初始文本: %s" (buffer-string))
;; => "Loading..."
;; 改变变量
(setq my-dynamic-text "数据加载完成!")
;; 文本自动更新!
(message "更新后: %s" (buffer-string)))
;; => "数据加载完成!"
```
### 使用 :compute 生成动态文本
`tp-text` 可以与 `:compute` 结合,创建由其他变量派生的动态文本:
```lisp
(define-tp greeting-layer ()
:props '(face (:foreground "green") tp-text $full-greeting)
:data '((user-name . "访客")
(greeting-prefix . "欢迎"))
:compute '((full-greeting
(lambda ()
(format "%s, %s!" greeting-prefix user-name)))))
;; 应用到文本
(tp-pop-to-buffer "*tp-test*"
(insert "placeholder")
(tp-set 1 12 'greeting-layer)
;; 显示 "欢迎, 访客!"
(message "初始: %s" (buffer-string))
;; 改变用户名
(setq user-name "张三")
;; 文本自动更新为 "欢迎, 张三!"
(message "更新后: %s" (buffer-string)))
```
### 匿名响应式文本
你也可以直接在属性列表中使用响应式 `tp-text`,无需定义层:
```lisp
(defvar inline-text "原始内容")
(tp-pop-to-buffer "*tp-test*"
(insert "placeholder")
;; 直接使用响应式 tp-text
(tp-set 1 12 '(face bold tp-text $inline-text))
;; 显示 "原始内容"
;; 改变变量
(setq inline-text "新内容")
;; 文本自动更新为 "新内容"
)
```
### 注意事项
1. **tp-text 作用于字符串时返回新字符串**Emacs 字符串长度无法原地改变,因此字符串形式的调用会返回一个新字符串,而不是修改原字符串。子区域的 `tp-text` 只替换该区域并保留字符串的其余部分;整串形式则只返回替换后的文本。
2. **保留现有属性**:使用 `tp-set``tp-add` 设置 `tp-text` 时,现有的文本属性会被保留。
3. **非响应式属性不添加 tp-name**:如果文本属性中没有响应式变量(`$` 前缀),则不会添加 `tp-name` 等响应式专用属性,保持原生文本属性行为。
## 使用 :transform 进行值转换
`:transform` 关键字允许你注册一个转换函数,在 `tp-text` 值显示之前对其进行处理。这对于格式化数字、日期或其他值非常有用:
```lisp
;; 数字格式化
(define-tp price-display ()
:props '(tp-text $price)
:data '((price . "99.9"))
:transform (lambda (text)
(format "$%.2f" (string-to-number text))))
;; 99.9 显示为 $99.90
;; 日期格式化
(define-tp date-display ()
:props '(tp-text $timestamp)
:data '((timestamp . "1703865600"))
:transform (lambda (text)
(format-time-string "%Y-%m-%d"
(seconds-to-time (string-to-number text)))))
;; 大写转换
(define-tp uppercase-text ()
:props '(tp-text $content)
:data '((content . "hello"))
:transform #'upcase)
;; "hello" 显示为 "HELLO"
```
转换函数的特点:
- 接收原始的 `tp-text` 字符串值
- 返回用于显示的转换后字符串
- 在初始显示和响应式更新时都会应用
- 转换函数中的错误会被捕获并记录
> 📖 **更多优化功能如批量更新和调试模式,请参阅 [响应式系统优化文档](reactive-optimization.md)**
## 总结
tp.el 的响应式文本属性功能为 Emacs 开发带来了现代化的响应式编程体验。通过使用 `$` 前缀的响应式变量、`:data` 定义状态、`:compute` 计算派生值、`:watch` 监听变化、`:transform` 格式化值,你可以构建出更加动态、易于维护的文本属性系统。
核心要点:
1. **响应式变量**:使用 `$` 前缀引用变量
2. **:props**:定义包含响应式变量的属性
3. **:data**:定义额外的响应式状态和初始值
4. **:compute**:定义由其他变量派生的计算属性
5. **:watch**:监听变量变化并执行副作用
6. **:transform**:在显示之前转换 tp-text 值
7. **自动更新**:改变变量值,所有相关文本自动更新
8. **响应式文本 (tp-text)**:让文本内容本身也能响应式更新

View File

@ -1,205 +0,0 @@
# TP Retained/Reactive Text Runtime Target Architecture
Chinese version: [TP Retained/Reactive Text Runtime 目标架构](retained-runtime-target-architecture.md).
For the public entry index, see [API-REFERENCE.md](API-REFERENCE.md); for
behavior contracts, see [API-SEMANTICS.md](API-SEMANTICS.md).
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
TP 1.0 is an independently installable, testable, releasable, and usable retained/reactive text runtime for Emacs. It projects declarative properties, reactive data, and stable text objects onto strings and buffers while owning final text-property diff, marker/index state, transactions, and buffer publication.
TP does not depend on Ebox and contains no spatial concepts such as Box, Flex, Grid, padding, layout owners, or Ebox regions. Ebox, ETAF, dashboards, diagnostics, interactive lists, and ordinary buffer annotations can all consume the same public TP APIs.
TP is not a CSS engine either. Complete stylesheets, selectors, specificity, origin/importance, CSS cascade layers, CSS-wide values, and custom properties belong to the independent ECSS package. ECSS may hand final computed declarations to TP for publication, but TP neither requires, detects, nor names ECSS.
The boundary in one sentence is:
> TP owns objects, dependencies, positions, changes, and publication; an upper consumer owns business meaning and the desired display result.
## 2. Design invariants
- TP source, tests, examples, and package metadata neither require, detect, nor name Ebox.
- TP owns no CSS stylesheet, selector matching, specificity, or cascade winner; those capabilities belong to the independent ECSS package.
- One property, binding, surface, mount, diff, and transaction core serves every live use; there is no embedded mode.
- TP is the sole final buffer committer. Producer and consumer prepare phases produce candidate values only.
- One live object has one TP identity. A consumer may store its opaque handle but cannot maintain a parallel identity requiring long-term synchronization.
- Signal updates travel from source to binding and object to marker-backed mount. Normal hot paths never scan `buffer-list` or search text by `tp-name`/`tp-layers`.
- `tp-name`, `tp-layers`, and `tp-meta` are not a live runtime database. Definitions, provenance, identity, dependencies, and mount metadata live in side state.
- Capabilities have exactly two values, `content` and `properties`. They share one compute and commit semantics and differ only in write permission.
- Ordinary function values are literal. Only an explicit `tp-computed` value source executes and records dependencies.
- Signal sources, bindings, plans, marker/index state, and opaque client state use one transaction revision and roll back together.
## 3. Independent data flow
```text
application state / theme / host edit
signals + bindings
│ exact dependency graph
TP prepare context
│ candidate objects/bindings/anchors
ordinary or client producer
│ object → direct property contributions
│ → generic keyed surface plan
reconcile + prepare diff
│ prepared text/property operations
atomic multi-surface publication
strings / Emacs buffers
```
Prepare creates candidate state without publication. A producer returns an ordinary surface plan plus optional opaque client state. TP never interprets client state but promotes it atomically with the plan, dependencies, mounts, and revision.
## 4. Property contributions, composition, and value sources
### 4.1 Property policies and contribution composition
TP maintains generic property policies for the Emacs text properties it ultimately writes: presence, normalization, validation, equality, merge, and projection. A policy answers only how TP contributions compose, whether a value truly changed, and how the result becomes an Emacs property; it defines no selector, stylesheet, or CSS winner.
Every properties mount contributes only the properties it declares. TP composes the host baseline and all TP contributions per property in stable mount/contribution order, strictly distinguishes explicit nil from absence, and retains enough side state to remove one contribution, detect an external conflict, and roll back a transaction. This is text-property ownership and composition, not CSS cascade.
ECSS is an independent pure style-computation package: it consumes property schemas, a subject tree/adapter, and a stylesheet and returns computed declarations plus provenance. It neither mutates buffers nor owns markers and depends on neither TP nor Ebox. Ebox or an ordinary text UI that needs complete CSS runs ECSS first and then hands the final text/property plan to TP; callers that do not need CSS use TP directly.
### 4.2 Literal and computed values
Every ordinary Elisp value is literal, including function objects. TP never invokes a help-echo function, keymap command, or callback implicitly.
A declaration that must be evaluated uses `tp-computed` to wrap a compute function. It executes in the owning object's binding during prepare; `tp-signal-read` and `tp-binding-read` record dependencies automatically. The result then passes through the property policy's normalization and validation and is treated as a literal, with no implicit second invocation. Errors abort the whole candidate transaction, and equal results produce no surface change.
An upper DSL may accept evaluable Elisp, but its constructor/compiler boundary must distinguish quoted lists, literal functions, and computed sources and compile reactive computation to `tp-computed` rather than creating a second watcher.
## 5. Stable objects and prepare contexts
Object identity is valid in one surface and retained by parent identity, sibling key, and opaque kind. Explicit keys are unique under one parent. An unkeyed object may retain identity only by position plus kind. Handles never cross surfaces.
TP creates a short-lived prepare context at the start of mount/update. A producer calls:
```elisp
(tp-object-ensure context parent key kind)
```
A matching live object returns its retained handle. A new object exists only in candidate state. Duplicate keys, stale parents, orphan objects, and cross-surface handles fail during prepare. Candidate identity becomes live only after successful publication; a failed handle is permanently unresolvable.
`tp-surface-materialize-string` gives a producer the same semantics through an ephemeral context. Its objects and bindings exist only for that pure computation, are released after the string returns, and never enter a live registry.
`tp-object-resolve` performs read-only lookup of a live handle by surface and key path for public selection/interaction entry points. It never creates an object.
## 6. Bindings and real reactive dependencies
A definition is a reusable recipe; a binding is a concrete computation installed on one object. `tp-bind` installs idempotently by object handle plus caller-namespaced binding key and stores at least compute, last successful value, dependencies, dirty state, revision, and lifecycle policy.
`tp-binding-read` returns another binding's memoized value while registering a binding-to-binding dependency. Signals, computed properties, measurements, and ordinary derived values can therefore form a real dependency graph rather than scanning a buffer after variables change.
Before recomputation TP removes old dependencies; after success the actual set read this time becomes authoritative, so conditional branches release unused sources. A transaction dirty queue deduplicates invalidations and recomputes one binding at most once per batch. Cycles report the complete path.
Prepare records touched objects and bindings. A logical object with no visible characters must be retained explicitly; one logical object may use prepare-only attachments to own several disjoint plan fragments without putting those attachments in the plan. Removing an object cleans up its bindings, subscriptions, anchors, and mounts in the same publication. A surviving binding omitted from the current declaration is removed by default unless an explicit lifecycle policy retains it. Ordinary bindings may return arbitrary client values; only designated producer bindings return plans or subplans.
## 7. Surface plans
A surface plan is immutable-semantic pure data with these node fields:
| Field | Contract |
| --- | --- |
| `key` | Sibling-local stable key |
| `kind` | Opaque comparable discriminator |
| `text` | Optional plain/propertized string leaf |
| `props` | Final direct Emacs text properties |
| `children` | Ordered child plans |
| `tags` | Opaque side metadata indexed but not interpreted by TP |
| `capability` | `content` or `properties` |
A plan contains no marker, buffer position, patch operation, producer closure, binding closure, or client continuation. Valid keymap/help-echo/callback functions may remain final property values, and reconciliation never invokes them.
Public constructors defensively copy caller-owned plists/strings or otherwise provide immutable semantics. Mutating the original after commit cannot change a published surface.
## 8. Mounts, range anchors, and property ownership
### 8.1 Content capability
A `content` mount owns text and properties in its span. It may insert, delete, move, or replace text and update properties. It serves dashboards, menus, special UI buffers, and advanced renderer output.
### 8.2 Properties capability
A `properties` mount contributes declared properties without changing host text. `tp-range-anchor-create` constructs an opaque marker-backed anchor from buffer, start/end, and marker insertion policy. During prepare the producer calls `tp-object-attach-range` to attach an object to that anchor. The plan itself still contains no position.
For every anchor/property interval, TP side state records the host baseline, every TP contribution, and the last published value. Overlapping contributions from one surface compose per property through its property policy.
If external code changes the same property to a value different from TP's last publication, the next prepare raises `tp-property-conflict` by default. TP neither overwrites the external value nor restores an old snapshot; the caller explicitly invokes `tp-range-rebase` or unmounts. Unmount removes only the TP contribution: it restores the baseline only while the current value still equals TP's last publication, otherwise preserving the external value and recording the conflict.
Live markers follow host text editing. An edit crossing or deleting an anchor boundary follows an explicit shorten/remove/stale policy; TP never scans nearby text to guess a new location.
## 9. Reconciliation and transactions
TP reconciles object identity by parent/key and computes child insert/remove/reorder, text diff, and property-run diff between old and new plans. A normal update resolves one or more ranges directly through the object-to-mount index; public queries expose numeric range/tag snapshots rather than live markers.
A transaction freezes candidate signal writes; creates prepare contexts; prepares every actually affected surface; validates capabilities, conflicts, and lifecycle; creates per-surface operations and inverse journals; publishes in stable surface-id order; then atomically swaps source values, bindings, plans, indexes, client state, and revisions. Observers run only after every surface succeeds.
One global signal may reach several surfaces. TP prepares all before publishing any. If a compute, buffer write, marker/index step, or transaction participant fails, TP rolls back already published surfaces and restores signal values, binding values/dependencies, dirty queues, and revisions. An observer failure occurs after commit and is reported without rollback.
If a buffer is killed during publication, kill-buffer teardown is authoritative and irreversible. TP rolls back other surfaces and source state and never resurrects the killed buffer.
## 10. Public API levels
### 10.1 Simple one-shot properties
```elisp
(tp-propertize string declarations)
(tp-apply buffer start end declarations)
```
Both use the same direct-declaration validation/projection and mutation primitives without identity, bindings, or live mounts. Existing `tp-set`, `tp-reset`, `tp-add`, `tp-remove`, lookup, and search APIs reuse the same lower semantics.
### 10.2 Reactive existing text
```elisp
(tp-watch buffer start end compute)
```
`tp-watch` creates a properties range anchor, surface object, and binding. COMPUTE returns declarations, and the result is an opaque update/unmount handle. Ordinary users do not manually build objects, bindings, or surfaces.
### 10.3 Complete retained UI
```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)
(tp-surface-unmount surface)
```
`tp-surface-update-scoped` is a one-transaction authorization over retained object identity. TP resolves each object through its mount index, supports one object with several disjoint mounts, verifies that the full candidate changes no output outside the authorized ranges, and then publishes text, direct properties, mounts, indexes, client state, and revision in the same rollback boundary. Scope is not stored in text and is not a second reactive runtime. Mismatch signals by default; an explicit option may request a full-root fallback.
The full API also includes `tp-computed`, signals, prepare/object operations, bindings, range anchors, transactions, materialize-string, and at-point/inspect/report diagnostics. TP adds no overlapping `tp-mount`/`tp-update` aliases and exposes no raw marker, patch, change-set, domain dirty kind, or `:impact` API.
## 11. Standalone acceptance scenarios
With no Ebox on `load-path`, TP 1.0 continuously verifies:
1. static string/buffer properties: nested faces, keymaps, help-echo functions, and explicit nil;
2. reactive status: `tp-watch` and a retained content producer, conditional/binding dependencies, and batching;
3. retained dashboard: keyed add/remove/reorder, buttons, signal-driven theme declarations, and rollback;
4. existing-text diagnostics: range anchors, host edits, overlap, external property conflict/rebase/unmount;
5. two-buffer producer: isolated identity/state plus global-signal multi-surface atomicity;
6. performance: sparse updates proportional to the actual dependency closure, zero buffer operations for equal values, and no marker/subscription/weak-reference leaks after unmount.
## 12. Compatibility, versioning, and deletion
TP 1.0 is a major-version transition. Stateless public APIs that map directly to the unified core remain. Managed behavior that requires the inline `tp-layers`/`tp-meta` database or scan renderer is explicitly removed or replaced rather than retained in a hidden compatibility engine.
There is no legacy import API in TP 1.0. Callers must provide a plan or producer explicitly; TP never scans historical propertized text to reconstruct surface identity.
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. Implemented, frozen contracts
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.

View File

@ -1,205 +0,0 @@
# TP Retained/Reactive Text Runtime 目标架构
英文版见 [TP Retained/Reactive Text Runtime Target Architecture](retained-runtime-target-architecture-en.md)。
公共入口索引见 [API-REFERENCE.md](API-REFERENCE.md);语义合同见
[API-SEMANTICS.md](API-SEMANTICS.md)。
状态TP 1.0 已实现的架构合同。本文记录已经落地并由测试保护的目标边界;当前模块和公共行为事实分别以 [ARCHITECTURE.md](ARCHITECTURE.md) 与 [API-SEMANTICS.md](API-SEMANTICS.md) 为准。文件名保留 `target-architecture` 以维持既有链接稳定。
## 1. 产品定位
TP 1.0 是一个可独立安装、测试、发布和使用的 Emacs retained/reactive text runtime它把声明式属性、响应式数据和稳定文本对象投影到 string 与 buffer并拥有最终文本属性 diff、marker/index、事务和 buffer publication。
TP 不依赖 Ebox也不包含 Box、Flex、Grid、padding、layout owner 或 Ebox region 等空间布局概念。Ebox、ETAF、dashboard、diagnostics、交互列表和普通 buffer 标注都可以通过同一 TP public API 使用它。
TP 也不是 CSS 引擎。完整 stylesheet、selector、specificity、origin/importance、CSS cascade layer、CSS-wide value 和 custom property 由独立 ECSS 包负责ECSS 可以把最终 computed declarations 交给 TP 发布,但 TP 不 require、检测或命名 ECSS。
一句话边界是:
> TP 负责对象、依赖、位置、变化和提交;上层 consumer 负责这些对象的业务含义以及期望显示结果。
## 2. 设计不变量
- TP source、tests、examples 和 package metadata 不 require、检测或命名 Ebox。
- TP 不拥有 CSS stylesheet、selector matching、specificity 或 cascade winner这些能力属于独立 ECSS 包。
- live runtime 只有一套 property、binding、surface、mount、diff 和 transaction core不增加 embedded mode。
- TP 是唯一最终 buffer committerproducer 和 consumer 的 prepare 阶段只能产生候选值。
- 一个 live object 只有一个 TP identityconsumer 可以保存 opaque handle但不能建立需要长期同步的平行 identity。
- signal update 从 source 直达 binding再从 object 直达 marker-backed mount正常热路径不扫描 `buffer-list` 或按 `tp-name`/`tp-layers` 搜索文本。
- `tp-name`、`tp-layers`、`tp-meta` 不是 live runtime 数据库definition、provenance、identity、dependencies 和 mount metadata 都在 side state。
- capability 只有 `content``properties` 两种;它们共享同一计算和提交语义,只是写权限不同。
- 普通函数值是 literal只有显式 `tp-computed` value source 会执行并收集依赖。
- signal source、bindings、plans、markers/indexes 和 opaque client state 在 transaction 中使用同一 revision失败时共同回滚。
## 3. 独立数据流
```text
application state / theme / host edit
signals + bindings
│ exact dependency graph
TP prepare context
│ candidate objects/bindings/anchors
ordinary or client producer
│ object → direct property contributions
│ → generic keyed surface plan
reconcile + prepare diff
│ prepared text/property operations
atomic multi-surface publication
strings / Emacs buffers
```
prepare 只产生 candidate state。producer 返回普通 surface plan 和可选 opaque client state。TP 不解释 client state但把它与 plan、dependencies、mounts 和 revision 一起原子晋升。
## 4. 属性 contribution、合成与 value source
### 4.1 Property policy 与 contribution composition
TP 为它最终写入的 Emacs text property 维护通用 property policypresence、normalizer、validator、equality、merge 和 projector。policy 只回答多个 TP contribution 如何合成、值是否真的变化以及怎样形成最终 Emacs property它不定义 selector、stylesheet 或 CSS winner。
每个 properties mount 只贡献它声明的 property。TP 按稳定的 mount/contribution 顺序逐属性合成 host baseline 与所有 TP contribution严格区分显式 nil 和 absent并保存足够的 side state 以便撤销单个 contribution、检测外部冲突和执行事务回滚。这个过程是文本属性 ownership/composition不是 CSS cascade。
ECSS 是独立的纯样式计算包:输入 property schemas、subject tree/adapter 与 stylesheet输出 computed declarations 和 provenance不读写 buffer、不持有 marker也不依赖 TP 或 Ebox。Ebox 或普通文本 UI 若需要完整 CSS 能力,先调用 ECSS再把最终文本/属性计划交给 TP不需要 CSS 的调用者直接使用 TP。
### 4.2 Literal 与 computed
普通 Elisp value 永远是 literal包括 function object。`help-echo` function、keymap command 和 callback 不会被 TP 隐式调用。
需要求值的声明必须使用 `tp-computed` 包装 compute function。compute 在所属 object binding 的 prepare context 中运行;`tp-signal-read` 和 `tp-binding-read` 自动登记依赖。返回值随后按 property policy normalize/validate并按 literal 处理,不隐式调用第二次。错误终止整个 candidate transaction相等结果不产生 surface change。
上层 DSL 可以接受可求值 Elisp但必须在 constructor/compiler 边界明确区分 quoted list、literal function 和 computed source并把响应式计算编译到 `tp-computed`,不能建立第二套 watcher。
## 5. Stable object 与 prepare context
每个 object 的 identity 只在一个 surface 中有效,由 parent identity、sibling key 和 opaque kind 保留。显式 key 在同一 parent 下唯一unkeyed object 只能按 position+kind 保留handle 不能跨 surface 使用。
TP 在 mount/update prepare 开始时创建短生命周期 prepare context。producer 调用:
```elisp
(tp-object-ensure context parent key kind)
```
匹配的 live object 返回原 handle新增 object 只存在于 candidate state。duplicate key、stale parent、orphan object 或 cross-surface handle 在 prepare 中失败。只有成功 publication 才把 candidate identity 变成 live identity失败 handle 必须不可解析。
`tp-surface-materialize-string` 给 producer 提供相同语义的 ephemeral context。object/binding 只在这次纯计算中存在string 返回后全部释放,不进入 live registry。
`tp-object-resolve` 只读地按 surface 与 key path 解析 live handle用于公开选择/交互入口,不创建对象。
## 6. Binding 与真正的响应式依赖
definition 是可复用配方binding 是安装在一个 object 上的具体计算。`tp-bind` 以 object handle 加 caller-namespaced binding key 幂等安装,至少保存 compute、last successful value、dependencies、dirty state、revision 和 lifecycle policy。
`tp-binding-read` 读取另一个 binding 的 memoized value并登记 binding→binding dependency。因此 signal、computed property、measurement 或普通 derived value 可以组成真实依赖图,而不是在变量变化后扫描 buffer。
重新计算前撤销旧依赖成功后以本次实际读取集合替换。conditional branch 因而会自动断开不再使用的 source。transaction dirty queue 去重,同一 binding 每批最多重算一次;循环报告完整路径。
每次 prepare 记录 touched object/binding。没有可见字符但仍属于 candidate 的 logical object 必须显式 retain一个 logical object 可以通过 prepare-only attachment 对应多个不连续 plan fragmentattachment 不进入 plan。删除 object 时同步清理 bindings、subscriptions、anchors 和 mounts仍存在但本次未声明的 binding 默认删除,只有显式 lifecycle policy 才能保留。普通 binding 可返回任意 client value只有 designated producer binding 返回 plan/subplan。
## 7. Surface plan
surface plan 是不可变语义的纯数据,节点字段为:
| Field | Contract |
| --- | --- |
| `key` | sibling-local stable key |
| `kind` | opaque comparable discriminator |
| `text` | optional plain/propertized string leaf |
| `props` | final direct Emacs text properties |
| `children` | ordered child plans |
| `tags` | opaque side metadata indexed but not interpreted by TP |
| `capability` | `content` or `properties` |
plan 不携带 marker、buffer position、patch op、producer closure、binding closure 或 client continuation。合法的 keymap/help-echo/callback function 可以作为最终 property value 保留reconciler 永不调用它们。
public constructor 对 caller-owned plist/string 做 defensive copy 或提供 immutable semanticscommit 后修改原值不能改变已发布 surface。
## 8. Mount、range anchor 与属性所有权
### 8.1 Content capability
`content` mount 拥有其 span 的文本和属性,可以插入、删除、移动、替换文字以及修改属性。它适合 dashboard、menu、special UI buffer 和高级 renderer output。
### 8.2 Properties capability
`properties` mount 只能贡献声明的属性,不能修改 host text。`tp-range-anchor-create` 从 buffer、start/end 和 marker insertion policy 创建 opaque marker-backed anchorproducer 在 prepare 中调用 `tp-object-attach-range` 把 object 绑定到 anchor。plan 本身仍没有位置。
TP side state 为每个 anchor/property interval 保存 host baseline、各 TP contribution 和最后一次 published value。同一 surface 的重叠 contribution 通过 property policy 逐属性合成。
外部代码把同一 property 改成不同于 TP 最后发布值时,下一次 prepare 默认报 `tp-property-conflict`。TP 不覆盖外部值,也不恢复旧 snapshot调用者显式 `tp-range-rebase` 或 unmount。unmount 只撤销 TP contribution当前值仍等于 TP 最后发布值时恢复 baseline否则保留外部值并在 report 中记录 conflict。
host text 编辑由 live markers 跟随。跨越或删除 anchor 边界时按显式 shorten/remove/stale policy 处理TP 不扫描附近文本猜测新位置。
## 9. Reconcile 与 transaction
TP 按 parent/key reconcile object identity并对 old/new plan 计算 child insert/remove/reorder、text diff 和 property-run diff。normal update 从 object→mount index 直接取得一个或多个范围;公开查询只返回数值 range/tag snapshot不暴露 live marker。
transaction 顺序是:冻结 candidate signal writes建立 prepare contexts准备所有实际受影响 surfaces验证 capability/conflict/lifecycle生成 per-surface operations 与 inverse journals按稳定 surface id publish最后原子切换 source values、bindings、plans、indexes、client state 和 revisions全部成功后才运行 observers。
一个 global signal 可以触达多个 surfaces。TP 必须先全部 prepare再逐 surface publish任一 compute、buffer write、marker/index step 或 transaction participant 失败时,回滚已经发布的 surfaces并恢复 signal values、binding values/dependencies、dirty queues 和 revisions。observer failure 发生在成功 commit 后,只记录而不回滚。
若 publish 中 buffer 被 killkill-buffer teardown 是不可逆权威结果;其他 surface 与 source state 回滚TP 不复活 killed buffer。
## 10. Public API 层级
### 10.1 简单的一次性属性
```elisp
(tp-propertize string declarations)
(tp-apply buffer start end declarations)
```
二者使用相同的 direct-declaration validation/projection 和 mutation primitives不建立 identity、binding 或 live mount。现有 `tp-set`、`tp-reset`、`tp-add`、`tp-remove`、lookup/search APIs 继续复用这些底层语义。
### 10.2 响应式已有文本
```elisp
(tp-watch buffer start end compute)
```
`tp-watch` 创建 properties range anchor、surface object 和 bindingCOMPUTE 返回 declarations结果是可 update/unmount 的 opaque handle。普通用户不需要手工创建 object、binding 或 surface。
### 10.3 完整 retained UI
```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)
(tp-surface-unmount surface)
```
`tp-surface-update-scoped` 是一次事务内基于 retained object identity 的授权。TP 通过 mount index 解析对象,支持一个对象拥有多个离散 mount验证完整 candidate 不会修改授权范围之外的输出,然后在同一回滚边界内发布 text、direct properties、mount、index、client state 和 revision。scope 不写入文本,也不会形成第二套响应式 runtime。默认 mismatch 直接报错;调用者可显式选择 full-root fallback。
完整 API 还包括 `tp-computed`、signals、prepare/object、bindings、range anchors、transactions、materialize-string、at-point/inspect/report。TP 不增加含义重叠的 `tp-mount`/`tp-update` aliases也不公开 raw marker/patch/change-set、domain dirty kind 或 `:impact` APIs。
## 11. 独立验收场景
TP 1.0 在没有 Ebox load-path 时必须长期通过:
1. static string/buffer propertiesnested face、keymap、help-echo function、explicit nil
2. reactive status`tp-watch` 与 retained content producer、conditional/binding dependency、batch
3. retained dashboardkeyed add/remove/reorder、button、signal-driven theme declarations、rollback
4. existing-text diagnosticsrange anchor、host edit、overlap、external property conflict/rebase/unmount
5. two-buffer produceridentity/state 隔离与 global-signal multi-surface atomicity
6. performancesparse update 与实际 dependency closure 成正比equal value 零 buffer opunmount 后无 marker/subscription/weak-reference 泄漏。
## 12. 兼容、版本与删除
TP 1.0 是主版本切换。能直接映射到统一 core 的静态 public API 保留;依赖 inline `tp-layers`/`tp-meta` database 和扫描式 renderer 才能工作的 managed behavior 必须明确删除或替换,不保留 hidden compatibility engine。
当前没有 legacy import API调用者必须显式提供 plan 或 producer。TP 不会扫描历史 propertized text 来重建 surface identity。
当前实现已经删除 layer→buffer registry、scan-driven refresh hooks、旧 inline managed codec、重复 transaction 和旧 batch renderer。TP 1.0 package、tests、examples 和本文档均可在没有 Ebox repository 的环境中独立工作。
## 13. 已冻结并实现的合同
TP 1.0 的 executable contract tests 已确定并持续保护prepare-context/object 时序binding identity/lifecycleliteral/computed valuerange anchor 和 property conflictsingle/multi-surface rollback三层便利 APIerror taxonomyreport shapeexplicit nil/absenceread-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。

View File

@ -1,117 +0,0 @@
;;; 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

View File

@ -1,178 +0,0 @@
;;; 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

View File

@ -1,160 +0,0 @@
;;; 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

View File

@ -1,56 +0,0 @@
;;; 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

View File

@ -1,66 +0,0 @@
# API 语义收敛阶段 1属性所有权必须先于便利重载
## 背景
仓库审计发现的错误并非彼此独立的条件遗漏。`tp-text` 属性扩散、层重定义残留、显式 nil 丢失、搜索 nil 分裂、隐藏层覆盖外部编辑,都来自同一个更深的问题:
> 调用者、内嵌字符串、普通 Emacs 属性、层定义和 managed stack 对同一属性键的所有权没有统一表达。
继续为每个入口增加特殊分支会扩大语义分裂,因此本阶段先冻结 `docs/API-SEMANTICS.md`,再在拥有状态的层修复。
## 决策
### 1. presence 是数据,不是真值
属性缺失与 present-nil 必须使用 `plist-member` 一类 presence-aware 判断区分。搜索中 VALUE 省略不能再借用 nil 表达,因而增加唯一哨兵 `tp-any-value`。选择唯一对象而不是某个普通符号,是为了避免与合法属性值冲突。
### 2. `tp-text` 的属性所有者是 interval
内嵌字符串的位置 0 不能代表整串。初次应用与响应式更新都按每个真实 property interval 计算,外部 props 在每段上覆盖内嵌 props显式 nil 也参与覆盖。
逐段算出待写属性后仍必须执行调用者选择的操作语义:`tp-set` 覆盖指定键,`tp-reset` 替换完整属性集合,`tp-add` 合并 face-family 和嵌套 plist。实现中一度让“属性已逐段应用”的返回标志绕过了这一步导致文本内容相同时 reset 留下旧键、add 覆盖而不合并。最终把 operation 传到唯一的逐段写入点,并为字符串/缓冲区和 `tp-text nil` 初始化路径加入回归断言。
### 3. 层重定义必须拿到 old 与 new
只传 layer name 会让渲染器无法判断哪些键应删除。定义入口在替换注册表前保存 old props渲染器随后执行
1. 仅删除仍等于旧值的旧层键;
2. 保留无关键和已经被外部改写的值;
3. 写入新定义;
4. 同步 direct render 与 buried/hidden stack entry。
这比完整 `set-text-properties` 更安全,因为后者会错误取得整个区间的所有权。
### 4. 隐藏层冲突默认失败
隐藏层存在时,直接属性只是 managed stack 的渲染缓存。外部直接写入无法可靠归属到某一层。三个候选方案中:
- 静默覆盖会丢用户数据;
- 自动收编为匿名层会凭空改变 stack 结构;
- 明确失败能保留双方状态并暴露所有权冲突。
因此选择 `tp-layer-conflict`,并保证在 managed write 前检查。
### 5. NOERROR 只处理可预期的解析失败
增加 `tp-unresolved-layer`NOERROR 仅捕获这一类型。层 body、compute、transform 和内部不变量错误不属于“未找到”,必须传播。
### 6. 业务计算与 observer 分开
transform/compute 决定渲染结果失败后继续会产生貌似有效的陈旧输出因此错误传播。watcher 是副作用观察者,单个失败不应阻断 managed update错误以结构化 plist 记录在 `tp-reactive-observer-errors`,同时保留用户可见消息。
## 有意延期
参数化 mounted layer entry 没有保存调用实参,重定义时无法重新求值。为避免猜测参数或引入兼容包装,本阶段明确不自动刷新参数化实例。后续应让 managed entry 保存参数和定义版本,再设计迁移。
字符串/缓冲区搜索返回结构、复制/原地修改策略和 stack mutator 的 run-count 返回值也仍有历史差异;它们属于 canonical façade 阶段,不能混入正确性补丁。
## 验证标准
本阶段以以下证据作为停止条件:
- 每个确认问题先有失败回归测试;
- 聚焦测试覆盖字符串/缓冲区、present-nil、静态/响应式重定义和 hidden conflict
- warning-as-error 字节编译通过;
- 全量 ERT、固定种子乱序 ERT 与 README doctest 通过;
- 中英文 README、docstring、架构文档和 changelog 与规范同步。

View File

@ -1,69 +0,0 @@
# 完整文本属性 facade把“替代”定义为语义覆盖而不是重写 Emacs
## 背景
仓库最初能够便捷地写入、搜索和组合文本属性,但“可以替代所有文本属性操作”仍缺少可验证边界:直接值与有效值混在一起,显式 nil 难以观察,参数化 managed layer 丢失实参overlay-aware 字符属性没有统一入口,主题变化和多步写入也没有生命周期证据。
本轮没有复制 Emacs 的 interval、overlay、undo、yank 或 stickiness 引擎。目标改为更严格也更可维护的定义:
> `tp` 为高频文本属性工作流提供统一 facade原生语义由 GNU Emacs 执行并以等价测试锁定overlay 生命周期等不应被包装的能力明确委托。
## 决策
### 1. 一个 lookup record五种明确模式
新增 `tp-lookup-result``tp-lookup`,而没有继续增加 `tp-direct-at`、`tp-char-at` 等平行入口。模式区分:
- `:text-direct`:只看直接 text plist
- `:text-effective`:等价于 `get-text-property`
- `:text-source`:报告 direct/category/alias/default/absent
- `:char`:等价于 overlay-aware `get-char-property`
- `:char-source`:同时报告来源和获胜 overlay。
record 的 `present-p` 是必要字段,因为 nil 既可能是合法直接值,也可能表示缺失。`overlay` 只在 overlay 真正提供获胜值时设置。
### 2. 原生编辑语义优先委托
property change、any/not-all 只做签名统一,直接调用对应 Emacs primitive。copy、substring、insert、insert-and-inherit、kill/yank、stickiness、narrowing 和 indirect buffer 不增加包装层;测试证明 facade 不会破坏这些行为,文档给出委托边界。
`with-silent-modifications` 原生会绑定 `inhibit-read-only`。因此 `:silent + :respect` 无法诚实实现:伪装支持会让策略名与实际行为冲突。本轮只支持 ordinary/respect、ordinary/inhibit、silent/inhibit并对矛盾组合立即报错。
### 3. managed metadata 属于存储,不属于渲染属性
managed entry 使用单一保留键 `tp-meta` 保存 schema、entry id、原始 spec、实参、arglist、定义版本和 entry 版本。没有把这些字段拆成大量普通 text-property key避免污染用户属性命名空间。
`tp-meta` 必须保留在 authoritative stack storage 中,但必须从直接渲染属性和公开 stack query 中剥离。冲突比较也只比较渲染投影,否则 metadata 自身会制造假冲突。
参数化 layer 重定义现在可用保存的 args 重新求值。旧 entry 若没有 args不猜测、不静默套用错误参数诊断将其标为 legacy limitation。
完整存储模式下的直接属性明确对应第一个可见 entry。definition/reactive refresh 具备 old/new 所有权上下文,因此会先把原生直接编辑协调进该 entry再刷新定义以保留外部值普通 stack decode 没有这层上下文,仍对缓存不一致发出 `tp-layer-conflict`。所有层都隐藏时出现直接属性同样属于冲突。
### 4. attach、diagnostics、transaction 是显式生命周期
插入已经带属性的字符串不会经过普通 buffer 写入注册路径,因此提供显式 attach 扫描。detach 可以移除 managed identity/storage并由调用者选择是否保留当前渲染结果。
诊断 API 必须是只读的:不能移动 point、修改 modified state、undo、文本属性或 registry清除已死亡 buffer 除外)。
多步 managed 写入通过 opt-in transaction 包装。事务保存受影响范围的精确文本与属性状态buffer 事务使用 live markers 跟踪范围内的插入和删除,任一步失败都恢复快照。默认重新抛出结构化 `tp-layer-transaction-error`,只有显式 NOERROR 才把失败转换为结构化返回值。
### 5. 主题检测与刷新分层
palette 模块只负责检测 `enable-theme` / `disable-theme`、递增 generation 并发出 hookmanaged renderer 负责刷新。v1 允许保守扫描全部 managed ranges因为错误地漏刷比多刷一次更危险。诊断记录 hook 来源、generation、刷新模式、范围和错误为后续 dependency-targeted 优化保留证据。
## 有意排除
- 不提供 overlay 创建、移动、删除、evaporation 或 priority mutation API
- 不重写 category、alias、default、undo、yank 或 stickiness 引擎;
- 不引入 compositional layer 语义;
- 不改变现有公共 mutator 的历史返回值;
- 不提高 Emacs 28.1 或 Dash 2.19.1 baseline。
## 验证标准
完成声明必须同时具备:
- direct/effective/source/char lookup 的原生等价测试;
- managed metadata、参数化刷新、attach/detach、只读诊断、事务回滚和主题 lifecycle 测试;
- 全量 ERT、固定 seed 乱序 ERT、doctest 和 warning-as-error 编译;
- 大文本、碎片 interval、深 stack、reactive fan-out 与主题刷新的可复现实测;
- 中英文 README、API semantics、architecture、audit checklist 和 changelog 同步。

View File

@ -1,28 +0,0 @@
# 独立测试目录与许可证边界
## 决策
所有 ERT 套件、README doctest 与乱序测试运行器统一放在 `tests/`。基准脚本仍在
仓库根目录因为它是独立的性能工具不属于测试入口。Makefile 同时把源码根目录
`tests/` 加入加载路径,继续提供原有的 `test`、`test-shuffled`、`doctest` 与
`compile-all` 命令。
项目继续采用 `GPL-3.0-or-later`。仓库根目录保留完整、未经修改的 GPLv3 正文,
README 明确标注 SPDX 许可证表达式并链接到该正文。
## 原因
测试文件与可发布模块混放会模糊安装边界,也让根目录的模块清单难以快速阅读。
按职责集中测试后,发布源码、测试支持代码和性能工具各有明确位置,同时无需新增
测试框架或包装脚本。
许可证不能只依赖源码头部的简写声明;分发仓库需要同时提供完整条款。保留标准
GPLv3 正文并在用户文档中明确 `GPL-3.0-or-later`,可以让机器识别信息与法律文本
保持一致。
## 被放弃的方案
- 只移动 `*-tests.el`、把 doctest 和乱序运行器留在根目录:测试边界仍然分散。
- 把基准脚本也移入 `tests/`:会把性能测量与正确性测试混为一谈。
- 为新目录增加额外 Elisp 加载器Makefile 已经能直接枚举并加载测试文件,新增
包装层没有净收益。

View File

@ -1,93 +0,0 @@
;;; 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

View File

@ -1,809 +0,0 @@
;;; tp-binding-tests.el --- Tests for TP binding graph -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;;; Commentary:
;; Contract tests for TP 1.0 signals, bindings, and transactions.
;;; Code:
(require 'ert)
(require 'tp-reactive)
(defvar tp-binding-test-variable nil
"Variable used by scoped signal adapter tests.")
(define-error 'tp-binding-test-primary "TP binding test primary failure")
(defvar tp-binding-test-transaction-trace nil
"Dynamic transaction phase trace used by rollback tests.")
(defvar tp-binding-test-precommit-condition nil
"Condition signaled by the test precommit hook, or nil.")
(defvar tp-binding-test-final-accept-function nil
"Test final-accept function installed by the test precommit hook.")
(defun tp--binding-test-precommit-inject ()
"Record precommit and signal `tp-binding-test-precommit-condition'."
(push 'precommit tp-binding-test-transaction-trace)
(when tp-binding-test-final-accept-function
(tp--transaction-install-final-accept
tp-binding-test-final-accept-function))
(when tp-binding-test-precommit-condition
(signal (car tp-binding-test-precommit-condition)
(cdr tp-binding-test-precommit-condition))))
(defun tp--binding-test-foreign-precommit ()
"Represent an undeclared private-looking foreign precommit function."
nil)
(defun tp-binding-test--rollback-hook-fail ()
"Record rollback hook failure and signal it."
(push 'rollback-hook-fail tp-binding-test-transaction-trace)
(error "Rollback hook failure"))
(defun tp-binding-test--rollback-hook-after ()
"Record the rollback hook following a failed hook."
(push 'rollback-hook-after tp-binding-test-transaction-trace))
(defun tp-binding-test--rollback-final-fail ()
"Record rollback-final failure and signal it."
(push 'rollback-final-fail tp-binding-test-transaction-trace)
(error "Rollback final failure"))
(defun tp-binding-test--rollback-final-after ()
"Record the rollback-final hook following a failed hook."
(push 'rollback-final-after tp-binding-test-transaction-trace))
(defun tp-binding-test--capture-condition (function)
"Call FUNCTION and return its signaled error or quit condition."
(condition-case condition
(progn (funcall function) nil)
(error condition)
(quit condition)))
(defmacro tp-binding-test--isolated (&rest body)
"Run BODY with an isolated reactive runtime."
(declare (indent 0) (debug t))
`(progn
(tp-reactive-reset)
(unwind-protect (progn ,@body)
(tp-reactive-reset))))
(ert-deftest tp-binding-test-signal-invalidates-only-direct-subscribers ()
"A sparse signal write never visits unrelated bindings."
(tp-binding-test--isolated
(let ((target (tp-signal-create 0))
(unrelated (tp-signal-create 0))
(target-calls 0)
(unrelated-calls 0))
(tp-with-transaction
(tp-bind 'target-owner '(test . value)
(lambda ()
(cl-incf target-calls)
(tp-signal-read target)))
(dotimes (index 9999)
(tp-bind (list 'unrelated-owner index) '(test . value)
(lambda ()
(cl-incf unrelated-calls)
(tp-signal-read unrelated)))))
(should (= target-calls 1))
(should (= unrelated-calls 9999))
(tp-reactive-reset-counters)
(cl-letf (((symbol-function 'buffer-list)
(lambda (&rest _) (error "Legacy scan")))
((symbol-function 'text-property-search-forward)
(lambda (&rest _) (error "Legacy scan")))
((symbol-function 'tp-reactive--buffer-layer-names)
(lambda (&rest _) (error "Legacy scan")))
((symbol-function 'tp-reactive-layer-buffers)
(lambda (&rest _) (error "Legacy scan"))))
(tp-signal-set target 1))
(should (= target-calls 2))
(should (= unrelated-calls 9999))
(should (equal (tp-reactive-counters)
'(:invalidated 1 :recomputed 1 :skipped 0
:subscription-added 0 :subscription-removed 0))))))
(ert-deftest tp-binding-test-conditional-dependencies-rewire ()
"A binding unsubscribes from the branch it no longer reads."
(tp-binding-test--isolated
(let ((enabled (tp-signal-create t))
(active (tp-signal-create 'active))
(disabled (tp-signal-create 'disabled))
(calls 0))
(tp-bind 'owner '(test . branch)
(lambda ()
(cl-incf calls)
(if (tp-signal-read enabled)
(tp-signal-read active)
(tp-signal-read disabled))))
(tp-signal-set enabled nil)
(should (= calls 2))
(tp-signal-set active 'ignored)
(should (= calls 2))
(tp-signal-set disabled 'changed)
(should (= calls 3)))))
(ert-deftest tp-binding-test-equal-signal-write-is-noop ()
"Setting an equal signal value does not dirty its binding."
(tp-binding-test--isolated
(let ((source (tp-signal-create '(1 2) :equality #'equal))
(calls 0))
(tp-bind 'owner '(test . value)
(lambda ()
(cl-incf calls)
(tp-signal-read source)))
(tp-reactive-reset-counters)
(tp-signal-set source (list 1 2))
(should (= calls 1))
(should (equal (tp-reactive-counters)
'(:invalidated 0 :recomputed 0 :skipped 0
:subscription-added 0 :subscription-removed 0))))))
(ert-deftest tp-binding-test-transaction-deduplicates-writes ()
"Repeated writes in one transaction recompute each binding once."
(tp-binding-test--isolated
(let ((source (tp-signal-create 0))
(calls 0))
(tp-bind 'owner '(test . value)
(lambda ()
(cl-incf calls)
(tp-signal-read source)))
(tp-reactive-reset-counters)
(tp-with-transaction
(dotimes (value 100)
(tp-signal-set source (1+ value))))
(should (= (tp-signal-peek source) 100))
(should (= calls 2))
(should (= (plist-get (tp-reactive-counters) :recomputed) 1)))))
(ert-deftest tp-binding-test-public-transaction-state-follows-dynamic-extent ()
"The public transaction predicate is true only inside joined transactions."
(should-not (tp-transaction-active-p))
(tp-with-transaction
(should (tp-transaction-active-p))
(tp-with-transaction
(should (tp-transaction-active-p))))
(should-not (tp-transaction-active-p)))
(ert-deftest tp-binding-test-transaction-commits-signals-in-first-touch-order ()
"Touched signals commit once in first-touch order, including net reverts."
(tp-binding-test--isolated
(let* ((first (tp-signal-create 0))
(second (tp-signal-create 0))
(third (tp-signal-create 0))
(original (symbol-function 'tp--commit-signal-entry))
commit-order final-accept-order (final-accept-count 0))
(cl-letf (((symbol-function 'tp--commit-signal-entry)
(lambda (entry)
(push (tp-signal-id
(tp--signal-commit-entry-signal entry))
commit-order)
(funcall original entry)))
((symbol-function 'tp--transaction-noop-final-accept)
(lambda ()
(cl-incf final-accept-count)
(setq final-accept-order
(mapcar
(lambda (entry)
(tp-signal-id
(tp--signal-commit-entry-signal entry)))
tp--transaction-signal-commit-journal)))))
(tp-with-transaction
(tp-signal-set second 1)
(tp-with-transaction
(tp-signal-set first 1)
(tp-signal-set second 0))
(tp-signal-set third 3)))
(setq commit-order (nreverse commit-order))
(should (equal commit-order
(mapcar #'tp-signal-id (list second first third))))
(should (equal final-accept-order commit-order))
(should (= final-accept-count 1))
(should (= (tp-signal-peek first) 1))
(should (= (tp-signal-peek second) 0))
(should (= (tp-signal-peek third) 3))
(dolist (signal (list first second third))
(should (= (tp-signal-revision signal) 1))))))
(ert-deftest tp-binding-test-signal-commit-journal-rolls-back-every-write ()
"Every signal-write injection restores values, revisions, and bindings."
(tp-binding-test--isolated
(dolist (fail-after '(0 1 2 3))
(let* ((first (tp-signal-create 1))
(second (tp-signal-create 2))
(third (tp-signal-create 3))
(binding
(tp-bind (list 'owner fail-after) '(test . sum)
(lambda ()
(+ (tp-signal-read first)
(tp-signal-read second)
(tp-signal-read third)))))
(binding-revision (tp-binding-revision binding))
(original (symbol-function 'tp--commit-signal-entry))
(writes 0))
(cl-letf (((symbol-function 'tp--commit-signal-entry)
(lambda (entry)
(when (and (zerop fail-after) (zerop writes))
(error "Before first signal write"))
(funcall original entry)
(cl-incf writes)
(when (= writes fail-after)
(error "After signal write %d" writes)))))
(should-error
(tp-with-transaction
(tp-signal-set first 10)
(tp-signal-set second 20)
(tp-signal-set third 30))))
(should (equal (mapcar #'tp-signal-peek (list first second third))
'(1 2 3)))
(should (equal (mapcar #'tp-signal-revision
(list first second third))
'(0 0 0)))
(should (= (tp-binding-read binding) 6))
(should (= (tp-binding-revision binding) binding-revision))
(should (= (tp-binding-dependency-count binding) 3))
(dolist (signal (list first second third))
(should (= (tp-signal-subscriber-count signal) 1)))
(tp-with-transaction
(tp-signal-set first 10)
(tp-signal-set second 20)
(tp-signal-set third 30))
(should (equal (mapcar #'tp-signal-peek (list first second third))
'(10 20 30)))
(should (equal (mapcar #'tp-signal-revision
(list first second third))
'(1 1 1)))
(should (= (tp-binding-read binding) 60))))))
(ert-deftest tp-binding-test-precommit-and-final-accept-failures-roll-back ()
"Precommit and final-accept error or quit restores pure reactive state."
(tp-binding-test--isolated
(dolist (phase '(precommit final-accept))
(dolist (condition '((error "Injected error") (quit)))
(let* ((signal (tp-signal-create 1))
observed-final
(tp--transaction-precommit-functions
'(tp--binding-test-precommit-inject))
(tp--transaction-precommit-allowed-functions
'(tp--binding-test-precommit-inject))
(tp-binding-test-precommit-condition
(and (eq phase 'precommit) condition))
(tp-binding-test-final-accept-function
(and (eq phase 'final-accept)
(lambda ()
(setq observed-final
(list (tp-signal-committed-value signal)
(tp-signal-revision signal)))
(signal (car condition) (cdr condition))))))
(let ((failure
(tp-binding-test--capture-condition
(lambda ()
(tp-with-transaction (tp-signal-set signal 2))))))
(should (eq (car failure) (car condition))))
(when (eq phase 'final-accept)
(should (equal observed-final '(2 1))))
(should (= (tp-signal-peek signal) 1))
(should (= (tp-signal-revision signal) 0))
(setq tp--transaction-precommit-functions nil
tp-binding-test-precommit-condition nil
tp-binding-test-final-accept-function nil)
(tp-signal-set signal 2)
(should (= (tp-signal-peek signal) 2))
(should (= (tp-signal-revision signal) 1)))))))
(ert-deftest tp-binding-test-final-accept-pending-quit-is-contained ()
"Clear final-accept pending quit before committed and after-commit actions."
(tp-binding-test--isolated
(let ((signal (tp-signal-create 1)) after-ran
(tp--transaction-precommit-functions
'(tp--binding-test-precommit-inject))
(tp--transaction-precommit-allowed-functions
'(tp--binding-test-precommit-inject))
(tp-binding-test-final-accept-function
(lambda () (setq quit-flag t))))
(tp-with-transaction
(tp-signal-set signal 2)
(tp--enqueue-after-commit (lambda () (setq after-ran t))))
(should (= 2 (tp-signal-peek signal)))
(should after-ran)
(should (eq 'final-accept
(caar tp--last-transaction-diagnostics))))))
(ert-deftest tp-binding-test-precommit-registry-rejects-foreign-functions ()
"Only declared TP-internal symbols may enter the precommit registry."
(tp-binding-test--isolated
(let ((tp--transaction-precommit-functions nil)
(tp--transaction-precommit-allowed-functions
'(tp--binding-test-precommit-inject)))
(tp--transaction-register-precommit-function
'tp--binding-test-precommit-inject)
(should (equal tp--transaction-precommit-functions
'(tp--binding-test-precommit-inject)))
(should-error
(tp--transaction-register-precommit-function
'tp--binding-test-foreign-precommit)
:type 'tp-reactive-error)
(dolist (foreign
(list 'ignore 'tp--binding-test-foreign-precommit
(lambda () nil)))
(let ((signal (tp-signal-create 1))
(tp--transaction-precommit-functions (list foreign)))
(should-error
(tp-with-transaction (tp-signal-set signal 2))
:type 'tp-reactive-error)
(should (= (tp-signal-peek signal) 1))
(should (= (tp-signal-revision signal) 0)))))))
(ert-deftest tp-binding-test-production-precommit-registry-is-exact ()
"The package exposes exactly its one statically declared precommit owner."
(should (equal tp--transaction-precommit-allowed-functions
'(tp--surface-precommit-transaction)))
(should (equal tp--transaction-precommit-functions
'(tp--surface-precommit-transaction))))
(ert-deftest tp-binding-test-condition-trailer-cannot-collide-with-primary-data ()
"User condition data ending like rollback metadata is not a TP trailer."
(let ((condition '(error "Primary" :rollback-failures user-value)))
(should-not
(tp--transaction-condition-trailer condition :rollback-failures))))
(ert-deftest tp-binding-test-rollback-preserves-primary-and-runs-all-phases ()
"Rollback failures attach in order without replacing the primary condition."
(tp-binding-test--isolated
(let* ((signal (tp-signal-create 1))
(binding (tp-bind 'owner '(test . rollback)
(lambda () (tp-signal-read signal))))
(tp-binding-test-transaction-trace nil)
(tp-binding-test-precommit-condition nil)
(tp--transaction-precommit-functions
'(tp--binding-test-precommit-inject))
(tp--transaction-precommit-allowed-functions
'(tp--binding-test-precommit-inject))
(tp-binding-test-final-accept-function
(lambda ()
(signal 'tp-binding-test-primary
'(:payload 7 :rollback-failures user-value))))
(tp--transaction-rollback-functions
'(tp-binding-test--rollback-hook-fail
tp-binding-test--rollback-hook-after))
(tp--transaction-rollback-final-functions
'(tp-binding-test--rollback-final-fail
tp-binding-test--rollback-final-after))
(restore-signal (symbol-function 'tp--restore-signal-entry))
(rollback-bindings (symbol-function 'tp--rollback-bindings))
(restore-counters
(symbol-function 'tp--restore-transaction-counters))
signal-restore-failed
failure)
(cl-letf (((symbol-function 'tp--restore-signal-entry)
(lambda (entry)
(funcall restore-signal entry)
(push 'signal-restored tp-binding-test-transaction-trace)
(unless signal-restore-failed
(setq signal-restore-failed t)
(error "Signal restore failure"))))
((symbol-function 'tp--rollback-bindings)
(lambda ()
(funcall rollback-bindings)
(push 'bindings-restored
tp-binding-test-transaction-trace)))
((symbol-function 'tp--restore-transaction-counters)
(lambda (snapshot)
(funcall restore-counters snapshot)
(push 'counters-restored
tp-binding-test-transaction-trace))))
(setq failure
(condition-case condition
(tp-with-transaction
(tp-transaction-participate-v2
:key 'first
:stage (lambda ()
(push 'publish-first
tp-binding-test-transaction-trace))
:rollback (lambda ()
(push 'rollback-first
tp-binding-test-transaction-trace)))
(tp-transaction-participate-v2
:key 'second
:stage (lambda ()
(push 'publish-second
tp-binding-test-transaction-trace))
:rollback (lambda ()
(push 'rollback-second
tp-binding-test-transaction-trace)))
(tp-signal-set signal 2))
(tp-binding-test-primary condition))))
(should (eq (car failure) 'tp-binding-test-primary))
(should (= (plist-get (cdr failure) :payload) 7))
(should (equal (butlast failure 2)
'(tp-binding-test-primary
:payload 7 :rollback-failures user-value)))
(let ((rollback-failures
(tp--transaction-condition-trailer
failure :rollback-failures)))
(should (equal (mapcar #'car rollback-failures)
'(rollback-hooks signal-journal rollback-final))))
(should
(equal (nreverse tp-binding-test-transaction-trace)
'(publish-first publish-second precommit
rollback-second rollback-first
rollback-hook-fail rollback-hook-after
signal-restored bindings-restored counters-restored
rollback-final-fail rollback-final-after)))
(should (= (tp-signal-peek signal) 1))
(should (= (tp-signal-revision signal) 0))
(should (= (tp-binding-read binding) 1)))))
(ert-deftest tp-binding-test-rollback-preserves-quit-primary ()
"A quit remains primary when rollback hooks fail and later hooks still run."
(tp-binding-test--isolated
(let* ((signal (tp-signal-create 1))
(tp-binding-test-transaction-trace nil)
(tp--transaction-precommit-functions
'(tp--binding-test-precommit-inject))
(tp--transaction-precommit-allowed-functions
'(tp--binding-test-precommit-inject))
(tp-binding-test-final-accept-function
(lambda () (signal 'quit '(:payload 9))))
(tp--transaction-rollback-functions
'(tp-binding-test--rollback-hook-fail
tp-binding-test--rollback-hook-after))
(failure
(tp-binding-test--capture-condition
(lambda ()
(tp-with-transaction (tp-signal-set signal 2))))))
(should (eq (car failure) 'quit))
(should (= (plist-get (cdr failure) :payload) 9))
(should
(equal (mapcar #'car
(tp--transaction-condition-trailer
failure :rollback-failures))
'(rollback-hooks)))
(should (equal (nreverse tp-binding-test-transaction-trace)
'(precommit rollback-hook-fail rollback-hook-after)))
(should (= (tp-signal-peek signal) 1))
(should (= (tp-signal-revision signal) 0)))))
(ert-deftest tp-binding-test-final-accept-throw-rolls-back-nonlocally ()
"A final-accept throw preserves its tag/value after complete rollback."
(tp-binding-test--isolated
(let* ((signal (tp-signal-create 1))
(binding (tp-bind 'owner '(test . throw)
(lambda () (tp-signal-read signal))))
(binding-revision (tp-binding-revision binding))
(tp-binding-test-transaction-trace nil)
(tp--transaction-precommit-functions
'(tp--binding-test-precommit-inject))
(tp--transaction-precommit-allowed-functions
'(tp--binding-test-precommit-inject))
(tp-binding-test-final-accept-function
(lambda () (throw 'tp-binding-test-tag 'thrown-value)))
(tp--transaction-rollback-functions
'(tp-binding-test--rollback-hook-fail
tp-binding-test--rollback-hook-after))
(result
(catch 'tp-binding-test-tag
(tp-with-transaction (tp-signal-set signal 2))
'not-thrown)))
(should (eq result 'thrown-value))
(should (equal (nreverse tp-binding-test-transaction-trace)
'(precommit rollback-hook-fail rollback-hook-after)))
(should (= (tp-signal-peek signal) 1))
(should (= (tp-signal-revision signal) 0))
(should (= (tp-binding-read binding) 1))
(should (= (tp-binding-revision binding) binding-revision))
(setq tp-binding-test-final-accept-function nil
tp--transaction-precommit-functions nil
tp--transaction-rollback-functions nil)
(tp-signal-set signal 2)
(should (= (tp-signal-peek signal) 2))
(should (= (tp-signal-revision signal) 1)))))
(ert-deftest tp-binding-test-nested-write-queues-a-second-pass ()
"A compute write queues stabilization instead of recursing."
(tp-binding-test--isolated
(let ((source (tp-signal-create 0))
(calls 0))
(let ((binding
(tp-bind 'owner '(test . stabilizing)
(lambda ()
(cl-incf calls)
(let ((value (tp-signal-read source)))
(when (zerop value)
(tp-signal-set source 1))
value)))))
(should (= (tp-binding-read binding) 1))
(should (= (tp-signal-peek source) 1))
(should (= calls 2))))))
(ert-deftest tp-binding-test-chain-stops-at-equal-computed-value ()
"An equal intermediate value prevents downstream recomputation."
(tp-binding-test--isolated
(let* ((source (tp-signal-create 10))
(middle-calls 0)
(leaf-calls 0)
(middle
(tp-bind 'middle-owner '(test . quotient)
(lambda ()
(cl-incf middle-calls)
(/ (tp-signal-read source) 10))))
(_leaf
(tp-bind 'leaf-owner '(test . display)
(lambda ()
(cl-incf leaf-calls)
(format "%s" (tp-binding-read middle))))))
(tp-signal-set source 11)
(should (= middle-calls 2))
(should (= leaf-calls 1))
(tp-signal-set source 20)
(should (= middle-calls 3))
(should (= leaf-calls 2)))))
(ert-deftest tp-binding-test-owner-disposal-cleans-graph-edges ()
"Disposing an owner removes all incoming and outgoing subscriptions."
(tp-binding-test--isolated
(let* ((source (tp-signal-create 1))
(owner (list 'owner))
(base (tp-bind owner '(test . base)
(lambda () (tp-signal-read source))))
(derived (tp-bind owner '(test . derived)
(lambda () (1+ (tp-binding-read base))))))
(should (= (tp-signal-subscriber-count source) 1))
(should (= (tp-binding-subscriber-count base) 1))
(should (= (tp-binding-dependency-count derived) 1))
(tp-binding-dispose-owner owner)
(should (= (tp-signal-subscriber-count source) 0))
(should (= (tp-binding-subscriber-count base) 0))
(should-not (tp-binding-live-p base))
(should-not (tp-binding-live-p derived)))))
(ert-deftest tp-binding-test-failed-compute-rolls-back-values-and-dependencies ()
"A failed transaction restores signal, binding, and dependency state."
(tp-binding-test--isolated
(let* ((switch (tp-signal-create t))
(left (tp-signal-create 10))
(right (tp-signal-create 20))
(binding
(tp-bind 'owner '(test . branch)
(lambda ()
(if (tp-signal-read switch)
(tp-signal-read left)
(progn
(tp-signal-read right)
(error "Broken branch")))))))
(let ((counters-before (tp-reactive-counters)))
(should-error (tp-signal-set switch nil) :type 'error)
(should (equal (tp-reactive-counters) counters-before)))
(should (tp-signal-peek switch))
(should (= (tp-binding-read binding) 10))
(should (= (tp-signal-subscriber-count left) 1))
(should (= (tp-signal-subscriber-count right) 0))
(tp-signal-set left 11)
(should (= (tp-binding-read binding) 11)))))
(ert-deftest tp-binding-test-failed-new-binding-is-unregistered ()
"A failed initial compute invalidates and unregisters the new binding."
(tp-binding-test--isolated
(let (failed)
(should-error
(tp-bind 'owner '(test . failing)
(lambda ()
(setq failed tp--current-binding)
(error "Initial failure"))))
(should-not (tp-binding-live-p failed))
(let ((replacement
(tp-bind 'owner '(test . failing) (lambda () 42))))
(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
(let ((switch (tp-signal-create nil)) first second)
(setq first
(tp-bind 'first-owner '(test . first)
(lambda ()
(if (tp-signal-read switch)
(tp-binding-read second)
1))))
(setq second
(tp-bind 'second-owner '(test . second)
(lambda () (1+ (tp-binding-read first)))))
(let ((failure
(should-error (tp-signal-set switch t)
:type 'tp-binding-cycle)))
(should
(equal (cadr failure)
'((test . first) (test . second) (test . first)))))
(should-not (tp-signal-peek switch))
(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-v2
:key key :stage #'ignore :rollback #'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-v2
:key (list 'test "participant" ["key"])
:stage #'ignore :rollback #'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
(let ((first-mode (tp-signal-create nil))
(second-mode (tp-signal-create t))
first second)
(setq first
(tp-bind 'first-owner '(test . first)
(lambda ()
(if (tp-signal-read first-mode)
(tp-binding-read second)
1))))
(setq second
(tp-bind 'second-owner '(test . second)
(lambda ()
(if (tp-signal-read second-mode)
(tp-binding-read first)
2))))
(tp-with-transaction
(tp-signal-set second-mode nil)
(tp-signal-set first-mode t))
(should (= (tp-binding-read first) 2))
(should (= (tp-binding-read second) 2)))))
(ert-deftest tp-binding-test-buffer-signal-dies-with-its-scope ()
"Killing a buffer-local source detaches all subscriptions."
(tp-binding-test--isolated
(let* ((buffer (generate-new-buffer " *tp-binding-scope*"))
(signal (tp-signal-create 1 :scope buffer))
(binding
(tp-bind 'owner '(test . local)
(lambda () (tp-signal-read signal)))))
(should (= (tp-binding-dependency-count binding) 1))
(kill-buffer buffer)
(should-not (tp-signal-live-p signal))
(should (= (tp-binding-dependency-count binding) 0)))))
(ert-deftest tp-binding-test-global-signal-can-be-disposed-explicitly ()
"Explicit disposal releases a global signal's graph edges."
(tp-binding-test--isolated
(let* ((signal (tp-signal-create 1))
(binding
(tp-bind 'owner '(test . global)
(lambda () (tp-signal-read signal)))))
(tp-signal-dispose signal)
(should-not (tp-signal-live-p signal))
(should (= (tp-signal-subscriber-count signal) 0))
(should (= (tp-binding-dependency-count binding) 0)))))
(ert-deftest tp-binding-test-variable-adapter-separates-global-and-buffer-scope ()
"Variable adapters route global and buffer-local writes precisely."
(tp-binding-test--isolated
(let* ((symbol 'tp-binding-test-variable)
(buffer (generate-new-buffer " *tp-binding-variable*"))
(global-calls 0)
(local-calls 0))
(unwind-protect
(progn
(set symbol 1)
(with-current-buffer buffer
(set (make-local-variable symbol) 10))
(let ((global (tp-variable-signal symbol))
(local (tp-variable-signal symbol buffer)))
(tp-bind 'global-owner '(test . global)
(lambda ()
(cl-incf global-calls)
(tp-signal-read global)))
(tp-bind 'local-owner '(test . local)
(lambda ()
(cl-incf local-calls)
(tp-signal-read local)))
(set symbol 2)
(should (= global-calls 2))
(should (= local-calls 1))
(with-current-buffer buffer
(set symbol 11))
(should (= global-calls 2))
(should (= local-calls 2))))
(when (buffer-live-p buffer) (kill-buffer buffer))
(makunbound symbol)))))
(ert-deftest tp-binding-test-precomputed-keeps-explicit-edge-reactive ()
"A precomputed binding skips first compute and reacts through its edge."
(let* ((signal (tp-signal-create 1))
(parent (tp-bind 'parent 'value (lambda () (tp-signal-read signal))))
(runs 0)
(child
(tp-bind-precomputed
'child 'value
(lambda () (cl-incf runs) (1+ (tp-binding-read parent)))
2 (list parent))))
(should (= (tp-binding-read child) 2))
(should (= runs 0))
(should (= (tp-binding-dependency-count child) 1))
(tp-signal-set signal 4)
(should (= (tp-binding-read child) 5))
(should (= runs 1))))
(provide 'tp-binding-tests)
;;; tp-binding-tests.el ends here

View File

@ -1,136 +0,0 @@
;;; tp-char-tests.el --- Character lookup tests for tp.el -*- lexical-binding: t -*-
;;; Commentary:
;; Stage 5 tests for `tp-lookup' character-property modes. These tests use
;; GNU Emacs public primitives as the oracle for overlay-aware behavior.
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'tp)
(require 'tp-query)
(defun tp-char-tests--source-result (position property)
"Return `tp-lookup' result for PROPERTY at POSITION in `:char-source' mode."
(tp-lookup position property :mode :char-source))
(ert-deftest tp-char-test-char-mode-returns-overlay-only-value ()
"The :char lookup mode returns the native overlay-only char property."
(with-temp-buffer
(insert "x")
(let ((overlay (make-overlay 1 2)))
(overlay-put overlay 'state 'overlay-only)
(let ((result (tp-lookup 1 'state :mode :char)))
(should (tp-lookup-result-present-p result))
(should (eq (tp-lookup-result-value result)
(get-char-property 1 'state)))
(should (eq (tp-lookup-result-value result) 'overlay-only))
(should (eq (tp-lookup-result-mode result) :char))))))
(ert-deftest tp-char-test-char-source-reports-winning-overlay-identity ()
"The :char-source lookup mode reports the native winning overlay."
(with-temp-buffer
(insert "x")
(let ((low (make-overlay 1 2))
(high (make-overlay 1 2)))
(overlay-put low 'priority 1)
(overlay-put low 'state 'low)
(overlay-put high 'priority 10)
(overlay-put high 'state 'high)
(let* ((native (get-char-property-and-overlay 1 'state))
(result (tp-char-tests--source-result 1 'state)))
(should (eq (car native) 'high))
(should (eq (cdr native) high))
(should (tp-lookup-result-present-p result))
(should (eq (tp-lookup-result-value result) (car native)))
(should (eq (tp-lookup-result-source result) :overlay))
(should (eq (tp-lookup-result-overlay result) (cdr native)))))))
(ert-deftest tp-char-test-text-effective-ignores-overlay-value ()
"The :text-effective lookup mode ignores overlay properties."
(with-temp-buffer
(insert "x")
(put-text-property 1 2 'state 'text)
(let ((overlay (make-overlay 1 2)))
(overlay-put overlay 'state 'overlay)
(let ((result (tp-lookup 1 'state :mode :text-effective)))
(should (tp-lookup-result-present-p result))
(should (eq (tp-lookup-result-value result)
(get-text-property 1 'state)))
(should (eq (tp-lookup-result-value result) 'text))))))
(ert-deftest tp-char-test-text-source-direct-nil-stops-fallback ()
"The :text-source lookup mode treats explicit nil text as present."
(with-temp-buffer
(insert "x")
(let ((category (make-symbol "tp-char-category"))
(default-text-properties '(state default)))
(put category 'state 'category)
(put-text-property 1 2 'category category)
(put-text-property 1 2 'state nil)
(let ((result (tp-lookup 1 'state :mode :text-source)))
(should (tp-lookup-result-present-p result))
(should-not (tp-lookup-result-value result))
(should (eq (tp-lookup-result-source result) :text-direct))))))
(ert-deftest tp-char-test-text-source-classifies-category-source ()
"The :text-source lookup mode classifies category fallback."
(with-temp-buffer
(insert "x")
(let ((category (make-symbol "tp-char-category")))
(put category 'state 'category)
(put-text-property 1 2 'category category)
(let ((result (tp-lookup 1 'state :mode :text-source)))
(should (tp-lookup-result-present-p result))
(should (eq (tp-lookup-result-value result) 'category))
(should (eq (tp-lookup-result-source result) :category))))))
(ert-deftest tp-char-test-text-source-classifies-alias-source ()
"The :text-source lookup mode classifies alias fallback."
(with-temp-buffer
(insert "x")
(let ((char-property-alias-alist '((state alternate))))
(put-text-property 1 2 'alternate 'alias)
(let ((result (tp-lookup 1 'state :mode :text-source)))
(should (tp-lookup-result-present-p result))
(should (eq (tp-lookup-result-value result) 'alias))
(should (eq (tp-lookup-result-source result) :alias))))))
(ert-deftest tp-char-test-text-source-classifies-default-source ()
"The :text-source lookup mode classifies default fallback."
(with-temp-buffer
(insert "x")
(let ((default-text-properties '(state default)))
(let ((result (tp-lookup 1 'state :mode :text-source)))
(should (tp-lookup-result-present-p result))
(should (eq (tp-lookup-result-value result) 'default))
(should (eq (tp-lookup-result-source result) :default))))))
(ert-deftest tp-char-test-text-source-classifies-absent-source ()
"The :text-source lookup mode classifies absent properties."
(with-temp-buffer
(insert "x")
(let ((result (tp-lookup 1 'state :mode :text-source)))
(should-not (tp-lookup-result-present-p result))
(should-not (tp-lookup-result-value result))
(should (eq (tp-lookup-result-source result) :absent)))))
(ert-deftest tp-char-test-char-source-follows-native-overlay-nil-fallback ()
"The :char-source lookup mode follows native explicit nil overlay fallback."
(with-temp-buffer
(insert "x")
(put-text-property 1 2 'state 'text)
(let ((overlay (make-overlay 1 2)))
(overlay-put overlay 'state nil)
(let* ((native (get-char-property-and-overlay 1 'state))
(result (tp-char-tests--source-result 1 'state)))
(should (eq (car native) 'text))
(should-not (cdr native))
(should (tp-lookup-result-present-p result))
(should (eq (tp-lookup-result-value result) (car native)))
(should-not (tp-lookup-result-overlay result))))))
(provide 'tp-char-tests)
;;; tp-char-tests.el ends here

View File

@ -1,95 +0,0 @@
;;; tp-convenience-tests.el --- Tests for TP convenience APIs -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;;; Commentary:
;; Contract tests for one-shot and reactive text-property conveniences.
;;; Code:
(require 'ert)
(require 'tp)
(ert-deftest tp-convenience-test-propertize-uses-style-projection ()
"Propertizing projects native declarations without mutating the input."
(let* ((callback (lambda (_window _object _position) "help"))
(source "Hello")
(result
(tp-propertize
source
(list 'face '(:foreground "red" :weight bold)
'help-echo callback 'keymap nil))))
(should (equal source "Hello"))
(should-not (text-properties-at 0 source))
(should (equal (get-text-property 0 'face result)
'(:foreground "red" :weight bold)))
(should (eq (get-text-property 0 'help-echo result) callback))
(should (plist-member (text-properties-at 0 result) 'keymap))
(should-not (get-text-property 0 'keymap result))))
(ert-deftest tp-convenience-test-apply-mutates-only-the-requested-range ()
"Applying declarations preserves text and properties outside the range."
(with-temp-buffer
(insert "abcdef")
(put-text-property 1 7 'category 'host)
(should (equal (tp-apply (current-buffer) 2 5 '(face italic)) '(2 . 5)))
(should (equal (buffer-string) "abcdef"))
(should-not (get-text-property 1 'face))
(should (eq (get-text-property 2 'face) 'italic))
(should-not (get-text-property 5 'face))
(should (eq (get-text-property 3 'category) 'host))))
(ert-deftest tp-convenience-test-apply-rejects-invalid-targets-and-ranges ()
"Applying never falls back from an invalid target to the current buffer."
(with-temp-buffer
(insert "safe")
(should-error (tp-apply " *missing-tp-buffer*" 1 2 '(face bold))
:type 'tp-unsupported-buffer)
(should-error (tp-apply (current-buffer) 4 2 '(face bold))
:type 'args-out-of-range)
(should (equal (buffer-string) "safe"))
(should-not (text-properties-at 0 (buffer-string)))))
(ert-deftest tp-convenience-test-watch-reacts-and-restores-host-properties ()
"Watching a range updates properties through one retained surface."
(with-temp-buffer
(insert "Status")
(put-text-property 1 7 'help-echo "host")
(let* ((connected (tp-signal-create nil))
(surface
(tp-watch
(current-buffer) 1 7
(lambda ()
(if (tp-signal-read connected)
'(face (:foreground "green") help-echo "Connected")
'(face (:foreground "red") help-echo "Disconnected"))))))
(should (equal (buffer-string) "Status"))
(should (equal (get-text-property 2 'face)
'(:foreground "red")))
(should (equal (get-text-property 2 'help-echo) "Disconnected"))
(tp-signal-set connected t)
(should (equal (get-text-property 2 'face)
'(:foreground "green")))
(should (equal (get-text-property 2 'help-echo) "Connected"))
(should (= (tp-surface-revision surface) 2))
(tp-surface-unmount surface)
(should-not (get-text-property 2 'face))
(should (equal (get-text-property 2 'help-echo) "host")))))
(ert-deftest tp-convenience-test-failed-watch-releases-its-range-anchor ()
"A failed first watch publication leaves no live marker-backed anchor."
(with-temp-buffer
(insert "host")
(let ((original (symbol-function 'tp-range-anchor-create))
anchor)
(cl-letf (((symbol-function 'tp-range-anchor-create)
(lambda (&rest arguments)
(setq anchor (apply original arguments)))))
(should-error
(tp-watch (current-buffer) 1 5
(lambda () (error "Initial compute failed")))))
(should-not (tp-range-anchor-live-p anchor)))))
(provide 'tp-convenience-tests)
;;; tp-convenience-tests.el ends here

View File

@ -1,409 +0,0 @@
;;; tp-core-tests.el --- ERT tests for tp-core.el -*- lexical-binding: t -*-
;;; Commentary:
;; Unit tests for the tp-core foundation module.
;;; Code:
(require 'ert)
(require 'tp-core)
;;; tp--map-intervals
(ert-deftest tp-core-test-map-intervals-string-clips ()
"Intervals extending beyond the range are clipped to it."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 11 'face 'bold str)
(should (equal (tp--map-intervals str 3 7 #'list)
'((3 7 (face bold)))))))
(ert-deftest tp-core-test-map-intervals-string-full ()
"Full-range walk over a string returns each property run."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 5 'face 'bold str)
(should (equal (tp--map-intervals str nil nil #'list)
'((0 5 (face bold)) (5 11 nil))))))
(ert-deftest tp-core-test-map-intervals-single-property ()
"PROPERTY narrows runs to that property and passes its value."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 5 'face 'bold str)
(put-text-property 2 8 'help-echo "tip" str)
(should (equal (tp--map-intervals str nil nil #'list 'face)
'((0 5 bold) (5 11 nil))))))
(ert-deftest tp-core-test-map-intervals-buffer-clips ()
"Buffer walk clips to the requested range with 1-based positions."
(with-temp-buffer
(insert "hello world")
(put-text-property 1 12 'face 'bold)
(should (equal (tp--map-intervals nil 4 8 #'list)
'((4 8 (face bold)))))))
(ert-deftest tp-core-test-map-intervals-buffer-multiple-runs ()
"Multiple runs in a buffer are visited in order, gaps included."
(with-temp-buffer
(insert "hello world")
(put-text-property 1 6 'face 'bold)
(put-text-property 7 12 'face 'italic)
(should (equal (tp--map-intervals nil nil nil #'list 'face)
'((1 6 bold) (6 7 nil) (7 12 italic))))))
(ert-deftest tp-core-test-map-intervals-out-of-range-normalized ()
"Out-of-bounds START/END are clamped, not signaled."
(let ((str (copy-sequence "abc")))
(put-text-property 0 3 'p 1 str)
(should (equal (tp--map-intervals str -5 99 #'list 'p)
'((0 3 1))))))
(ert-deftest tp-core-test-map-intervals-empty-range ()
"An empty range visits nothing."
(let ((str (copy-sequence "abc")))
(should (equal (tp--map-intervals str 1 1 #'list) nil))))
;;; tp-face-properties
(ert-deftest tp-core-test-face-properties ()
"The face-family property list contains the three face properties."
(should (equal tp-face-properties '(face font-lock-face mouse-face))))
;;; Stage 2 canonical façade
(ert-deftest tp-core-test-native-range-string-and-buffer-coordinates ()
"Canonical ranges store concrete objects and native coordinates."
(let* ((str (copy-sequence "abcd"))
(range (tp--native-range-from-object str 1 3)))
(should (tp--native-range-p range))
(should (eq (tp--native-range-kind range) :string))
(should (eq (tp--native-range-object range) str))
(should (equal (list (tp--native-range-start range)
(tp--native-range-end range))
'(1 3))))
(with-temp-buffer
(insert "abcd")
(narrow-to-region 2 4)
(let ((range (tp--native-range-from-object nil nil nil)))
(should (eq (tp--native-range-kind range) :buffer))
(should (eq (tp--native-range-object range) (current-buffer)))
(should (equal (list (tp--native-range-start range)
(tp--native-range-end range))
'(2 4))))))
(ert-deftest tp-core-test-presence-distinguishes-three-value-states ()
"Canonical presence distinguishes absence, explicit nil, and a value."
(let ((str (copy-sequence "abc")))
(put-text-property 0 1 'state nil str)
(put-text-property 1 2 'state 'ready str)
(let ((nil-value (tp--presence-at 0 'state str))
(value (tp--presence-at 1 'state str))
(absent (tp--presence-at 2 'state str)))
(should (tp--presence-present-p nil-value))
(should-not (tp--presence-value nil-value))
(should (tp--presence-present-p value))
(should (eq (tp--presence-value value) 'ready))
(should-not (tp--presence-present-p absent))
(should-not (tp--presence-value absent)))))
(ert-deftest tp-core-test-canonical-request-match-and-result-adapters ()
"Canonical records preserve policy and adapt only at public boundaries."
(let* ((str (copy-sequence "abcd"))
(range (tp--native-range-from-object str 1 3))
(request (tp--make-request
:operation :set :range range :props '(face bold)
:mutation :copy :read-only :respect
:noerror nil :public-return :range))
(match (tp--make-match range 'face 'bold))
(result (tp--make-result
:request request :matches (list match)
:count 1 :object str :native 'native-value)))
(should (tp--request-p request))
(should (eq (tp--request-operation request) :set))
(should (eq (tp--request-mutation request) :copy))
(should (equal (tp--match-to-list match) '(1 3 bold)))
(let ((native-match (tp--match-to-prop-match match)))
(should (= (prop-match-beginning native-match) 1))
(should (= (prop-match-end native-match) 3))
(should (eq (prop-match-value native-match) 'bold)))
(should (equal (tp--result-public-value result) '(1 . 3)))
(setf (tp--request-public-return request) :matches)
(should (equal (tp--result-public-value result) '((1 3 bold))))
(setf (tp--request-public-return request) :count)
(should (= (tp--result-public-value result) 1))
(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"])))))
(ert-deftest tp-core-test-property-value-copy-isolates-full-keymaps ()
"Full keymaps, parent maps and self-references retain an isolated graph."
(let* ((map (make-keymap))
(parent (make-keymap))
(callback (lambda () "callback")))
(define-key map (kbd "RET") callback)
(define-key parent (kbd "x") #'ignore)
(define-key map [prefix] map)
(set-keymap-parent map parent)
(let ((copy (tp-property-value-copy map)))
(should-not (eq copy map))
(should-not (eq (keymap-parent copy) parent))
(should (eq (lookup-key copy [prefix]) copy))
(should (eq (lookup-key copy (kbd "RET")) callback))
(define-key map (kbd "RET") #'forward-char)
(define-key parent (kbd "x") #'backward-char)
(should (eq (lookup-key copy (kbd "RET")) callback))
(should (eq (lookup-key copy (kbd "x")) #'ignore)))))
(ert-deftest tp-core-test-property-value-copy-preserves-character-table-structure ()
"Local ranges, defaults, parents, extra slots and cycles are copied faithfully."
(let ((purpose (make-symbol "tp-copy-table")))
(put purpose 'char-table-extra-slots 1)
(let* ((parent (make-char-table purpose))
(table (make-char-table purpose))
(value (list 'value)))
(set-char-table-range parent ?p value)
(set-char-table-range table ?x value)
(set-char-table-range table ?s table)
(set-char-table-extra-slot table 0 value)
(set-char-table-parent table parent)
(let ((copy (tp-property-value-copy table)))
(should (eq (char-table-range copy ?s) copy))
(should (eq (char-table-range copy ?x) (char-table-extra-slot copy 0)))
(should (eq (char-table-range copy ?x)
(char-table-range (char-table-parent copy) ?p)))
(set-char-table-range (char-table-parent copy) ?p 'new)
(should (eq (char-table-range copy ?p) 'new))
(set-char-table-range copy nil 'default)
(should (eq (char-table-range copy ?z) 'default))
(setcar value 'mutated)
(should (equal (char-table-range copy ?x) '(value)))))))
(ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
"Property copies keep list-shaped function values opaque."
(let ((function-value '(lambda () 1)))
(should (functionp function-value))
(should (eq (tp--copy-property-value function-value)
function-value))))
(ert-deftest tp-core-test-property-value-copy-deep-copies-string-properties ()
"Property copies do not alias mutable values stored in string properties."
(let* ((owners (list 'original))
(text (copy-sequence "x")))
(add-text-properties 0 1 (list 'ebox-content-owners owners) text)
(let ((copy (tp--copy-property-value text)))
(should-not (eq copy text))
(should-not (eq (get-text-property 0 'ebox-content-owners copy)
owners))
(setcar owners 'caller-mutated)
(should (equal (get-text-property 0 'ebox-content-owners copy)
'(original)))
(setcar (get-text-property 0 'ebox-content-owners copy) 'copy-mutated)
(should (equal (get-text-property 0 'ebox-content-owners text)
'(caller-mutated))))))
(ert-deftest tp-core-test-property-value-copy-preserves-source-identity-rules ()
"Property copies memoize one source identity without canonicalizing equals."
(let* ((shared (list 'shared))
(equal-but-distinct (list 'shared))
(value (list shared shared equal-but-distinct))
(copy (tp--copy-property-value value)))
(should (eq (nth 0 copy) (nth 1 copy)))
(should-not (eq (nth 0 copy) (nth 2 copy)))
(should-not (eq (nth 0 copy) shared))
(should-not (eq (nth 2 copy) equal-but-distinct))
(setcar shared 'source-mutated)
(should (equal (nth 0 copy) '(shared)))
(setcar (nth 0 copy) 'copy-mutated)
(should (equal shared '(source-mutated)))
(should (equal equal-but-distinct '(shared)))))
(ert-deftest tp-core-test-property-value-copy-reuses-string-identity ()
"Property copies preserve repeated references to one propertized string."
(let* ((shared (copy-sequence "shared"))
(value (list shared shared))
(copy (tp--copy-property-value value)))
(should (eq (nth 0 copy) (nth 1 copy)))
(should-not (eq (nth 0 copy) shared))))
(ert-deftest tp-core-test-text-snapshot-transfers-authorized-values ()
"Text snapshots transfer only values explicitly owned by the caller."
(let* ((owned (list :face t))
(copied (list :face t))
(text (copy-sequence "ab")))
(put-text-property 0 1 'face owned text)
(put-text-property 1 2 'payload copied text)
(let ((snapshot
(tp-text-snapshot
text (lambda (property value)
(and (eq property 'face) (eq value owned))))))
(should (eq (get-text-property 0 'face snapshot) owned))
(should-not (eq (get-text-property 1 'payload snapshot) copied))
(should-not (eq (get-text-property 1 'payload snapshot) owned)))))
(ert-deftest tp-core-test-text-snapshot-transfer-does-not-pollute-copy-cache ()
"Transferred values do not make an unauthorized property alias its source."
(let* ((shared (list :face t))
(text (copy-sequence "ab")))
(put-text-property 0 1 'face shared text)
(put-text-property 1 2 'payload shared text)
(let ((snapshot
(tp-text-snapshot
text (lambda (property _value) (eq property 'face)))))
(should (eq (get-text-property 0 'face snapshot) shared))
(should-not (eq (get-text-property 1 'payload snapshot) shared))
(should-not (eq (get-text-property 1 'payload snapshot)
(get-text-property 0 'face snapshot))))))
(ert-deftest tp-core-test-text-snapshot-copies-propertized-strings-by-default ()
"Text snapshots preserve nested string properties under strict copying."
(let* ((first (propertize "x" 'nested 'first))
(second (propertize "x" 'nested 'second))
(text (copy-sequence "ab")))
(put-text-property 0 1 'payload first text)
(put-text-property 1 2 'payload second text)
(let ((snapshot (tp-text-snapshot text)))
(should-not (eq (get-text-property 0 'payload snapshot)
(get-text-property 1 'payload snapshot)))
(should (eq (get-text-property 0 'nested
(get-text-property 0 'payload snapshot))
'first))
(should (eq (get-text-property 0 'nested
(get-text-property 1 'payload snapshot))
'second)))))
(ert-deftest tp-core-test-text-snapshot-copies-circular-values-by-default ()
"Text snapshots copy circular values without invoking equality."
(let* ((first (cons :cycle nil))
(second (cons :cycle nil))
(text (copy-sequence "ab")))
(setcdr first first)
(setcdr second second)
(put-text-property 0 1 'payload first text)
(put-text-property 1 2 'payload second text)
(let ((snapshot (tp-text-snapshot text)))
(should-not (eq (get-text-property 0 'payload snapshot)
(get-text-property 1 'payload snapshot)))
(should (eq (cdr (get-text-property 0 'payload snapshot))
(get-text-property 0 'payload snapshot)))
(should (eq (cdr (get-text-property 1 'payload snapshot))
(get-text-property 1 'payload snapshot))))))
(ert-deftest tp-core-test-property-value-copy-preserves-flat-list-sharing ()
"Flat-list snapshots memoize every cons cell, including shared tails."
(let* ((tail (list :tail))
(value (list (cons :head tail) tail))
(copy (tp--copy-property-value value)))
(should (eq (cdr (car copy)) (cadr copy)))
(should-not (eq (cadr copy) tail))))
(ert-deftest tp-core-test-property-value-copy-terminates-on-circular-list ()
"Circular list snapshots use the recursive memo path without looping."
(let ((value (cons :cycle nil)))
(setcdr value value)
(let ((copy (tp--copy-property-value value)))
(should-not (eq copy value))
(should (eq (cdr copy) copy)))))
(ert-deftest tp-core-test-public-property-value-copy-is-defensive ()
"The public copy boundary preserves opaque values and isolates containers."
(let* ((function (lambda () t))
(source (list :nested (vector "value") :function function))
(copy (tp-property-value-copy source)))
(should (equal copy source))
(should-not (eq copy source))
(should-not (eq (plist-get copy :nested)
(plist-get source :nested)))
(should (eq (plist-get copy :function) function))))
;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map
(ert-deftest tp-core-test-intervals-buffer-relative-default ()
"Without ABSOLUTE, buffer intervals stay START-relative (legacy)."
(with-temp-buffer
(insert "hello world")
(put-text-property 4 8 'face 'bold)
(should (equal (tp-intervals 3 9)
'((0 1 nil) (1 5 (face bold)) (5 6 nil))))))
(ert-deftest tp-core-test-intervals-buffer-absolute ()
"With ABSOLUTE, buffer intervals use native 1-based positions."
(with-temp-buffer
(insert "hello world")
(put-text-property 4 8 'face 'bold)
(should (equal (tp-intervals 3 9 nil t)
'((3 4 nil) (4 8 (face bold)) (8 9 nil))))
;; Clipping still applies in native coordinates.
(should (equal (tp-intervals 5 7 nil t)
'((5 7 (face bold)))))))
(ert-deftest tp-core-test-intervals-string-ignores-absolute ()
"String intervals are already absolute; ABSOLUTE changes nothing."
(let ((s (copy-sequence "hello world")))
(put-text-property 3 7 'face 'bold s)
(should (equal (tp-intervals 2 9 s) (tp-intervals 2 9 s t)))
(should (equal (tp-intervals 2 9 s t)
'((2 3 nil) (3 7 (face bold)) (7 9 nil))))))
(ert-deftest tp-core-test-intervals-map-absolute ()
"tp-intervals-map passes ABSOLUTE through to native positions."
(with-temp-buffer
(insert "hello world")
(put-text-property 4 8 'face 'bold)
(should (equal (tp-intervals-map #'list 3 9)
'((0 1 nil nil) (1 5 (face bold) nil) (5 6 nil nil))))
(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-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 help-echo "direct"))
(let ((res (tp-intervals-map #'list 1 6 nil t)))
(should (= (length res) 1))
(pcase-let ((`(,beg ,end ,props ,reserved) (car res)))
(should (= beg 1))
(should (= end 6))
(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."
(with-temp-buffer
(insert "hello world")
(put-text-property 4 8 'face 'bold)
(should (equal (tp-intervals-map
(lambda (beg end top _below)
(when (plist-get top 'face) (cons beg end)))
1 12 nil t)
'((4 . 8))))))
(provide 'tp-core-tests)
;;; tp-core-tests.el ends here

View File

@ -1,196 +0,0 @@
;;; tp-doctest.el --- Executable TP 1.0 examples -*- lexical-binding: t; -*-
;; Copyright (C) 2024-2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Executable counterparts of the public examples in README.md and
;; README_CN.md. Run with `make doctest'.
;;; Code:
(require 'cl-lib)
(require 'tp)
(defvar tp-doctest--failures 0
"Number of failed TP documentation examples.")
(defvar tp-doctest--total 0
"Number of executed TP documentation examples.")
(defvar tp-doctest--computed-calls 0
"Number of explicit computed-value calls in the doctest.")
(defvar tp-doctest--height 7
"Height returned by the doctest's explicit computed value.")
(defmacro tp-doctest--check (label expected &rest body)
"Run BODY and compare its value with EXPECTED under LABEL."
(declare (indent 2) (debug t))
`(let* ((wanted ,expected)
(actual
(condition-case error-data
(progn ,@body)
(error (list :unexpected-error error-data)))))
(cl-incf tp-doctest--total)
(if (equal actual wanted)
(princ (format "PASS %s\n" ,label))
(cl-incf tp-doctest--failures)
(princ (format "FAIL %s\n expected: %S\n actual: %S\n"
,label wanted actual)))))
(unwind-protect
(progn
(tp-doctest--check "static-propertize"
'("Hello" (:foreground "white" :background "navy") t nil)
(let* ((callback (lambda (_window _object _position) "Open"))
(text
(tp-propertize
"Hello"
(list 'face '(:foreground "white" :background "navy")
'help-echo callback 'keymap nil))))
(list (substring-no-properties text)
(get-text-property 0 'face text)
(eq (get-text-property 0 'help-echo text) callback)
(get-text-property 0 'keymap text))))
(tp-doctest--check "buffer-apply"
'("abcdef" nil italic nil host)
(with-temp-buffer
(insert "abcdef")
(put-text-property 1 7 'category 'host)
(tp-apply (current-buffer) 2 5 '(face italic))
(list (buffer-string)
(get-text-property 1 'face)
(get-text-property 2 'face)
(get-text-property 5 'face)
(get-text-property 3 'category))))
(tp-doctest--check "declaration-recipe"
'((:foreground "cyan" :weight bold) "Open item" nil)
(define-tp tp-doctest-link (foreground)
`(face (:foreground ,foreground :weight bold)
help-echo "Open item"
keymap nil))
(let ((text (tp-set "item" '(tp-doctest-link "cyan"))))
(list (get-text-property 0 'face text)
(get-text-property 0 'help-echo text)
(get-text-property 0 'keymap text))))
(tp-doctest--check "explicit-computed-value"
'(1 (:height 7))
(setq tp-doctest--computed-calls 0)
(define-tp tp-doctest-sized ()
`(face ,(tp-computed
(lambda ()
(cl-incf tp-doctest--computed-calls)
(list :height tp-doctest--height)))))
(let ((text (tp-set "size" 'tp-doctest-sized)))
(list tp-doctest--computed-calls
(get-text-property 0 'face text))))
(tp-doctest--check "reactive-existing-text"
'((:foreground "red") (:foreground "green") 2 nil)
(with-temp-buffer
(insert "offline")
(let* ((online (tp-signal-create nil))
(surface
(tp-watch
(current-buffer) 1 8
(lambda ()
(list 'face
(list :foreground
(if (tp-signal-read online)
"green"
"red"))))))
(before (get-text-property 1 'face)))
(tp-signal-set online t)
(prog1
(list before
(get-text-property 1 'face)
(tp-surface-revision surface)
(plist-get (tp-surface-unmount surface)
:property-conflicts))
(tp-signal-dispose online)))))
(tp-doctest--check "retained-content"
'("ready" "done" 2 1)
(with-temp-buffer
(let* ((status (tp-signal-create "ready"))
(producer
(lambda (context)
(let* ((object
(tp-object-ensure context nil 'status 'text))
(binding
(tp-bind object '(readme . status)
(lambda () (tp-signal-read status)))))
(tp-surface-plan-create
:key 'status :kind 'text
:text (tp-binding-read binding)
:props '(face bold) :capability 'content))))
(surface
(tp-surface-mount
(current-buffer) producer '(:capability content)))
(first (buffer-string)))
(tp-with-transaction
(tp-signal-set status "working")
(tp-signal-set status "done"))
(prog1
(list first (buffer-string)
(tp-surface-revision surface)
(plist-get (tp-surface-report surface)
:text-operations))
(tp-surface-unmount surface)
(tp-signal-dispose status)))))
(tp-doctest--check "retained-noop"
'(1 1 nil)
(with-temp-buffer
(let* ((plan
(tp-surface-plan-create
:key 'root :kind 'text :text "same"
:capability 'content))
(surface
(tp-surface-mount
(current-buffer) plan '(:capability content)))
(revision (tp-surface-revision surface)))
(set-buffer-modified-p nil)
(tp-surface-update surface plan)
(prog1
(list revision
(tp-surface-revision surface)
(buffer-modified-p))
(tp-surface-unmount surface)))))
(tp-doctest--check "materialize-is-ephemeral"
'("42" nil nil 0)
(let ((signal (tp-signal-create 42)) object binding)
(let ((text
(tp-surface-materialize-string
(lambda (context)
(setq object
(tp-object-ensure context nil 'value 'text)
binding
(tp-bind object '(readme . value)
(lambda () (tp-signal-read signal))))
(tp-surface-plan-create
:key 'value :kind 'text
:text (number-to-string (tp-binding-read binding))
:capability 'content)))))
(prog1
(list text
(tp-object-live-p object)
(tp-binding-live-p binding)
(tp-signal-subscriber-count signal))
(tp-signal-dispose signal))))))
(tp-layer-reset)
(tp-reactive-reset))
(princ (format "\nTOTAL: %d FAILURES: %d\n"
tp-doctest--total tp-doctest--failures))
(when (> tp-doctest--failures 0)
(kill-emacs 1))
(provide 'tp-doctest)
;;; tp-doctest.el ends here

View File

@ -1,247 +0,0 @@
;;; 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

View File

@ -1,296 +0,0 @@
;;; tp-layer-tests.el --- Declaration recipe tests -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Contract tests for static and parameterized named declaration recipes.
;;; Code:
(require 'ert)
(require 'tp)
(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)))
(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")))))
(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
(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-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-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)))
(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-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

View File

@ -1,188 +0,0 @@
;;; tp-m0a-characterization-tests.el --- Current TP completion semantics -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;;; Commentary:
;; Focused M0a characterization tests for completion semantics that are
;; already implemented. Future structured batches and final markers do not
;; belong in this baseline.
;;; Code:
(require 'cl-lib)
(require 'ert)
(require 'tp-surface)
(define-error 'tp-m0a-characterization-error
"Injected TP M0a characterization failure")
(defvar tp-m0a-characterization--precommit-condition nil
"Condition injected by the M0a precommit test hook.")
(defun tp--m0a-characterization-precommit-inject ()
"Signal `tp-m0a-characterization--precommit-condition'."
(when tp-m0a-characterization--precommit-condition
(signal (car tp-m0a-characterization--precommit-condition)
(cdr tp-m0a-characterization--precommit-condition))))
(defun tp-m0a-characterization--leaf (text)
"Return a retained content leaf displaying TEXT."
(tp-surface-plan-create
:key 'root :kind 'text :text text :capability 'content))
(defun tp-m0a-characterization--producer (source)
"Return a retained content producer reading SOURCE."
(lambda (context)
(tp-object-ensure context nil 'root 'text)
(tp-m0a-characterization--leaf
(number-to-string (tp-signal-read source)))))
(defun tp-m0a-characterization--capture (function)
"Call FUNCTION and return its signaled condition."
(condition-case condition
(progn (funcall function) nil)
(tp-m0a-characterization-error condition)))
(cl-defmacro tp-m0a-characterization--with-surface
((buffer surface source) &rest body)
"Create BUFFER, SOURCE, and SURFACE, then evaluate BODY."
(declare (indent 1) (debug ((symbolp symbolp symbolp) body)))
`(let* ((,buffer (generate-new-buffer " *tp-m0a-characterization*"))
(,source (tp-signal-create 1))
(,surface
(tp-surface-mount
,buffer (tp-m0a-characterization--producer ,source)
'(:capability content))))
(unwind-protect
(progn ,@body)
(when (buffer-live-p ,buffer)
(kill-buffer ,buffer))
(when (tp-signal-live-p ,source)
(tp-signal-dispose ,source)))))
(ert-deftest tp-m0a-characterization-test-first-surface-failure-rolls-back-batch ()
"A first-surface failure restores every surface and the source state."
(let* ((source (tp-signal-create 1))
(producer (tp-m0a-characterization--producer source))
(first-buffer (generate-new-buffer " *tp-m0a-first*"))
(second-buffer (generate-new-buffer " *tp-m0a-second*"))
(first (tp-surface-mount
first-buffer producer '(:capability content)))
(second (tp-surface-mount
second-buffer producer '(:capability content)))
(first-revision (tp-surface-revision first))
(second-revision (tp-surface-revision second))
(injected '(tp-m0a-characterization-error
:phase first-surface :payload (1 2 3)))
(tp--surface-publication-step-function
(lambda (step surface)
(when (and (eq step 'client-state) (eq surface first))
(signal (car injected) (cdr injected))))))
(unwind-protect
(let ((failure
(tp-m0a-characterization--capture
(lambda () (tp-signal-set source 2)))))
(should (equal failure injected))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision first) first-revision))
(should (= (tp-surface-revision second) second-revision))
(with-current-buffer first-buffer
(should (equal (buffer-string) "1")))
(with-current-buffer second-buffer
(should (equal (buffer-string) "1"))))
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
(when (buffer-live-p second-buffer) (kill-buffer second-buffer))
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
(ert-deftest tp-m0a-characterization-test-participant-failure-preserves-condition ()
"A participant failure preserves raw condition data and restores all owners."
(tp-m0a-characterization--with-surface (buffer surface source)
(let ((external 'old)
(revision (tp-surface-revision surface))
(injected '(tp-m0a-characterization-error
:phase participant :payload [raw data])))
(let ((failure
(tp-m0a-characterization--capture
(lambda ()
(tp-with-transaction
(tp-transaction-participate-v2
:key 'm0a-participant
:stage (lambda ()
(setq external 'candidate)
(signal (car injected) (cdr injected)))
:rollback (lambda () (setq external 'old)))
(tp-signal-set source 2))))))
(should (equal failure injected)))
(should (eq external 'old))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(ert-deftest tp-m0a-characterization-test-precommit-failure-preserves-condition ()
"A precommit failure preserves raw condition data and restores publication."
(tp-m0a-characterization--with-surface (buffer surface source)
(let* ((revision (tp-surface-revision surface))
(injected '(tp-m0a-characterization-error
:phase precommit :payload (raw data)))
(tp--transaction-precommit-functions
'(tp--m0a-characterization-precommit-inject))
(tp--transaction-precommit-allowed-functions
'(tp--m0a-characterization-precommit-inject))
(tp-m0a-characterization--precommit-condition injected)
(failure
(tp-m0a-characterization--capture
(lambda () (tp-signal-set source 2)))))
(should (equal failure injected))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(ert-deftest tp-m0a-characterization-test-signal-commit-failure-preserves-condition ()
"A signal commit failure preserves raw condition data and restores publication."
(tp-m0a-characterization--with-surface (buffer surface source)
(let ((revision (tp-surface-revision surface))
(injected '(tp-m0a-characterization-error
:phase signal :payload (:raw data)))
(original (symbol-function 'tp--commit-signal-entry)))
(let ((failure
(cl-letf (((symbol-function 'tp--commit-signal-entry)
(lambda (entry)
(funcall original entry)
(signal (car injected) (cdr injected)))))
(tp-m0a-characterization--capture
(lambda () (tp-signal-set source 2))))))
(should (equal failure injected)))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(ert-deftest tp-m0a-characterization-test-final-accept-failure-preserves-condition ()
"A final-accept failure preserves raw condition data and restores publication."
(tp-m0a-characterization--with-surface (buffer surface source)
(let ((revision (tp-surface-revision surface))
(injected '(tp-m0a-characterization-error
:phase final-accept :payload ((raw . data)))))
(let ((failure
(cl-letf (((symbol-function 'accept-change-group)
(lambda (_group)
(signal (car injected) (cdr injected)))))
(tp-m0a-characterization--capture
(lambda () (tp-signal-set source 2))))))
(should (equal failure injected)))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(provide 'tp-m0a-characterization-tests)
;;; tp-m0a-characterization-tests.el ends here

View File

@ -1,210 +0,0 @@
;;; tp-native-tests.el --- Native text-property equivalence tests -*- lexical-binding: t -*-
;;; Commentary:
;; Stage 3/5 tests for the explicit GNU Emacs text/character property
;; compatibility boundary. Tests compare tp entry points with public Emacs
;; primitives rather than duplicating their expected implementation.
;;; Code:
(require 'ert)
(require 'tp)
(ert-deftest tp-native-test-lookup-direct-presence-states ()
"Direct lookup distinguishes absence, explicit nil, and a value."
(let ((str (copy-sequence "abc")))
(put-text-property 0 1 'state nil str)
(put-text-property 1 2 'state 'ready str)
(let ((nil-value (tp-lookup 0 'state :object str :mode :text-direct))
(value (tp-lookup 1 'state :object str :mode :text-direct))
(absent (tp-lookup 2 'state :object str :mode :text-direct)))
(should (tp-lookup-result-present-p nil-value))
(should-not (tp-lookup-result-value nil-value))
(should (eq (tp-lookup-result-source nil-value) :text-direct))
(should (tp-lookup-result-present-p value))
(should (eq (tp-lookup-result-value value) 'ready))
(should-not (tp-lookup-result-present-p absent))
(should (eq (tp-lookup-result-source absent) :absent)))))
(ert-deftest tp-native-test-lookup-effective-source-matrix ()
"Source lookup explains direct, category, alias, and default values.
Like native lookup, a nil alias value falls through to the default."
(let* ((str (copy-sequence "abcd"))
(category (make-symbol "tp-native-category"))
(char-property-alias-alist '((state alternate)))
(default-text-properties '(state default)))
(put category 'state 'category)
(put-text-property 0 1 'state nil str)
(put-text-property 1 2 'category category str)
(put-text-property 2 3 'alternate 'alias str)
(put-text-property 3 4 'alternate nil str)
(dolist (case '((0 nil :text-direct)
(1 category :category)
(2 alias :alias)
(3 default :default)))
(pcase-let ((`(,position ,value ,source) case))
(let ((result (tp-lookup
position 'state :object str :mode :text-source)))
(should (tp-lookup-result-present-p result))
(should (equal (tp-lookup-result-value result) value))
(should (eq (tp-lookup-result-source result) source))
(should (equal
(tp-lookup-result-value
(tp-lookup position 'state
:object str :mode :text-effective))
(get-text-property position 'state str))))))))
(ert-deftest tp-native-test-property-change-matches-emacs ()
"Single/all and next/previous change queries match Emacs primitives."
(let ((str (copy-sequence "abcdef")))
(put-text-property 0 3 'state 1 str)
(put-text-property 3 6 'state 2 str)
(put-text-property 1 2 'unrelated t str)
(should (equal
(tp-property-change
0 :property 'state :object str :limit 6 :direction :next)
(next-single-property-change 0 'state str 6)))
(should (equal
(tp-property-change 0 :object str :limit 6 :direction :next)
(next-property-change 0 str 6)))
(should (equal
(tp-property-change
6 :property 'state :object str :limit 0 :direction :previous)
(previous-single-property-change 6 'state str 0)))
(should (equal
(tp-property-change 6 :object str :limit 0 :direction :previous)
(previous-property-change 6 str 0)))))
(ert-deftest tp-native-test-property-any-not-all-match-emacs ()
"Region equality predicates preserve exact nil behavior."
(let ((str (copy-sequence "abcd")))
(put-text-property 0 2 'state nil str)
(put-text-property 2 4 'state 'ready str)
(dolist (value '(nil ready missing))
(should (equal (tp-property-any 0 4 'state value str)
(text-property-any 0 4 'state value str)))
(should (equal (tp-property-not-all 0 4 'state value str)
(text-property-not-all 0 4 'state value str))))))
(ert-deftest tp-native-test-mutation-policy-respect-and-inhibit ()
"Read-only override is explicit and ordinary mode records changes."
(with-temp-buffer
(insert "abc")
(put-text-property 1 2 'read-only t)
(should-error
(tp-with-mutation-policy
'(:modified :ordinary :read-only :respect)
(tp-set 1 2 '(face bold))))
(tp-with-mutation-policy
'(:modified :ordinary :read-only :inhibit)
(tp-set 1 2 '(face bold)))
(should (eq (get-text-property 1 'face) 'bold)))
(with-temp-buffer
(buffer-enable-undo)
(insert "abc")
(setq buffer-undo-list nil)
(set-buffer-modified-p nil)
(tp-with-mutation-policy
'(:modified :ordinary :read-only :respect)
(tp-set 1 2 '(face bold)))
(should (buffer-modified-p))
(should (consp buffer-undo-list))))
(ert-deftest tp-native-test-mutation-policy-silent ()
"Silent property writes keep modified and undo state unchanged."
(with-temp-buffer
(buffer-enable-undo)
(insert "abc")
(setq buffer-undo-list nil)
(set-buffer-modified-p nil)
(tp-with-mutation-policy
'(:modified :silent :read-only :inhibit)
(tp-set 1 2 '(face bold)))
(should (eq (get-text-property 1 'face) 'bold))
(should-not (buffer-modified-p))
(should-not buffer-undo-list))
(should-error
(tp-with-mutation-policy
'(:modified :silent :read-only :respect)
nil))
(should-error
(tp-with-mutation-policy '(:unknown t) nil))
(should-error
(tp-with-mutation-policy '(:modified nil) nil))
(should-error
(tp-with-mutation-policy '(:modified) nil)))
(ert-deftest tp-native-test-stickiness-and-insertion-delegation ()
"tp-set properties retain native insert and insert-and-inherit behavior."
(with-temp-buffer
(insert "ab")
(tp-set 1 2 '(face bold))
(goto-char 2)
(insert "x")
(should-not (get-text-property 2 'face)))
(with-temp-buffer
(insert "ab")
(tp-set 1 2 '(face bold))
(goto-char 2)
(insert-and-inherit "x")
(should (eq (get-text-property 2 'face) 'bold))))
(ert-deftest tp-native-test-copy-insert-and-yank-filtering ()
"Copy and yank primitives preserve/filter tp-applied properties natively."
(let* ((source (tp-set "abcd" 'face 'bold 'secret 7))
(copy (copy-sequence source))
(slice (substring source 1 3)))
(should (equal-including-properties source copy))
(should (eq (get-text-property 0 'face slice) 'bold))
(with-temp-buffer
(let ((yank-excluded-properties '(secret)))
(insert-for-yank source))
(should (eq (get-text-property 1 'face) 'bold))
(should-not (get-text-property 1 'secret))
(should (eq (get-text-property
0 'face (buffer-substring 1 3))
'bold))
(should-not (text-properties-at
0 (buffer-substring-no-properties 1 3))))))
(ert-deftest tp-native-test-narrowing-and-indirect-buffer-coordinates ()
"Public operations keep native positions across narrowing and indirection."
(let ((base (generate-new-buffer " *tp-native-base*"))
indirect)
(unwind-protect
(progn
(with-current-buffer base
(insert "abcdef")
(setq indirect
(make-indirect-buffer base " *tp-native-indirect*" t)))
(with-current-buffer indirect
(narrow-to-region 2 5)
(should (equal (tp-set 2 4 '(state shared)) '(2 . 4)))
(let ((result (tp-lookup 3 'state :mode :text-direct)))
(should (eq (tp-lookup-result-object result) indirect))
(should (= (tp-lookup-result-position result) 3))
(should (eq (tp-lookup-result-value result) 'shared))))
(with-current-buffer base
(should (eq (get-text-property 3 'state) 'shared))))
(when (buffer-live-p indirect) (kill-buffer indirect))
(when (buffer-live-p base) (kill-buffer base)))))
(ert-deftest tp-native-test-emacs-28-required-primitives-exist ()
"The selected native mapping stays within the Emacs 28.1 baseline."
(dolist (function '(object-intervals
text-property-search-forward
text-property-search-backward
make-prop-match
with-silent-modifications
overlays-at
get-char-property
get-char-property-and-overlay
text-property-any
text-property-not-all
previous-single-property-change
previous-property-change))
(should (fboundp function))))
(provide 'tp-native-tests)
;;; tp-native-tests.el ends here

View File

@ -1,372 +0,0 @@
;;; 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 CSS-independent native property policies, direct
;; declarations, and explicit computed values.
;;; Code:
(require 'ert)
(require 'tp-style)
(require 'tp-layer)
(ert-deftest tp-style-test-native-keymaps-preserve-all-binding-facts ()
"Snapshots compare by prompts, menu order, parents and literal commands."
(let* ((factory (eval '(lambda ()
(let ((n 0))
(lambda () (setq n (1+ n))))) t))
(first (funcall factory)) (second (funcall factory))
(map (make-keymap "Root"))
(prefix (make-sparse-keymap "Prefix"))
(parent (make-sparse-keymap "Parent")))
(define-key map (kbd "RET") first)
(define-key map [t] #'ignore)
(define-key prefix [self] prefix)
(define-key prefix [one] '(menu-item "One" ignore))
(define-key prefix [two] '(menu-item "Two" forward-char))
(define-key map [prefix] prefix)
(define-key parent [inherited] #'backward-char)
(set-keymap-parent map parent)
(should (equal first second))
(should (tp--native-property-value-equal-p map (tp-property-value-copy map)))
(dolist (kind '(root-prompt prefix-prompt parent-prompt menu-order
callback default inherited))
(let ((copy (tp-property-value-copy map)))
(pcase kind
((or 'root-prompt 'prefix-prompt 'parent-prompt)
(let* ((target (pcase kind
('root-prompt copy)
('prefix-prompt (lookup-key copy [prefix]))
('parent-prompt (keymap-parent copy))))
(cell (memq (keymap-prompt target) target)))
(setcar cell "Changed")))
('menu-order
(let* ((target (lookup-key copy [prefix]))
(one (lookup-key target [one])))
(define-key target [one] nil t)
(define-key target [one] one)))
('callback (define-key copy (kbd "RET") second))
('default (define-key copy [t] #'forward-char))
('inherited (define-key (keymap-parent copy) [inherited] #'ignore)))
(should-not (tp--native-property-value-equal-p map copy))))))
(defmacro tp-style-test--isolated (&rest body)
"Run BODY with isolated TP property and named-style registries."
(declare (indent 0) (debug t))
`(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-policy ()
"Register and return a direct demo color policy."
(tp-define-property-policy
'demo/color
:normalizer #'downcase
:validator #'stringp
:equality #'equal
:projector (lambda (value)
(list 'face (list :foreground value)))))
(ert-deftest tp-style-test-paint-slot-keeps-one-face-address ()
"Updating a paint slot changes its face without rewriting text properties."
(let* ((slot (tp-paint-slot-create '(:foreground "red")))
(face (tp-paint-slot-face slot))
(text (propertize "x" 'face face))
(buffer (generate-new-buffer " *tp-paint-slot-test*")))
(should (facep face))
(should (eq face (get-text-property 0 'face text)))
(tp-paint-slot-update slot '(:foreground "red"))
(should (equal "red" (face-attribute face :foreground nil nil)))
(tp-paint-slot-update slot '(:foreground "blue"))
(should (eq face (get-text-property 0 'face text)))
(should (equal "blue" (face-attribute face :foreground nil nil)))
(unwind-protect
(let ((journal
(tp-paint-slot-apply-updates
buffer (list (cons slot '(:foreground "green"))))))
(with-current-buffer buffer
(should
(equal '(:foreground "green")
(cadr (assq face face-remapping-alist)))))
(tp-paint-slot-rollback-updates journal)
(with-current-buffer buffer
(should-not (assq face face-remapping-alist)))
(should (equal "blue" (face-attribute face :foreground nil nil))))
(kill-buffer buffer))))
(ert-deftest tp-style-test-policy-registration-is-atomic ()
"Invalid replacement leaves the previous valid policy installed."
(tp-style-test--isolated
(let ((policy (tp-style-test--color-policy)))
(should (eq policy (tp-property-policy 'demo/color)))
(should-error
(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-policy 'color)
:type 'tp-invalid-property-policy))))
(ert-deftest tp-style-test-policy-rejects-css-schema-options ()
"TP property policies reject CSS inheritance and shorthand fields."
(tp-style-test--isolated
(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-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 ()
"Tagged computation runs once and never invokes its returned function."
(tp-style-test--isolated
(let ((compute-calls 0)
(result-calls 0)
result-function)
(setq result-function (lambda () (cl-incf result-calls)))
(tp-define-property-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 projected 'help-echo) result-function))
(should (= compute-calls 1))
(should (= result-calls 0))))))
(ert-deftest tp-style-test-computed-p-distinguishes-literal-functions ()
"Only explicit computed wrappers satisfy the public predicate."
(let ((function (lambda () "value")))
(should-not (tp-computed-p function))
(should (tp-computed-p (tp-computed function)))))
(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
(equal (tp-resolve-value
(tp-computed (lambda () (cl-incf calls) '(computed value))))
'(computed value)))
(should (= calls 1))))
(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 ((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--project-declarations '(demo/color 42))
:type 'tp-invalid-declaration))))
(ert-deftest tp-style-test-validator-rejection-is-explicit ()
"A false validator result raises a direct declaration error."
(tp-style-test--isolated
(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-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"))
(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-native-face-policy-merges-contributions ()
"The native face policy retains TP's established face merge semantics."
(tp-style-test--isolated
(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-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"))
(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-layer-has-no-frozen-style ()
"A parameterized redefinition removes its former static style."
(tp-style-test--isolated
(unwind-protect
(progn
(define-tp tp-style-test-layer () '(face bold))
(should (tp-style-declarations 'tp-style-test-layer))
(define-tp tp-style-test-layer (weight)
`(face (:weight ,weight)))
(should-not (tp-style-declarations 'tp-style-test-layer)))
(tp-undefine-layer 'tp-style-test-layer))))
(ert-deftest tp-style-test-static-group-element-compiles-style ()
"A generated static group layer becomes a named direct style."
(tp-style-test--isolated
(unwind-protect
(progn
(define-tps tp-style-test-group ()
'("label" . (face italic mouse-face highlight)))
(should
(equal (tp-style-declarations 'tp-style-test-group-label)
'(text/face italic text/mouse-face highlight))))
(tp-undefine-group 'tp-style-test-group))))
(ert-deftest tp-style-test-named-styles-are-defensive ()
"Named styles own declarations and return defensive copies."
(tp-style-test--isolated
(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

File diff suppressed because it is too large Load Diff

View File

@ -1,138 +0,0 @@
;;; tp-tests.el --- Public TP facade tests -*- lexical-binding: t; -*-
;; Copyright (C) 2024-2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Focused end-to-end tests for the stateless public property facade. Retained
;; and reactive behavior is covered by tp-surface-tests and tp-binding-tests.
;;; Code:
(require 'ert)
(require 'tp)
(defmacro tp-test-with-temp-buffer (&rest body)
"Run BODY in a temporary buffer with isolated declaration recipes."
(declare (indent 0) (debug t))
`(unwind-protect
(with-temp-buffer
(tp-layer-reset)
,@body)
(tp-layer-reset)))
(ert-deftest tp-test-set-get-and-member-preserve-presence ()
"Set/get APIs preserve explicit nil separately from absence."
(tp-test-with-temp-buffer
(insert "hello")
(should (equal (tp-set 1 6 '(face bold help-echo nil)) '(1 . 6)))
(should (eq (tp-at 2 'face) 'bold))
(should (equal (tp-member 2 'help-echo) '(help-echo nil)))
(should-not (tp-member 2 'mouse-face))
(should (equal (tp-get 1 6 'help-echo) '((1 6 nil))))))
(ert-deftest tp-test-set-string-whole-object-is-nondestructive ()
"Whole-string mutation returns a copy and leaves its input untouched."
(let* ((source (copy-sequence "hello"))
(result (tp-set source 'face 'bold 'help-echo "tip")))
(should-not (eq source result))
(should-not (text-properties-at 0 source))
(should (eq (get-text-property 0 'face result) 'bold))
(should (equal (get-text-property 0 'help-echo result) "tip"))))
(ert-deftest tp-test-set-string-range-mutates-in-place ()
"Explicit string ranges retain the historical in-place contract."
(let ((text (copy-sequence "hello")))
(should (eq (tp-set 1 4 '(face italic) text) text))
(should-not (get-text-property 0 'face text))
(should (eq (get-text-property 1 'face text) 'italic))
(should-not (get-text-property 4 'face text))))
(ert-deftest tp-test-reset-replaces-only-the-requested-range ()
"Reset removes prior properties inside its range and nowhere else."
(tp-test-with-temp-buffer
(insert "abcdef")
(put-text-property 1 7 'help-echo "host")
(tp-reset 2 5 '(face bold))
(should (equal (get-text-property 1 'help-echo) "host"))
(should-not (get-text-property 2 'help-echo))
(should (eq (get-text-property 2 'face) 'bold))
(should (equal (get-text-property 5 'help-echo) "host"))))
(ert-deftest tp-test-add-composes-face-and-nested-plists ()
"Add uses the shared native property merge policy."
(let* ((source (propertize "x" 'face 'bold
'display '(:width 1 :height 2)))
(result (tp-add source
'face 'italic
'display '(:width 3))))
(should (equal (get-text-property 0 'face result) '(italic bold)))
(should
(equal (get-text-property 0 'display result)
'(:width 3 :height 2)))))
(ert-deftest tp-test-remove-top-level-and-nested-properties ()
"Remove handles top-level, sub-property, and nested paths."
(let* ((source (propertize
"x" 'face '(:foreground "red"
:underline (:style wave :color "blue"))
'help-echo "tip"))
(no-help (tp-remove source 'help-echo))
(no-underline-style
(tp-remove source 'face :underline '(:style))))
(should-not (get-text-property 0 'help-echo no-help))
(should
(equal (get-text-property 0 'face no-underline-style)
'(:foreground "red" :underline (:color "blue"))))))
(ert-deftest tp-test-clear-defaults-to-target-bounds ()
"Clear removes every property while preserving text."
(let ((text (propertize "hello" 'face 'bold)))
(tp-clear nil nil text)
(should (equal text "hello"))
(should-not (text-properties-at 0 text))))
(ert-deftest tp-test-native-recipe-application-is-one-shot ()
"Applying a named recipe creates no object, binding, anchor, or mount."
(tp-test-with-temp-buffer
(define-tp tp-test-warning (color)
`(face (:foreground ,color) help-echo "warning"))
(insert "warning")
(let ((before (tp-reactive-counters)))
(tp-set 1 8 '(tp-test-warning "orange"))
(should (equal (get-text-property 1 'face)
'(:foreground "orange")))
(should (equal (tp-reactive-counters) before)))))
(ert-deftest tp-test-match-and-regexp-use-the-same-direct-core ()
"Literal and regexp application share recipe projection semantics."
(tp-test-with-temp-buffer
(define-tp tp-test-hit () '(face bold))
(insert "one two one")
(should (equal (tp-match-set "one" 'tp-test-hit)
'((1 . 4) (9 . 12))))
(should (equal (tp-regexp-add "t.o" '(help-echo "two"))
'((5 . 8))))
(should (eq (get-text-property 1 'face) 'bold))
(should (equal (get-text-property 5 'help-echo) "two"))))
(ert-deftest tp-test-property-navigation-keeps-string-buffer-parity ()
"Forward and backward search report equivalent string/buffer matches."
(let ((text (tp-set "abcd" 'face 'bold)))
(with-temp-buffer
(insert text)
(goto-char (point-min))
(let ((buffer-match (tp-forward 'face 'bold)))
(should (= (prop-match-beginning buffer-match) 1))
(should (= (prop-match-end buffer-match) 5))
(should (eq (prop-match-value buffer-match) 'bold)))
(should (equal (tp-forward 'face 'bold text) '((0 4 bold))))
(goto-char (point-max))
(let ((buffer-match (tp-backward 'face 'bold)))
(should (= (prop-match-beginning buffer-match) 1))
(should (= (prop-match-end buffer-match) 5))
(should (eq (prop-match-value buffer-match) 'bold))))))
(provide 'tp-tests)
;;; tp-tests.el ends here

File diff suppressed because it is too large Load Diff

View File

@ -1,325 +0,0 @@
;;; tp-benchmark.el --- Batch benchmarks for tp -*- lexical-binding: t -*-
;; Copyright (C) 2024-2026 Geekinney
;; Author: Geekinney (kinneyzhang666@gmail.com)
;;; Commentary:
;; Run with:
;; Emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run
;;; Code:
(require 'cl-lib)
(require 'tp)
(defconst tp-benchmark--fixed-seeds '(1 7 42 747555)
"Fixed deterministic benchmark seeds.")
(defconst tp-benchmark--generated-seed 8675309
"Printed generated seed. Fixed so the benchmark output is reproducible.")
(defun tp-benchmark--print (plist)
"Print one benchmark row from PLIST."
(princ
(concat
(mapconcat
(lambda (key)
(format "%s=%S" (substring (symbol-name key) 1)
(plist-get plist key)))
'(:scenario :status :fixture :seed :requested :actual :operations
:objects :subscribers :invalidated :recomputed :skipped
:text-operations :property-operations :touched :revision :published
:elapsed :gcs :note)
" ")
"\n")))
(defun tp-benchmark--random-string (size seed)
"Return deterministic random string of SIZE using SEED."
(let ((state seed)
(chars "abcdefghijklmnopqrstuvwxyz")
(result (make-string size ?a))
(pos 0))
(while (< pos size)
(setq state (mod (+ (* state 1103515245) 12345) 2147483648))
(aset result pos (aref chars (mod state (length chars))))
(setq pos (1+ pos)))
result))
(defun tp-benchmark--measure (scenario fixture seed requested actual body)
"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))
(result (funcall body))
(elapsed (- (float-time) start)))
(tp-benchmark--print
(append
(list :scenario scenario :status 'ok :fixture fixture :seed seed
:requested requested :actual actual)
result
(list :elapsed elapsed :gcs (- gcs-done gc-start) :note nil)))))
(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"))
(set-text-properties 0 size nil text)
(tp-benchmark--measure
'large-text 'string seed size size
(lambda ()
(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 :touched size :note (length matches)))))))
(defun tp-benchmark--fragmented (runs 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"))
(tp-benchmark--measure
'fragmented 'string seed runs runs
(lambda ()
(let ((matches (tp-search text 'tp-bench)))
(list :operations 1 :touched runs :note (length matches)))))))
(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--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
(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
'retained-keyed-reconcile 'buffer seed count count
(lambda ()
(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--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 ()
(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."
(interactive)
(princ (format "tp-benchmark emacs=%S generated-seed=%d fixed-seeds=%S\n"
emacs-version tp-benchmark--generated-seed
tp-benchmark--fixed-seeds))
(dolist (seed (append tp-benchmark--fixed-seeds
(list tp-benchmark--generated-seed)))
(dolist (size '(100000 1000000))
(tp-benchmark--large-text size seed))
(dolist (runs '(1000 10000 50000))
(tp-benchmark--fragmented runs 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

View File

@ -6,7 +6,7 @@
;; macros, and the palette module (tp-builtins.el / tp-palette.el). ;; macros, and the palette module (tp-builtins.el / tp-palette.el).
;; ;;
;; Run with: ;; Run with:
;; emacs --batch -L . -L tests -l tp.el -l tp-builtins-tests.el \ ;; emacs --batch -L . -l tp.el -l tp-builtins-tests.el \
;; -f ert-run-tests-batch-and-exit ;; -f ert-run-tests-batch-and-exit
;;; Code: ;;; Code:
@ -252,14 +252,6 @@ tp-builtins restores the shipped layer definitions."
(tp-builtins-test--with-background-mode 'dark (tp-builtins-test--with-background-mode 'dark
(should (equal (tp-palette-color 'info :fg) "#58a6ff")))) (should (equal (tp-palette-color 'info :fg) "#58a6ff"))))
(ert-deftest tp-builtins-test-palette-color-resolves-explicit-mode ()
"Resolve a palette for an application mode without reading the frame."
(should (equal "#0969da"
(tp-palette-color-for-mode 'info :fg 'light)))
(should (equal "#58a6ff"
(tp-palette-color-for-mode 'info :fg 'dark)))
(should-error (tp-palette-color-for-mode 'info :fg 'sepia)))
(ert-deftest tp-builtins-test-palette-has-p () (ert-deftest tp-builtins-test-palette-has-p ()
"tp-palette-has-p tests palette registration and per-key presence." "tp-palette-has-p tests palette registration and per-key presence."
(should (tp-palette-has-p 'info)) (should (tp-palette-has-p 'info))

137
tp-core-tests.el Normal file
View File

@ -0,0 +1,137 @@
;;; tp-core-tests.el --- ERT tests for tp-core.el -*- lexical-binding: t -*-
;;; Commentary:
;; Unit tests for the tp-core foundation module.
;;; Code:
(require 'ert)
(require 'tp-core)
;;; tp--map-intervals
(ert-deftest tp-core-test-map-intervals-string-clips ()
"Intervals extending beyond the range are clipped to it."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 11 'face 'bold str)
(should (equal (tp--map-intervals str 3 7 #'list)
'((3 7 (face bold)))))))
(ert-deftest tp-core-test-map-intervals-string-full ()
"Full-range walk over a string returns each property run."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 5 'face 'bold str)
(should (equal (tp--map-intervals str nil nil #'list)
'((0 5 (face bold)) (5 11 nil))))))
(ert-deftest tp-core-test-map-intervals-single-property ()
"PROPERTY narrows runs to that property and passes its value."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 5 'face 'bold str)
(put-text-property 2 8 'help-echo "tip" str)
(should (equal (tp--map-intervals str nil nil #'list 'face)
'((0 5 bold) (5 11 nil))))))
(ert-deftest tp-core-test-map-intervals-buffer-clips ()
"Buffer walk clips to the requested range with 1-based positions."
(with-temp-buffer
(insert "hello world")
(put-text-property 1 12 'face 'bold)
(should (equal (tp--map-intervals nil 4 8 #'list)
'((4 8 (face bold)))))))
(ert-deftest tp-core-test-map-intervals-buffer-multiple-runs ()
"Multiple runs in a buffer are visited in order, gaps included."
(with-temp-buffer
(insert "hello world")
(put-text-property 1 6 'face 'bold)
(put-text-property 7 12 'face 'italic)
(should (equal (tp--map-intervals nil nil nil #'list 'face)
'((1 6 bold) (6 7 nil) (7 12 italic))))))
(ert-deftest tp-core-test-map-intervals-out-of-range-normalized ()
"Out-of-bounds START/END are clamped, not signaled."
(let ((str (copy-sequence "abc")))
(put-text-property 0 3 'p 1 str)
(should (equal (tp--map-intervals str -5 99 #'list 'p)
'((0 3 1))))))
(ert-deftest tp-core-test-map-intervals-empty-range ()
"An empty range visits nothing."
(let ((str (copy-sequence "abc")))
(should (equal (tp--map-intervals str 1 1 #'list) nil))))
;;; tp-face-properties
(ert-deftest tp-core-test-face-properties ()
"The face-family property list contains the three face properties."
(should (equal tp-face-properties '(face font-lock-face mouse-face))))
;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map
(ert-deftest tp-core-test-intervals-buffer-relative-default ()
"Without ABSOLUTE, buffer intervals stay START-relative (legacy)."
(with-temp-buffer
(insert "hello world")
(put-text-property 4 8 'face 'bold)
(should (equal (tp-intervals 3 9)
'((0 1 nil) (1 5 (face bold)) (5 6 nil))))))
(ert-deftest tp-core-test-intervals-buffer-absolute ()
"With ABSOLUTE, buffer intervals use native 1-based positions."
(with-temp-buffer
(insert "hello world")
(put-text-property 4 8 'face 'bold)
(should (equal (tp-intervals 3 9 nil t)
'((3 4 nil) (4 8 (face bold)) (8 9 nil))))
;; Clipping still applies in native coordinates.
(should (equal (tp-intervals 5 7 nil t)
'((5 7 (face bold)))))))
(ert-deftest tp-core-test-intervals-string-ignores-absolute ()
"String intervals are already absolute; ABSOLUTE changes nothing."
(let ((s (copy-sequence "hello world")))
(put-text-property 3 7 'face 'bold s)
(should (equal (tp-intervals 2 9 s) (tp-intervals 2 9 s t)))
(should (equal (tp-intervals 2 9 s t)
'((2 3 nil) (3 7 (face bold)) (7 9 nil))))))
(ert-deftest tp-core-test-intervals-map-absolute ()
"tp-intervals-map passes ABSOLUTE through to native positions."
(with-temp-buffer
(insert "hello world")
(put-text-property 4 8 'face 'bold)
(should (equal (tp-intervals-map #'list 3 9)
'((0 1 nil nil) (1 5 (face bold) nil) (5 6 nil nil))))
(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."
(with-temp-buffer
(insert "hello")
(set-text-properties
1 6 '(face bold tp-layers ((face italic tp-name below))))
(let ((res (tp-intervals-map #'list 1 6 nil t)))
(should (= (length res) 1))
(pcase-let ((`(,beg ,end ,top ,below) (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))))))))
(ert-deftest tp-core-test-intervals-map-drops-nil-results ()
"nil results from FUNCTION are removed from the returned list."
(with-temp-buffer
(insert "hello world")
(put-text-property 4 8 'face 'bold)
(should (equal (tp-intervals-map
(lambda (beg end top _below)
(when (plist-get top 'face) (cons beg end)))
1 12 nil t)
'((4 . 8))))))
(provide 'tp-core-tests)
;;; tp-core-tests.el ends here

View File

@ -21,16 +21,14 @@
;;; Code: ;;; Code:
(require 'cl-lib) (require 'cl-lib)
(require 'dash)
(require 'seq) (require 'seq)
(require 'text-property-search)
(defgroup tp nil (defgroup tp nil
"Group for tp.el text property manipulation." "Group for tp.el text property manipulation."
:prefix "tp-" :prefix "tp-"
:group 'development) :group 'development)
(define-error 'tp-unsupported-buffer "Unsupported TP buffer")
(defcustom tp-debug-mode nil (defcustom tp-debug-mode nil
"When non-nil, enable debug logging for reactive updates. "When non-nil, enable debug logging for reactive updates.
Debug messages are logged to the *tp-debug* buffer and optionally Debug messages are logged to the *tp-debug* buffer and optionally
@ -99,7 +97,7 @@ FORMAT-STRING and ARGS are passed to `format'."
(defun tp-debug-clear () (defun tp-debug-clear ()
"Clear the *tp-debug* buffer." "Clear the *tp-debug* buffer."
(interactive) (interactive)
(when-let* ((buf (get-buffer "*tp-debug*"))) (when-let ((buf (get-buffer "*tp-debug*")))
(with-current-buffer buf (with-current-buffer buf
(erase-buffer)))) (erase-buffer))))
@ -116,103 +114,6 @@ FORMAT-STRING and ARGS are passed to `format'."
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
,@body))) ,@body)))
(cl-defstruct (tp--native-range
(:constructor tp--make-native-range
(object kind start end)))
object kind start end)
(cl-defstruct (tp--presence
(:constructor tp--make-presence (present-p value)))
present-p value)
(cl-defstruct (tp--request
(:constructor tp--make-request
(&key operation range props property value
predicate mutation read-only noerror
public-return)))
operation range props property value predicate mutation read-only
noerror public-return)
(cl-defstruct (tp--match
(:constructor tp--make-match (range property value)))
range property value)
(cl-defstruct (tp--result
(:constructor tp--make-result
(&key request value matches count object native)))
request value matches count object native)
(defun tp--object-kind (object)
"Return the canonical kind for OBJECT."
(if (stringp object) :string :buffer))
(defun tp--object-bounds (object)
"Return native bounds for OBJECT."
(if (stringp object)
(cons 0 (length object))
(with-current-buffer (or object (current-buffer))
(cons (point-min) (point-max)))))
(defun tp--native-range-from-object (object start end)
"Return a concrete native range for OBJECT from START to END."
(let* ((obj (or object (current-buffer)))
(bounds (tp--object-bounds obj)))
(tp--make-native-range
obj (tp--object-kind obj)
(max (or start (car bounds)) (car bounds))
(min (or end (cdr bounds)) (cdr bounds)))))
(defun tp--buffer-position-p (position buffer)
"Return non-nil when POSITION belongs to BUFFER or is an integer."
(or (integerp position)
(and (markerp position)
(eq (marker-buffer position) buffer)
(marker-position position))))
(defun tp--validate-buffer-range (buffer start end)
"Validate START and END as an ordered live range in BUFFER."
(unless (buffer-live-p buffer)
(signal 'tp-unsupported-buffer (list buffer)))
(with-current-buffer buffer
(save-restriction
(widen)
(unless (and (tp--buffer-position-p start buffer)
(tp--buffer-position-p end buffer)
(<= (point-min) start) (<= start end) (<= end (point-max)))
(signal 'args-out-of-range (list buffer start end))))))
(defun tp--presence-at (pos property &optional object)
"Return canonical presence of PROPERTY at POS in OBJECT."
(let ((cell (plist-member (text-properties-at pos object) property)))
(tp--make-presence (and cell t) (cadr cell))))
(defun tp--match-to-list (match)
"Convert MATCH to the historical (START END VALUE) list."
(let ((range (tp--match-range match)))
(list (tp--native-range-start range)
(tp--native-range-end range)
(tp--match-value match))))
(defun tp--match-to-prop-match (match)
"Convert MATCH to an Emacs `prop-match' object."
(let ((range (tp--match-range match)))
(make-prop-match :beginning (tp--native-range-start range)
:end (tp--native-range-end range)
:value (tp--match-value match))))
(defun tp--result-public-value (result)
"Return RESULT using its request's public return convention."
(pcase (tp--request-public-return (tp--result-request result))
(:range
(let ((range (tp--request-range (tp--result-request result))))
(cons (tp--native-range-start range)
(tp--native-range-end range))))
(:matches (mapcar #'tp--match-to-list (tp--result-matches result)))
(:count (tp--result-count result))
(:object (tp--result-object result))
(:native (tp--result-native result))
(_ (tp--result-value result))))
(defun tp-intervals (start end &optional object absolute) (defun tp-intervals (start end &optional object absolute)
"Return list of property intervals from START to END in OBJECT. "Return list of property intervals from START to END in OBJECT.
Each element is (START END PROPERTIES). OBJECT defaults to current Each element is (START END PROPERTIES). OBJECT defaults to current
@ -252,10 +153,8 @@ OBJECT can be string or buffer; nil means current buffer."
(null (object-intervals (or object (current-buffer))))) (null (object-intervals (or object (current-buffer)))))
(defun tp-plist (start-or-string &optional end object) (defun tp-plist (start-or-string &optional end object)
"Return merged plist of all properties from START-OR-STRING to END in OBJECT. "Return merged plist of all properties from START to END in OBJECT.
With single STRING argument, return properties of entire string."
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) (let (start-pos end-pos obj)
(if (stringp start-or-string) (if (stringp start-or-string)
(setq start-pos 0 (setq start-pos 0
@ -271,197 +170,6 @@ Otherwise, START-OR-STRING and END define the range."
do (setq result (plist-put result key val))))) do (setq result (plist-put result key val)))))
result))) result)))
(defconst tp--copy-cache-missing (make-symbol "tp-copy-cache-missing")
"Sentinel for a missing defensive-copy memo entry.")
(defun tp--copy-mutable-property-value-p (value)
"Return non-nil when VALUE is a recursively copied property container."
(and (not (functionp value))
(or (consp value)
(stringp value)
(char-table-p value)
(and (vectorp value) (not (recordp value))))))
(defun tp--copy-cons-spine (value cache)
"Return a single-pass memoized copy of cons spine VALUE using CACHE.
Each cons cell is allocated and entered into CACHE before its car is copied,
so dotted tails, shared suffixes, and cycles retain their source topology."
(let ((source value)
head
tail
reused-p)
(while (consp source)
(let ((cached (gethash source cache tp--copy-cache-missing)))
(if (not (eq cached tp--copy-cache-missing))
(progn
(if tail
(setcdr tail cached)
(setq head cached))
(setq reused-p t
source nil))
(let ((copy (cons nil nil)))
(puthash source copy cache)
(if tail
(setcdr tail copy)
(setq head copy))
(let ((item (car source)))
(setcar
copy
(if (and (not (functionp item))
(or (consp item)
(stringp item)
(char-table-p item)
(and (vectorp item) (not (recordp item)))))
(tp--copy-property-value item cache)
item)))
(setq tail copy
source (cdr source))))))
(when (and tail (not reused-p))
(setcdr tail
(if (null source)
nil
(tp--copy-property-value source cache))))
head))
(defun tp--copy-proper-cons-list (value cache)
"Return a fast memoized copy of uncached proper-list VALUE.
CACHE preserves sharing and cycles across the copied value graph.
The whole spine is registered before mutable cars are copied, preserving
back-references from cars while `copy-sequence' supplies the spine cheaply."
(let ((source value)
(cache-free-p t))
(while (and cache-free-p (consp source))
(when (not (eq (gethash source cache tp--copy-cache-missing)
tp--copy-cache-missing))
(setq cache-free-p nil))
(setq source (cdr source)))
(if (not cache-free-p)
(tp--copy-cons-spine value cache)
(let* ((copy (copy-sequence value))
(source value)
(target copy))
(while (consp source)
(puthash source target cache)
(let ((item (car source)))
(when (and (not (functionp item))
(or (consp item)
(stringp item)
(char-table-p item)
(and (vectorp item) (not (recordp item)))))
(setcar target (tp--copy-property-value item cache))))
(setq source (cdr source)
target (cdr target)))
copy))))
(defun tp--copy-string-with-properties
(value &optional cache reuse-property-p)
"Return a copy of string VALUE with recursively copied property values.
CACHE preserves sharing across mutable property values.
REUSE-PROPERTY-P, when non-nil, is called with PROPERTY and VALUE. A non-nil
result transfers that exact candidate-owned VALUE into the returned string;
the caller must ensure that VALUE is not mutated by another owner. Values not
transferred keep strict source-identity memoization and recursive copying."
(let* ((cache (or cache (make-hash-table :test #'eq)))
(cached (gethash value cache tp--copy-cache-missing)))
(if (not (eq cached tp--copy-cache-missing))
cached
(let ((copy (copy-sequence value))
(position 0)
(length (length value)))
(puthash value copy cache)
(while (< position length)
(let ((next (or (next-property-change position value) length))
(properties (text-properties-at position value))
updates)
(while properties
(let* ((property (pop properties))
(original (pop properties))
(mutable-p
(tp--copy-mutable-property-value-p original))
(reuse-p
(and mutable-p reuse-property-p
(funcall reuse-property-p property original)))
(copied
(if reuse-p
original
(if mutable-p
(tp--copy-property-value original cache)
original))))
(unless (eq copied original)
(push property updates)
(push copied updates))))
(when updates
(add-text-properties position next (nreverse updates) copy))
(setq position next)))
copy))))
(defun tp-text-snapshot (text &optional reuse-property-p)
"Return a defensive copy of TEXT and its mutable text-property values.
REUSE-PROPERTY-P, when non-nil, is called with PROPERTY and VALUE. A non-nil
result transfers that exact candidate-owned VALUE into the snapshot; the
caller must ensure that VALUE is not mutated by another owner. Without the
predicate, repeated source identities share defensive copies and all mutable
values are recursively isolated."
(unless (stringp text)
(signal 'wrong-type-argument (list 'stringp text)))
(tp--copy-string-with-properties text nil reuse-property-p))
(defun tp--copy-property-value (value &optional cache)
"Return a defensive copy of mutable containers in property VALUE.
Optional CACHE preserves sharing and cycles across recursive copies.
Cons cells, strings, vectors and character tables are copied recursively.
Functions, records,
and other opaque objects keep their identity; functions are never executed."
(if (not (tp--copy-mutable-property-value-p value))
value
(let* ((cache (or cache (make-hash-table :test #'eq)))
(cached (gethash value cache tp--copy-cache-missing)))
(if (not (eq cached tp--copy-cache-missing))
cached
(cond
((consp value)
(if (proper-list-p value)
(tp--copy-proper-cons-list value cache)
(tp--copy-cons-spine value cache)))
((stringp value) (tp--copy-string-with-properties value cache))
((char-table-p value)
(let ((copy (copy-sequence value))
(default (char-table-range value nil))
entries)
(puthash value copy cache)
;; Enumerate only local assignments, without inherited/default
;; ranges becoming explicit assignments in the copied table.
(set-char-table-parent copy nil)
(set-char-table-range copy nil nil)
(map-char-table (lambda (range item) (push (cons range item) entries))
copy)
(dolist (entry entries)
(set-char-table-range
copy (car entry) (tp--copy-property-value (cdr entry) cache)))
(set-char-table-range copy nil (tp--copy-property-value default cache))
(set-char-table-parent
copy (tp--copy-property-value (char-table-parent value) cache))
(dotimes (index (or (get (char-table-subtype value)
'char-table-extra-slots) 0))
(set-char-table-extra-slot
copy index (tp--copy-property-value
(char-table-extra-slot value index) cache)))
copy))
((vectorp value)
(let ((copy (copy-sequence value)))
(puthash value copy cache)
(dotimes (index (length copy))
(aset copy index
(tp--copy-property-value (aref copy index) cache)))
copy)))))))
(defun tp-property-value-copy (value)
"Return a defensive copy of mutable text-property VALUE.
Functions, records, and other opaque identities are retained; mutable cons,
string, character-table and non-record vector graphs are copied with sharing
and cycles intact."
(tp--copy-property-value value (make-hash-table :test #'eq)))
(defun tp--deep-merge-plist (base new) (defun tp--deep-merge-plist (base new)
"Deep merge NEW plist into BASE plist. "Deep merge NEW plist into BASE plist.
For nested plists (starting with keyword), recursively merge. For nested plists (starting with keyword), recursively merge.
@ -615,6 +323,34 @@ Returns the modified face value with the layer's face contribution removed."
;; Unknown - return as-is ;; Unknown - return as-is
(t face-value))) (t face-value)))
(defun tp--merge-string-props-into-plist (str props)
"Merge text properties from string STR into PROPS plist.
Properties from PROPS take precedence over those in STR.
Returns the merged plist where new props override embedded props.
For simplicity, only considers properties at position 0 of STR."
(if (not (tp--string-has-properties-p str))
props
(let ((str-props (text-properties-at 0 str))
(result (copy-sequence props)))
;; Merge each property from the string into result
;; Props values take precedence over embedded string values
(cl-loop for (key val) on str-props by #'cddr
do (let ((existing (plist-get result key)))
(if existing
;; Props already has this key - merge with props taking precedence
(setq result
(plist-put result key
(cond
;; Face properties need special merging
;; Pass embedded val as face1 (base), existing as face2 (override)
((memq key tp-face-properties)
(tp--merge-face-values val existing))
;; Other properties - props value takes precedence
(t existing))))
;; Props doesn't have this key - add from string
(setq result (plist-put result key val)))))
result)))
(defun tp--merge-face-values (face1 face2) (defun tp--merge-face-values (face1 face2)
"Merge two face values into one. "Merge two face values into one.
FACE1 is the earlier value, FACE2 is the later value. FACE1 is the earlier value, FACE2 is the later value.
@ -625,9 +361,8 @@ Returns the merged face value.
Role: this is the merge engine for face values that arrive together in Role: this is the merge engine for face values that arrive together in
a SINGLE call's property spec - `tp--merge-duplicate-keys' reduces a SINGLE call's property spec - `tp--merge-duplicate-keys' reduces
repeated face/font-lock-face/mouse-face keys through it, and repeated face/font-lock-face/mouse-face keys through it, and
`tp--merge-embedded-props' uses it for each property run of a `tp--merge-string-props-into-plist' uses it to fold a string's embedded
propertized replacement string. Argument order is (EARLIER LATER); face into caller props. Argument order is (EARLIER LATER); LATER wins.
LATER wins.
Note: `tp--prepend-face' is a sibling engine used by `tp-add' to merge Note: `tp--prepend-face' is a sibling engine used by `tp-add' to merge
an INCOMING face value into one already present on the text. Its an INCOMING face value into one already present on the text. Its
@ -801,6 +536,81 @@ Supports plists, alists, and list-of-keys extraction."
(t nil)))) (t nil))))
(tp--get-nested next-value rest)))) (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) (defun tp--prepend-face (new-face existing-face)
"Prepend NEW-FACE to EXISTING-FACE for the face property. "Prepend NEW-FACE to EXISTING-FACE for the face property.
Returns a face value where NEW-FACE takes precedence. Returns a face value where NEW-FACE takes precedence.
@ -956,10 +766,16 @@ order."
(defun tp-intervals-map (function start end &optional object absolute) (defun tp-intervals-map (function start end &optional object absolute)
"Apply FUNCTION to each property interval of [START, END) in OBJECT. "Apply FUNCTION to each property interval of [START, END) in OBJECT.
FUNCTION is called with (I-START I-END PROPERTIES RESERVED) for every FUNCTION is called with (I-START I-END TOP-PROPS BELOW-PROPS-LST) for
interval `tp-intervals' reports. PROPERTIES is the direct property plist and every interval `tp-intervals' reports, splitting the layer-stack
RESERVED is nil. The fourth argument is retained so existing stateless callers bookkeeping out of the raw properties:
do not need an arity change; TP no longer stores an inline layer stack. - 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.
I-START/I-END follow `tp-intervals' coordinates: for buffers they I-START/I-END follow `tp-intervals' coordinates: for buffers they
are by default relative to START (0-based offsets, the legacy are by default relative to START (0-based offsets, the legacy
@ -973,7 +789,17 @@ Returns the list of FUNCTION's non-nil results, in interval order
nil nil
(mapcar (mapcar
(lambda (tp) (lambda (tp)
(funcall function (nth 0 tp) (nth 1 tp) (nth 2 tp) nil)) (let* ((interval-start (nth 0 tp)) ;; start from 0
(interval-end (nth 1 tp))
(interval-props (nth 2 tp))
(top-props
(if-let ((idx (-elem-index 'tp-layers interval-props)))
(-remove-at-indices (list idx (1+ idx)) interval-props)
interval-props))
(below-props-lst (plist-get interval-props 'tp-layers)))
(funcall function
interval-start interval-end
top-props below-props-lst)))
(tp-intervals start end object absolute)))) (tp-intervals start end object absolute))))
(provide 'tp-core) (provide 'tp-core)

881
tp-doctest.el Normal file
View File

@ -0,0 +1,881 @@
;;; tp-doctest.el --- executable README examples -*- 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:
;; Executable documentation tests: each assertion reproduces an example
;; from README.md / README_CN.md (the code blocks are identical across
;; the two files) and compares the result against the exact output the
;; docs claim. Run with `make doctest'; the batch process exits
;; non-zero if any assertion fails. When changing a README example,
;; update the matching assertion here in the same commit.
;;; Code:
(require 'tp)
(tp-layer-reset)
(defvar tp-doctest--fails 0)
(defvar tp-doctest--total 0)
(defmacro chk (label expected &rest body)
`(let* ((exp ,expected)
(got (condition-case err (progn ,@body) (error (list :ERROR err)))))
(setq tp-doctest--total (1+ tp-doctest--total))
(if (equal got exp)
(princ (format "PASS %s\n" ,label))
(setq tp-doctest--fails (1+ tp-doctest--fails))
(princ (format "FAIL %s\n expected: %S\n got: %S\n"
,label exp got)))))
(defmacro chk-str (label expected &rest body)
"Compare prin1 form (covers propertized strings)."
`(chk ,label ,expected (prin1-to-string (progn ,@body))))
;; ---- Quick Start ----
(chk-str "QS-set" "#(\"hello\" 0 5 (face bold))" (tp-set "hello" 'face 'bold))
(chk "QS-layer" 'spotlight
(progn
(define-tp spotlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 6 'spotlight)
(tp-layer-top 1 6))))
(defvar accent-color "red")
(chk "QS-reactive" '(:foreground "blue")
(progn
(define-tp accent ()
:props '(face (:foreground $accent-color)))
(with-temp-buffer
(insert "Hello")
(tp-push-layer 1 6 'accent)
(setq accent-color "blue")
(tp-at 1 'face))))
;; ---- Features ----
(chk "F-getstyle" '((0 5 wave))
(let ((str (copy-sequence "Hello World")))
(tp-set 0 5 '(face (:underline (:color "green" :style wave))) str)
(tp-get str 'face :underline :style)))
(chk "F-getmulti" '((0 5 (:color "green" :style wave)))
(let ((str (copy-sequence "Hello World")))
(tp-set 0 5 '(face (:underline (:color "green" :style wave))) str)
(tp-get str 'face :underline '(:color :style))))
(chk "F-dupface" '((:foreground "red") (:background "green") bold)
(tp-at 0 'face (tp-set "emacs"
'face 'bold
'face '(:background "green")
'face '(:foreground "red"))))
(chk "F-override" '(:foreground "yellow")
(tp-at 0 'face (tp-set "emacs"
'face '(:foreground "red")
'face '(:foreground "yellow"))))
(chk "F-search" '((0 5 t) (12 17 t))
(let ((my-string (copy-sequence "Hello World Hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-search my-string 'marker)))
(chk "F-searchmap" "HELLO world HELLO"
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-search-map #'upcase 'marker nil my-string)
(substring-no-properties my-string)))
(chk "F-teaser-fullname" '(help-echo "John Doe" face (:foreground "purple") tp-name full-name-layer)
(progn
(define-tp full-name-layer ()
:props '(help-echo $full-name face (:foreground $name-color))
:data '((first-name . "John") (last-name . "Doe") (name-color . "purple"))
:compute '((full-name (lambda () (concat first-name " " last-name))))
:watch '((first-name (lambda (new old layer)
(message "Name changed from %s to %s" old new)))))
(tp-layer-props 'full-name-layer)))
;; ---- tp-set my-style ----
;; Compared per property: the ORDER properties print in varies across
;; Emacs versions (28 vs 29+), the values do not.
(chk "S-mystyle" '((:foreground "blue") my-style)
(progn
(define-tp my-style ()
:props '(face (:foreground $my-color))
:data '((my-color . "blue")))
(let ((r (tp-set " " 'my-style)))
(list (tp-at 0 'face r) (tp-at 0 'tp-name r)))))
;; ---- tp-member ----
(chk "M-member-str" '((face nil) nil)
(let ((str (copy-sequence "Hello")))
(tp-set 0 5 '(face nil) str)
(list (tp-member 0 'face str)
(tp-member 0 'display str))))
(chk "M-member-buf" '(face bold)
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 '(face bold))
(tp-member 1 'face)))
;; ---- tp-remove nested ----
(chk "R-remove-nested" '(:color "blue")
(let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue")))))
(let ((result (tp-remove original 'face :underline '(:style))))
(tp-at 0 '(face :underline) result))))
;; ---- tp-forward / tp-backward ----
(chk "N-fwd-t" 7
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char 1)
(let ((match (tp-forward 'marker t)))
(when match (prop-match-beginning match)))))
(chk "N-fwd-nil" '(1 7)
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char 1)
(let ((match (tp-forward 'marker)))
(list (prop-match-beginning match) (prop-match-end match)))))
(chk "N-bwd-t" '(7 12)
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char (point-max))
(let ((match (tp-backward 'marker t)))
(list (prop-match-beginning match) (prop-match-end match)))))
(chk "N-fwd-heading" 'heading
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(type heading))
(goto-char 1)
(let ((match (tp-forward 'type 'heading)))
(when match (prop-match-value match)))))
(chk "N-fwd-string" '((0 5 t) (12 17 t))
(let ((my-string (copy-sequence "Hello World Hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-forward 'marker nil my-string 2)))
;; ---- tp-forward-do / tp-search-map examples ----
(chk "DO-fdo" "hello world HELLO"
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-forward-do #'upcase 'marker nil my-string 2)
(substring-no-properties my-string)))
(chk "DO-bdo" "HELLO world hello"
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-backward-do #'upcase 'marker nil my-string 2)
(substring-no-properties my-string)))
(chk "DO-fdo-pos" '("hello world HELLO" (12 17))
(let ((my-string (copy-sequence "hello world hello"))
(match-info nil))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-forward-do
(lambda (text start end)
(setq match-info (list start end))
(upcase text))
'marker nil my-string 2)
(list (substring-no-properties my-string) match-info)))
(chk "SM-idx" '("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11)))
(let ((my-string (copy-sequence "aaa bbb ccc"))
(positions nil))
(tp-set 0 3 '(marker t) my-string)
(tp-set 4 7 '(marker t) my-string)
(tp-set 8 11 '(marker t) my-string)
(tp-search-map
(lambda (text start end idx)
(push (list idx start end) positions)
(upcase text))
'marker nil my-string)
(list (substring-no-properties my-string) (nreverse positions))))
;; ---- Layer definitions ----
(defvar my-color)
(chk "L-format3" '((:foreground "blue") "status: active")
(progn
(tp-layer-reset)
(define-tp my-reactive-layer ()
:props '(face (:foreground $my-color) help-echo $status-note)
:data '((my-color . "red") (status . "active"))
:compute '((status-note (lambda () (concat "status: " status))))
:watch '((my-color (lambda (new old layer) (message "Color changed!"))))
:transform (lambda (text) (upcase text)))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'my-reactive-layer)
(setq my-color "blue")
(list (tp-at 1 'face) (tp-at 1 'help-echo)))))
(chk "L-statuscolors" 3
(progn
(tp-layer-reset)
(define-tp highlight ()
'(face (:background "yellow" :foreground "black")))
(define-tp error ()
'(face (:background "red" :foreground "white")))
(define-tp info ()
'(face (:background "blue" :foreground "white")))
(define-tps status-colors ()
'highlight 'error 'info)
(length (tp-group-props 'status-colors))))
(chk "L-moon" '(display "🌕")
(progn
(tp-layer-reset)
(define-tps moon-phases ()
'("new" . (display "🌑"))
'("waxing-crescent" . (display "🌒"))
'("first-quarter" . (display "🌓"))
'("full" . (display "🌕")))
(tp-layer-props 'moon-phases-full)))
;; Compared per property (print order of the top-level plist varies
;; across Emacs versions; the tp-layers stack order itself is stable).
(chk "L-paramgroup"
'((:foreground "orange")
tp-test-l1
((face (:foreground "red") tp-name tp-test-l2)
(face (:background "green") tp-name tp-test-l3)))
(progn
(tp-layer-reset)
(define-tp tp-test-l1 (color)
`(face (:foreground ,color)))
(define-tp tp-test-l2 (color)
`(face (:foreground ,color)))
(define-tp tp-test-l3 ()
'(face (:background "green")))
(define-tps tp-test-group1 (color)
`(tp-test-l1 ,color)
'(tp-test-l2 "red")
'tp-test-l3)
(let ((r (tp-set "emacs" 'tp-test-group1 "orange")))
(list (tp-at 0 'face r)
(tp-at 0 'tp-name r)
(tp-at 0 'tp-layers r)))))
(chk "L-props" '((face bold help-echo "tip")
(face bold help-echo "tip" tp-name my-layer))
(progn
(tp-layer-reset)
(define-tp my-layer ()
'(face bold help-echo "tip"))
(list (tp-layer-props 'my-layer)
(tp-layer-props 'my-layer t))))
(chk "L-groupprops" 2
(progn
(tp-layer-reset)
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(define-tps my-group ()
'layer1 'layer2)
(length (tp-group-props 'my-group))))
(chk "L-undeflayer" nil
(progn
(tp-layer-reset)
(define-tp temp-layer () '(face bold))
(tp-undefine-layer 'temp-layer)
(tp-layer-props 'temp-layer)))
(chk "L-undefgroup" nil
(progn
(tp-layer-reset)
(define-tp l1 () '(face bold))
(define-tps my-group ()
'l1)
(tp-undefine-group 'my-group)
(assoc 'my-group tp-layer-groups)))
(chk "L-reset" '(nil nil)
(progn
(define-tp test-layer () '(face bold))
(tp-layer-reset)
(list tp-layer-alist tp-layer-groups)))
(defvar my-reactive-color "red")
(chk "L-reactivereset" '(face (:foreground "red"))
(progn
(tp-layer-reset)
(define-tp reactive-layer ()
:props '(face (:foreground $my-reactive-color)))
(tp-reactive-reset)
(tp-layer-props 'reactive-layer)))
;; ---- tp-put-layer / tp-push-layer ----
(chk "P-base" 'base
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 'base 0)
(tp-at 1 'tp-name))))
(chk "P-idx1" 2
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 'base 0)
(tp-put-layer 1 10 'highlight 1)
(tp-layer-count 1 10))))
(chk "P-bottom" 'base
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp info () '(face (:foreground "blue")))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 'base 0)
(tp-put-layer 1 10 'info -1)
(tp-layer-top 1 10))))
(chk "P-inline" '(bold "tip")
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 '(face bold help-echo "tip") 0)
(list (tp-at 1 'face) (tp-at 1 'help-echo))))
(chk "P-names" '(bold (layer-a layer-b))
(progn
(tp-layer-reset)
(define-tp layer-a () '(face bold))
(define-tp layer-b () '(face italic))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 '(layer-a layer-b) 0)
(list (tp-at 1 'face) (tp-layer-list 1 10)))))
(chk "P-param" '(:foreground "red")
(progn
(tp-layer-reset)
(define-tp tp-color (color)
`(face (:foreground ,color)))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 '(tp-color "red") 0)
(tp-at 1 'face))))
(chk "P-stack" '(:face (:background "yellow") :top highlight :layers (highlight base) :hidden 1)
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'base)
(tp-push-layer 1 10 'highlight)
(list :face (tp-at 1 'face)
:top (tp-layer-top 1 10)
:layers (tp-layer-list 1 10)
:hidden (length (tp-at 1 'tp-layers))))))
;; ---- Utilities ----
(chk "U-intervals" '((0 5 (face bold)) (5 6 nil) (6 11 (face italic)))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic))
(tp-intervals 1 12)))
(chk "U-intervalsmap" '((0 5 bold) (5 6 nil) (6 11 italic))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic))
(tp-intervals-map
(lambda (start end props belows)
(ignore belows)
(list start end (plist-get props 'face)))
1 12)))
(chk "U-plist" '(help-echo "Tip" face italic)
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold help-echo "Tip"))
(tp-set 7 12 '(face italic))
(tp-plist 1 12)))
(chk "U-emptyp" '(t nil)
(let* ((str "text")
(new (tp-set str 'face 'bold)))
(list (tp-empty-p str) (tp-empty-p new))))
(chk "U-emptyp2" t (tp-empty-p "plain text"))
(chk-str "U-popbuffer" "#(\"Important\" 0 9 (face (:foreground \"red\" :weight bold)))"
(progn
(tp-pop-to-buffer "*tp-demo*"
(insert (tp-set "Important" 'face '(:foreground "red" :weight bold))
" message\n"))
(with-current-buffer "*tp-demo*"
(buffer-substring 1 10))))
(chk "U-parsecolor1" "red" (tp-parse-color "red"))
(chk "U-parsecolor2" t
(and (member (tp-parse-color '("white" . "black")) '("white" "black")) t))
;; ---- Practical examples ----
(chk "X-taskstatus" 3
(progn
(tp-layer-reset)
(define-tp status-todo () '(face (:foreground "gray")))
(define-tp status-progress () '(face (:foreground "yellow")))
(define-tp status-done () '(face (:foreground "green")))
(define-tps task-status () 'status-todo 'status-progress 'status-done)
(length (tp-group-props 'task-status))))
(chk "X-temphl" '(face (:background "yellow"))
(progn
(tp-layer-reset)
(define-tp temp-highlight ()
'(face (:background "yellow")))
(tp-layer-props 'temp-highlight)))
(chk "X-synhl" 'code-error
(progn
(tp-layer-reset)
(define-tp code-base ()
'(face font-lock-keyword-face))
(define-tp code-error ()
'(face (:underline (:color "red" :style wave))
help-echo "Syntax error"))
(define-tp code-debug ()
'(face (:background "dark blue")))
(with-temp-buffer
(insert (make-string 100 ?x))
(tp-push-layer 1 100 'code-base)
(tp-push-layer 50 60 'code-error)
(tp-layer-top 50 60))))
;; ---- Reactive chapter ----
(defvar status-color nil)
(chk "RC-watch" '("Layer monitored-layer: color changed from nil to red"
"Layer monitored-layer: color changed from red to green")
(let ((msgs nil))
(tp-layer-reset)
(cl-letf* (((symbol-function 'message)
(lambda (fmt &rest args)
(when fmt (push (apply #'format fmt args) msgs))
nil)))
(define-tp monitored-layer ()
:props '(face (:foreground $status-color))
:watch '((status-color
(lambda (new-val old-val layer-name)
(message "Layer %s: color changed from %s to %s"
layer-name old-val new-val)))))
(setq status-color "red")
(setq status-color "green"))
(nreverse msgs)))
(chk "RC-groups" '(face (:foreground "green") tp-name status-indicators-success)
(progn
(tp-layer-reset)
(define-tps status-indicators ()
'("success" :props (face (:foreground $success-color))
:data ((success-color . "green")))
'("warning" :props (face (:foreground $warning-color))
:data ((warning-color . "orange")))
'("error" :props (face (:foreground $error-color))
:data ((error-color . "red"))))
(tp-layer-props 'status-indicators-success)))
(defvar fg-color)
(defvar bg-color)
(chk "RC-batch" '(:foreground "red" :background "blue")
(progn
(tp-layer-reset)
(define-tp themed-text ()
:props '(face (:foreground $fg-color :background $bg-color))
:data '((fg-color . "white") (bg-color . "black")))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 12 'themed-text)
(setq fg-color "yellow")
(setq bg-color "navy")
(tp-with-batch-updates
(setq fg-color "red")
(setq bg-color "blue"))
(tp-at 1 'face))))
(defvar my-face-color "blue")
(chk "RC-anon" '((:foreground "blue") (:foreground "red"))
(progn
(tp-layer-reset)
(setq my-face-color "blue")
(with-temp-buffer
(insert "Hello World")
(tp-set 1 10 '(face (:foreground $my-face-color)))
(let ((before (tp-at 1 'face)))
(setq my-face-color "red")
(list before (tp-at 1 'face))))))
;; ---- Theme example (as in the docs) ----
(declare-function switch-to-light-theme "tp-doctest")
(defvar theme-fg "white")
(defvar theme-bg "black")
(defvar theme-accent "cyan")
(chk "RC-theme" '(:before ((:foreground "cyan" :weight bold)
(:foreground "white" :background "black"))
:after ((:foreground "blue" :weight bold)
(:foreground "black" :background "white")))
(progn
(tp-layer-reset)
(setq theme-fg "white" theme-bg "black" theme-accent "cyan")
(define-tp code-text ()
:props '(face (:foreground $theme-fg :background $theme-bg)))
(define-tp code-keyword ()
:props '(face (:foreground $theme-accent :weight bold)))
(defun switch-to-light-theme ()
(interactive)
(setq theme-fg "black")
(setq theme-bg "white")
(setq theme-accent "blue"))
(defun switch-to-dark-theme ()
(interactive)
(setq theme-fg "white")
(setq theme-bg "black")
(setq theme-accent "cyan"))
(with-temp-buffer
(insert "(defun greet () (let (x) x))")
(tp-set (point-min) (point-max) 'code-text)
(tp-match-set '("defun" "defvar" "let" "if" "when") 'code-keyword)
(let ((before (list (tp-at 2 'face) (tp-at 10 'face))))
(switch-to-light-theme)
(list :before before
:after (list (tp-at 2 'face) (tp-at 10 'face)))))))
;; ---- Regexp and string-form examples ----
(tp-layer-reset)
(chk "X-buffer-return" '(1 . 10)
(let ((my-buffer (generate-new-buffer "*test*")))
(with-current-buffer my-buffer (insert "Hello World"))
(prog1 (tp-set 1 10 '(face italic) my-buffer)
(kill-buffer my-buffer))))
(chk-str "X-regexp-case-fold" "#(\"Hello WORLD\" 0 5 (face bold) 6 11 (face bold))"
(tp-regexp-set "[A-Z]+" '(face bold) "Hello WORLD"))
(chk-str "X-regexp-multi" "#(\"abc 123 XYZ\" 0 3 (face bold) 4 7 (face bold) 8 11 (face bold))"
(tp-regexp-set '("[0-9]+" "[A-Z]+") '(face bold) "abc 123 XYZ"))
(chk "X-regexp-reset-new-string" '((face italic) (help-echo "original"))
(let ((str (copy-sequence "abc 123 def")))
(tp-set 4 7 '(help-echo "original") str)
(let ((result (tp-regexp-reset "[0-9]+" '(face italic) str)))
(list (tp-at 4 result) (tp-at 4 str)))))
(chk "X-regexp-add-new-string" '((face italic help-echo "number") (help-echo "number"))
(let ((str (copy-sequence "abc 123 def")))
(tp-set 4 7 '(help-echo "number") str)
(let ((result (tp-regexp-add "[0-9]+" '(face italic) str)))
(list (tp-at 4 result) (tp-at 4 str)))))
(chk "X-match-per-pattern-order" '((7 . 12) (1 . 6) (14 . 19))
(with-temp-buffer
(insert "Hello world, Hello again")
(tp-match-set '("world" "Hello") '(face bold))))
(chk "X-do-shortfall-all-or-nothing" '(1 "hello world")
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str)
(list (tp-forward-do #'upcase 'marker nil str 3)
(substring-no-properties str))))
;; ---- 0.3.0: search bounds and SUBEXP ----
;; Compared via tp-search / tp-at accessors, not prin1 output, so the
;; property print order difference between Emacs 28 and 29+ cannot bite.
(chk "V3-match-bounds" '((10 . 14))
(with-temp-buffer
(insert "TODO one TODO two")
(tp-match-set "TODO" '(face warning) nil 5 18)))
(chk "V3-subexp" '(((8 10 bold) (13 14 bold)) ((0 3 bold)))
(list (tp-search (tp-regexp-set "\\([0-9]+\\)px" '(face bold)
"margin: 10px 4px" nil nil 1)
'face)
;; group 1 does not participate in the "bar" match
(tp-search (tp-regexp-set "\\(foo\\)\\|bar" '(face bold)
"foo bar" nil nil 1)
'face)))
(chk "V3-subexp-out-of-range"
'(:ERROR (error "Regexp \"[0-9]+\" has no group 2"))
(tp-regexp-set "[0-9]+" '(face bold) "abc 123" nil nil 2))
(chk "V3-regexp-bounds-and-reversed" '(((1 3 bold)) ((1 3 bold)))
(list (tp-search (tp-regexp-set "a+" '(face bold) "aaaa" 1 3) 'face)
(tp-search (tp-regexp-set "a+" '(face bold) "aaaa" 3 1) 'face)))
;; ---- 0.3.0: PREDICATE / NOT-CURRENT ----
(chk "V3-predicate" '((3 6) ((6 11 20)))
(list (with-temp-buffer
(insert "abcdef")
(tp-set 1 3 '(size 10))
(tp-set 3 6 '(size 20))
(goto-char 1)
(let ((match (tp-forward 'size 15 nil 1
(lambda (target v) (and v (> v target))))))
(list (prop-match-beginning match) (prop-match-end match))))
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(size 10) str)
(tp-set 6 11 '(size 20) str)
(tp-forward 'size 15 str 2
(lambda (target v) (and v (> v target)))))))
(chk "V3-not-current" '(2 5)
(with-temp-buffer
(insert "one two")
(tp-set 1 4 '(mark t))
(tp-set 5 8 '(mark t))
(let (a b)
(goto-char 2)
(setq a (prop-match-beginning (tp-forward 'mark t)))
(goto-char 2)
(setq b (prop-match-beginning (tp-forward 'mark t nil 1 nil t)))
(list a b))))
;; ---- 0.3.0: multi-argument parameterized layers ----
(chk "V3-multiarg-specs" '((:foreground "red" :background "blue")
((:foreground "red" :background "blue") "tip")
(:foreground "white" :background "black"))
(progn
(tp-layer-reset)
(define-tp tp-colors (fg bg)
`(face (:foreground ,fg :background ,bg)))
(list (tp-at 0 'face (tp-set "hello" 'tp-colors "red" "blue"))
(let ((str (copy-sequence "hello")))
(tp-set 0 5 '(tp-colors ("red" "blue") help-echo "tip") str)
(list (tp-at 0 'face str) (tp-at 0 'help-echo str)))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 '(tp-colors "white" "black") 0)
(tp-at 1 'face)))))
(chk "V3-multiarg-arity-error"
'(:ERROR (error "tp layer tp-colors takes 2 argument(s), got 1"))
(tp-set "hello" 'tp-colors "red"))
(chk "V3-args-introspection"
'((face (:foreground "red" :background "blue"))
(fg bg)
((face (:foreground "white" :background "black")) (face bold)))
(progn
(define-tps tp-badge (fg bg)
`(tp-colors ,fg ,bg)
'(face bold))
(list (tp-layer-props-with-args 'tp-colors '("red" "blue"))
(tp-layer-arglist 'tp-colors)
(tp-group-props-with-args 'tp-badge '("white" "black")))))
;; ---- 0.3.0: layer visibility ----
(chk "V3-hide-reveals-below"
'(:visible base :face default :count 2 :layers (highlight base))
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'base)
(tp-push-layer 1 10 'highlight)
(tp-hide-layer 1 10 'highlight)
(list :visible (tp-at 1 'tp-name)
:face (tp-at 1 'face)
:count (tp-layer-count 1 10)
:layers (tp-layer-list 1 10)))))
(chk "V3-hide-all-bare-and-show" '((:face nil :count 2) (:background "yellow"))
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'base)
(tp-push-layer 1 10 'highlight)
(tp-hide-layer 1 10 'highlight)
(tp-hide-layer 1 10 'base)
(let ((all-hidden (list :face (tp-at 1 'face)
:count (tp-layer-count 1 10))))
(tp-show-layer 1 10 'highlight)
(list all-hidden (tp-at 1 'face))))))
(chk "V3-hide-run-counts" '(1 0 0)
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'base)
(list (tp-hide-layer 1 10 'base)
(tp-hide-layer 1 10 'base)
(tp-hide-layer 1 10 'nonexistent)))))
(chk "V3-merge-excludes-hidden" '(:face bold :help nil :name merged)
(progn
(tp-layer-reset)
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(help-echo "tip"))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'layer1)
(tp-push-layer 1 10 'layer2)
(tp-hide-layer 1 10 'layer2)
(tp-merge-layers 1 10 'merged '(layer1 layer2))
(list :face (tp-at 1 'face)
:help (tp-at 1 'help-echo)
:name (tp-at 1 'tp-name)))))
(chk "V3-flatten-discards-hidden" '(default flat)
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'base)
(tp-push-layer 1 10 'highlight)
(tp-hide-layer 1 10 'highlight)
(tp-flatten-layers 1 10 'flat)
(list (tp-at 1 'face) (tp-at 1 'tp-name)))))
;; ---- 0.3.0: movement additions and stack introspection ----
(chk "V3-lower-layer" '(layer2 (layer2 layer3 layer1))
(progn
(tp-layer-reset)
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(define-tp layer3 () '(face underline))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'layer1)
(tp-push-layer 1 10 'layer2)
(tp-push-layer 1 10 'layer3)
(tp-lower-layer 1 10 'layer3 1)
(list (tp-layer-top 1 10) (tp-layer-list 1 10)))))
(chk "V3-rotate-canonical" '((layer1 layer3 layer2) (layer1 layer3 layer2))
(progn
(tp-layer-reset)
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(define-tp layer3 () '(face underline))
(list (with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'layer1)
(tp-push-layer 1 10 'layer2)
(tp-push-layer 1 10 'layer3)
(tp-rotate-layer 1 10 'up)
(tp-layer-list 1 10))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'layer1)
(tp-push-layer 1 10 'layer2)
(tp-push-layer 1 10 'layer3)
(tp-rotate-layer 1 10 'down 2)
(tp-layer-list 1 10)))))
;; Compared via assq/plist-get per layer: the top layer's PROPS come from
;; the direct text properties, whose plist order varies on Emacs 28.
(chk "V3-layer-stack-at" '(((highlight base) (:background "yellow") default nil)
((highlight base) (:background "yellow") default t)
nil)
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'base)
(tp-push-layer 1 10 'highlight)
(let* ((probe (lambda ()
(let ((stack (tp-layer-stack-at 1)))
(list (mapcar #'car stack)
(plist-get (cdr (assq 'highlight stack)) 'face)
(plist-get (cdr (assq 'base stack)) 'face)
(plist-get (cdr (assq 'highlight stack))
'tp-hidden)))))
(visible (funcall probe)))
(tp-hide-layer 1 10 'highlight)
(list visible
(funcall probe)
(with-temp-buffer (insert "Hello") (tp-layer-stack-at 1)))))))
(chk "V3-put-push-noerror" '(nil nil)
(with-temp-buffer
(insert "Hello World")
(list (tp-put-layer 1 10 'no-such-layer 0 nil t)
(tp-push-layer 1 10 'no-such-layer nil t))))
;; ---- 0.3.0: reactive layer-buffer registry and lifecycle ----
(defvar reg-color "red")
(chk "V3-registry-and-track" '(unknown t (reg-layer))
(progn
(tp-layer-reset)
(define-tp reg-layer ()
:props '(face (:foreground $reg-color)))
(let ((before (tp-reactive-layer-buffers 'reg-layer)))
(with-temp-buffer
(insert "Hello")
(tp-push-layer 1 6 'reg-layer)
(let ((registered (equal (tp-reactive-layer-buffers 'reg-layer)
(list (current-buffer)))))
(list before
registered
(let ((s (tp-set "hello" 'reg-layer)))
(with-temp-buffer
(insert s)
(tp-reactive-track-buffer)))))))))
(defvar tmp-color "green")
(chk "V3-gc-anonymous" '(1 nil nil)
(progn
(tp-reactive-reset)
(tp-layer-reset)
(let ((buf (generate-new-buffer "*gc-demo*")))
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 '(face (:foreground $tmp-color))))
(kill-buffer buf)
(let ((collected (tp-gc-anonymous-layers)))
(list (length collected)
(tp-layer-props (car collected))
;; string-only layers stay `unknown' and are kept
(let ((s (tp-set "hello" '(face (:foreground $tmp-color)))))
(ignore s)
(tp-gc-anonymous-layers)))))))
;; ---- 0.3.0: minimal-diff tp-text re-rendering ----
(defvar counter-val "0")
(chk "V3-tp-text-minimal-diff" '("count: 9 items" 105 10)
(progn
(tp-layer-reset)
(setq counter-val "0")
(define-tp counter-label ()
:props '(tp-text $counter-val))
(with-temp-buffer
(insert "count: 0 items")
(tp-set 8 9 'counter-label)
(let ((m (copy-marker 10))) ; marker on the "i" of "items"
(setq counter-val "9")
(list (buffer-substring-no-properties 1 (point-max))
(char-after m)
(marker-position m))))))
(chk "V3-tp-text-noop-unmodified" nil
(with-temp-buffer
(insert "count: 9 items")
(tp-set 8 9 'counter-label)
(set-buffer-modified-p nil)
(setq counter-val "9")
(buffer-modified-p)))
;; ---- 0.3.0: ABSOLUTE coordinates and palette primaries ----
(chk "V3-intervals-absolute"
'(((1 6 (face bold)) (6 7 nil) (7 12 (face italic))) "bold text")
(list (with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic))
(tp-intervals 1 12 nil t))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold))
(dolist (iv (tp-intervals 1 12 nil t))
(when (eq (plist-get (nth 2 iv) 'face) 'bold)
(tp-add (nth 0 iv) (nth 1 iv) '(help-echo "bold text"))))
(tp-at 1 'help-echo))))
(chk "V3-intervals-map-absolute" '((1 6 bold) (6 7 nil) (7 12 italic))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic))
(tp-intervals-map
(lambda (start end props belows)
(ignore belows)
(list start end (plist-get props 'face)))
1 12 nil t)))
;; The resolved color depends on the frame's light/dark mode, like the
;; U-parsecolor2 assertion above.
(chk "V3-palette-primaries" '(t nil (t t t nil))
(list (and (member (tp-palette-color 'info :fg)
'("#0969da" "#58a6ff"))
t)
(tp-palette-color 'no-such-palette :fg)
(list (tp-palette-has-p 'info)
(tp-palette-has-p 'info :fg)
(tp-palette-has-p 'info :border)
(tp-palette-has-p 'no-such-palette))))
(princ (format "\nTOTAL: %d FAILS: %d\n" tp-doctest--total tp-doctest--fails))
(when (> tp-doctest--fails 0) (kill-emacs 1))
;;; tp-doctest.el ends here

710
tp-layer-tests.el Normal file
View File

@ -0,0 +1,710 @@
;;; tp-layer-tests.el --- ERT regression tests for tp-layer.el -*- lexical-binding: t -*-
;;; 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.
;;; 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))
`(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)
;;; 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."
(should-error
(eval '(define-tp tp-layer-test-extra ()
'(face bold)
'(display "x"))
t)))
(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-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 ()
"tp--normalize-layer-spec accepts (LAYER ARG1 ARG2) specs."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(should (equal (tp--normalize-layer-spec
'(tp-layer-test-fgbg "red" "blue"))
'(face (:foreground "red" :background "blue")
tp-name tp-layer-test-fgbg)))))
(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 is unchanged.
(let ((s (copy-sequence "st")))
(tp-push-layer s '(tp-lt-colors "red" "blue"))
(should (equal (text-properties-at 0 s)
'(face (:foreground "red" :background "blue")
tp-name tp-lt-colors))))))
;;; 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)
`(face (:foreground ,color)))
(should (equal (tp-layer-props-with-arg 'tp-layer-test-alias-p "red")
'(face (:foreground "red"))))))
(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))))))
(provide 'tp-layer-tests)
;;; tp-layer-tests.el ends here

File diff suppressed because it is too large Load Diff

View File

@ -278,54 +278,5 @@
(should (equal (tp-member 1 'my-prop) '(my-prop nil))) (should (equal (tp-member 1 'my-prop) '(my-prop nil)))
(should (equal (tp-member 1 'other) nil)))) (should (equal (tp-member 1 'other) nil))))
;;; Stage 2 canonical operation requests
(ert-deftest tp-ops-test-parser-builds-canonical-string-request ()
"The flexible string parser ends at one canonical request."
(let* ((str (copy-sequence "hello"))
(request (tp--parse-args str 'face 'bold nil :set))
(range (tp--request-range request)))
(should (tp--request-p request))
(should (eq (tp--request-operation request) :set))
(should (equal (tp--request-props request) '(face bold)))
(should (eq (tp--request-mutation request) :copy))
(should (eq (tp--request-public-return request) :object))
(should (eq (tp--native-range-object range) str))
(should (equal (list (tp--native-range-start range)
(tp--native-range-end range))
'(0 5)))))
(ert-deftest tp-ops-test-parser-builds-canonical-buffer-request ()
"The region parser resolves nil to a concrete current-buffer range."
(with-temp-buffer
(insert "hello")
(let* ((request (tp--parse-args 2 5 '(face bold) nil :add))
(range (tp--request-range request)))
(should (eq (tp--request-operation request) :add))
(should (eq (tp--request-mutation request) :in-place))
(should (eq (tp--request-public-return request) :range))
(should (eq (tp--native-range-object range) (current-buffer)))
(should (equal (list (tp--native-range-start range)
(tp--native-range-end range))
'(2 5))))))
;;; TP-A05: removing the last sub-property removes its parent key
(ert-deftest tp-ops-test-remove-last-sub-key-removes-string-parent ()
"String sub-property removal does not leave a present nil parent."
(let* ((str (propertize "x" 'face '(:underline t)))
(result (tp-remove str 'face :underline)))
(should-not (tp-member 0 'face result))))
(ert-deftest tp-ops-test-remove-last-sub-key-string-buffer-parity ()
"String and buffer removal both omit an emptied parent property."
(let* ((str (propertize "x" 'face '(:underline t)))
(result (tp-remove str 'face :underline)))
(should-not (plist-member (text-properties-at 0 result) 'face)))
(with-temp-buffer
(insert (propertize "x" 'face '(:underline t)))
(tp-remove 1 2 '(face :underline))
(should-not (plist-member (text-properties-at 1) 'face))))
(provide 'tp-ops-tests) (provide 'tp-ops-tests)
;;; tp-ops-tests.el ends here ;;; tp-ops-tests.el ends here

1578
tp-ops.el

File diff suppressed because it is too large Load Diff

View File

@ -261,43 +261,45 @@ documentation of NAME and PLIST.")
"Return non-nil when the current frame's background mode is light." "Return non-nil when the current frame's background mode is light."
(eq (frame-parameter nil 'background-mode) 'light)) (eq (frame-parameter nil 'background-mode) 'light))
(defun tp-parse-color (color &optional mode) (defun tp-parse-color (color)
"Resolve COLOR to a color string for MODE or the current frame theme. "Resolve COLOR to a color string for the current theme.
COLOR may be: COLOR may be:
- a color string, returned as is: \"red\" - a color string, returned as is: \"red\"
- a (LIGHT . DARK) cons: (\"red\" . \"green\"); either side may be - a (LIGHT . DARK) cons: (\"red\" . \"green\"); either side may be
nil, meaning no color for that mode nil, meaning no color for that mode
- a (:light LIGHT :dark DARK) plist: (:light \"red\" :dark \"green\") - a (:light LIGHT :dark DARK) plist: (:light \"red\" :dark \"green\")
MODE may be `light' or `dark'. When MODE is nil, use the current Return nil when COLOR is nil, or when the side selected by the
frame's background mode. Return nil when COLOR is nil, or when the current theme is nil. When the theme cannot be determined, fall
selected side is nil. An unknown frame mode falls back to `light'." back to the light color."
(let ((mode (or mode (if (tp-theme-dark-p) 'dark 'light))))
(unless (memq mode '(light dark))
(signal 'wrong-type-argument (list '(member light dark) mode)))
(cond ((stringp color) color) (cond ((stringp color) color)
((and (consp color) ((and (consp color)
(or (stringp (car color)) (null (car color))) (or (stringp (car color)) (null (car color)))
(or (stringp (cdr color)) (null (cdr color)))) (or (stringp (cdr color)) (null (cdr color))))
(if (eq mode 'dark) (cdr color) (car color))) (cond
((tp-theme-light-p) (car color))
((tp-theme-dark-p) (cdr color))
;; Default to light color when background-mode is unknown
(t (car color))))
((and (tp-palette--plistp color) ((and (tp-palette--plistp color)
(or (plist-member color :light) (or (plist-member color :light)
(plist-member color :dark))) (plist-member color :dark)))
(if (eq mode 'dark) (cond
(plist-get color :dark) ((tp-theme-light-p) (plist-get color :light))
(plist-get color :light))) ((tp-theme-dark-p) (plist-get color :dark))
;; Default to light color when background-mode is unknown
(t (plist-get color :light))))
((null color) nil) ((null color) nil)
(t (error "Invalid format of color %S" color))))) (t (error "Invalid format of color %S" color))))
(defun tp-palette--get-color (symbol key &optional mode) (defun tp-palette--get-color (symbol key)
"Get color value for KEY from palette SYMBOL, resolving MODE. "Get color value for KEY from the palette named SYMBOL.
SYMBOL is looked up in `tp-palette-alist'. KEY should be one of SYMBOL is looked up in `tp-palette-alist'. KEY should be one of
:fg, :bg, or :border. Return nil if SYMBOL names no registered :fg, :bg, or :border. Return nil if SYMBOL names no registered
palette or its definition doesn't contain KEY. palette or its definition doesn't contain KEY.
The public entry points are `tp-palette-color' and The public entry point delegating here is `tp-palette-color'."
`tp-palette-color-for-mode'."
(let ((plist (alist-get symbol tp-palette-alist))) (let ((plist (alist-get symbol tp-palette-alist)))
(when (tp-palette--plistp plist) (when (tp-palette--plistp plist)
(tp-parse-color (plist-get plist key) mode)))) (tp-parse-color (plist-get plist key)))))
(defun tp-palette-color (symbol key) (defun tp-palette-color (symbol key)
"Return the KEY color of the palette named SYMBOL, theme-resolved. "Return the KEY color of the palette named SYMBOL, theme-resolved.
@ -315,16 +317,8 @@ conveniences equivalent to calling it with a fixed KEY. See also
color." color."
(tp-palette--get-color symbol key)) (tp-palette--get-color symbol key))
(defun tp-palette-color-for-mode (symbol key mode)
"Return palette SYMBOL KEY resolved explicitly for MODE.
MODE must be `light' or `dark'. Unlike `tp-palette-color', this
function does not inspect the selected frame, so a higher-level
application Theme can switch palettes without changing the Emacs
frame's own background mode."
(tp-palette--get-color symbol key mode))
(defun tp-palette-has-p (symbol &optional kind) (defun tp-palette-has-p (symbol &optional kind)
"Return non-nil when KIND is available in SYMBOL's palette. "Return non-nil when SYMBOL names a palette that defines KIND.
With nil KIND, test only that SYMBOL names a palette registered in With nil KIND, test only that SYMBOL names a palette registered in
`tp-palette-alist' (like `tp-palette-p'). Otherwise KIND is one of `tp-palette-alist' (like `tp-palette-p'). Otherwise KIND is one of
:fg, :bg or :border, and the palette's definition must contain that :fg, :bg or :border, and the palette's definition must contain that

View File

@ -1,194 +0,0 @@
;;; tp-query.el --- Native query and policy helpers for tp -*- lexical-binding: t -*-
;; Copyright (C) 2024-2026 Geekinney
;; Author: Geekinney (kinneyzhang666@gmail.com)
;;; Commentary:
;; Explicit native text-property query boundaries and mutation policy.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(cl-defstruct (tp-lookup-result
(:constructor tp--make-lookup-result
(&key property value present-p source mode
object position overlay)))
"Normalized text or character property lookup result.
PRESENT-P distinguishes an explicit nil value from absence. SOURCE
identifies the winning text source or `:overlay'; OVERLAY is non-nil
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 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
:property property :value (cadr cell) :present-p (and cell t)
:source (if cell :text-direct :absent) :mode mode
:object obj :position position)))
(defun tp--lookup-effective (position property object mode)
"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)))
(tp--make-lookup-result
:property property :value value :present-p present-p
:source (if present-p (car source-cell) :absent) :mode mode
:object (or object (current-buffer)) :position position)))
(defun tp--lookup-char (position property object mode)
"Return overlay-aware lookup for PROPERTY at POSITION in OBJECT.
MODE is recorded in the returned `tp-lookup-result'."
(let* ((native (get-char-property-and-overlay position property object))
(overlay (cdr native))
(text-object (if (windowp object) (window-buffer object) object))
(text-source (tp--lookup-source-cell
position property text-object))
(present-p (or overlay (nth 2 text-source)))
(source (if overlay :overlay (car text-source))))
(tp--make-lookup-result
:property property :value (car native) :present-p (and present-p t)
:source source :mode mode :object (or object (current-buffer))
:position position :overlay overlay)))
(defun tp--lookup-alias-cell (position property object)
"Return the first non-nil alias value for PROPERTY at POSITION."
(catch 'found
(dolist (alias (cdr (assq property char-property-alias-alist)))
(when-let* ((value (get-text-property position alias object)))
(throw 'found (list alias value))))))
(defun tp--lookup-source-cell (position property object)
"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))
(cat-cell (and category (plist-member (symbol-plist category) property)))
(alias-cell (tp--lookup-alias-cell position property object))
(default-cell (plist-member default-text-properties property)))
(cond
(direct (list :text-direct (cadr direct) t))
(cat-cell (list :category (cadr cat-cell) t))
(alias-cell (list :alias (cadr alias-cell) t))
(default-cell (list :default (cadr default-cell) t))
(t (list :absent nil nil)))))
;;;###autoload
(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';
when an overlay supplies the winning value, the result records both
source `:overlay' and the winning overlay object.
Always return a `tp-lookup-result'. Its `present-p' field separates
absence from a direct property whose value is nil."
(pcase mode
(:text-direct (tp--lookup-direct position property object mode))
(:text-effective (tp--lookup-effective position property object mode))
(:text-source
(pcase-let ((`(,source ,value ,present-p)
(tp--lookup-source-cell position property object)))
(tp--make-lookup-result
:property property :value value :present-p present-p
:source source :mode mode :object (or object (current-buffer))
:position position)))
((or :char :char-source)
(tp--lookup-char position property object mode))
(_ (error "TP-LOOKUP: unknown mode %S" mode))))
;;;###autoload
(cl-defun tp-property-change
(position &key property object limit (direction :next))
"Return a native property change position from POSITION.
With PROPERTY, delegate to the single-property change primitives;
with nil PROPERTY, observe changes to any property. DIRECTION is
`:next' or `:previous'. OBJECT and LIMIT retain their native Emacs
meanings. Return the changed position or nil."
(pcase direction
(:next
(if property
(next-single-property-change position property object limit)
(next-property-change position object limit)))
(:previous
(if property
(previous-single-property-change position property object limit)
(previous-property-change position object limit)))
(_ (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.
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.
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.
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"))
(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))
(let ((modified (if (plist-member policy :modified)
(plist-get policy :modified)
:ordinary))
(read-only (if (plist-member policy :read-only)
(plist-get policy :read-only)
:respect)))
(unless (memq modified '(:ordinary :silent))
(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))
(when (and (eq modified :silent) (eq read-only :respect))
(error "TP-WITH-MUTATION-POLICY: :silent requires :read-only :inhibit"))
(list modified read-only)))
;;;###autoload
(defmacro tp-with-mutation-policy (policy &rest body)
"Run BODY with explicit mutation POLICY.
POLICY accepts `:modified' (`:ordinary' or `:silent') and
`:read-only' (`:respect' or `:inhibit'). The supported combinations
are ordinary/respect, ordinary/inhibit, and silent/inhibit.
Silent/respect is rejected because native `with-silent-modifications'
itself inhibits read-only text."
(declare (indent 1) (debug (form body)))
`(pcase (tp--mutation-policy-modes ,policy)
('(:ordinary :respect) ,@body)
('(:ordinary :inhibit)
(let ((inhibit-read-only t)) ,@body))
('(:silent :inhibit)
(let ((inhibit-read-only t))
(with-silent-modifications ,@body)))))
(provide 'tp-query)
;;; tp-query.el ends here

File diff suppressed because it is too large Load Diff

893
tp-render-tests.el Normal file
View File

@ -0,0 +1,893 @@
;;; tp-render-tests.el --- ERT regression tests for tp-render.el -*- lexical-binding: t -*-
;;; Commentary:
;; Regression tests for confirmed bugs fixed in the reactive-render
;; module (tp-render.el, with supporting fixes in tp-reactive.el).
;; Each section is tagged with the canonical bug id it guards against.
;;; Code:
(require 'ert)
(require 'tp)
;; Reactive test variables must be dynamically bound so watcher and
;; compute machinery can see them through `symbol-value'.
(defvar tp-rt-b9-var nil)
(defvar tp-rt-b10-data nil)
(defvar tp-rt-b10-full nil)
(defvar tp-rt-b11-face nil)
(defvar tp-rt-b11b-color nil)
(defvar tp-rt-b12-color nil)
(defvar tp-rt-b13-text nil)
(defvar tp-rt-b13b-text nil)
(defvar tp-rt-b14-flag nil)
(defvar tp-rt-b14-inv nil)
(defvar tp-rt-b14b-init nil)
(defvar tp-rt-b16-data nil)
(defvar tp-rt-b16-comp nil)
(defvar tp-rt-b16-count 0)
(defvar tp-rt-b17-color nil)
(defvar tp-rt-b17-text nil)
(defvar tp-rt-b17b-color nil)
(defvar tp-rt-b17b-echo nil)
(defvar tp-rt-b18-text nil)
(defvar tp-rt-b19-amount nil)
(defvar tp-rt-b19s-amount nil)
(defvar tp-rt-r1-color nil)
(defvar tp-rt-r1b-color nil)
(defvar tp-rt-r1c-color nil)
(defvar tp-rt-r1d-color nil)
(defvar tp-rt-r2-text nil)
(defvar tp-rt-r2m-text nil)
(defvar tp-rt-r2n-text nil)
(defvar tp-rt-r2s-text nil)
(defvar tp-rt-r3a-color nil)
(defvar tp-rt-r3b-color nil)
(defvar tp-rt-r3c-color nil)
(defmacro tp-rt-with-cleanup (layers vars &rest body)
"Run BODY, then undefine LAYERS and reset VARS to nil (teardown)."
(declare (indent 2))
`(unwind-protect
(progn ,@body)
,@(mapcar (lambda (l) `(tp-undefine-layer ',l)) layers)
,@(mapcar (lambda (v) `(setq ,v nil)) vars)))
;;; B9: sub-region tp-text on a string must splice, not replace the whole string
(ert-deftest tp-render-test-tp-text-string-region-keeps-rest ()
"Region-form tp-text on a string keeps the text outside the region."
(let ((result (tp-set 0 1 '(tp-text "X") (copy-sequence "abc"))))
(should (equal result "Xbc"))
(should (equal (get-text-property 0 'tp-text result) "X"))
;; The preserved suffix must not receive the layer's props
(should (null (get-text-property 1 'tp-text result)))
(should (null (get-text-property 2 'tp-text result)))))
(ert-deftest tp-render-test-tp-text-string-mid-region-splices ()
"A mid-string tp-text region splices prefix + replacement + suffix."
(let ((result (tp-set 1 2 '(face bold tp-text "XY") (copy-sequence "abc"))))
(should (equal result "aXYc"))
;; Props only on the replaced span [1, 3)
(should (null (get-text-property 0 'face result)))
(should (eq (get-text-property 1 'face result) 'bold))
(should (eq (get-text-property 2 'face result) 'bold))
(should (null (get-text-property 3 'face result)))))
(ert-deftest tp-render-test-tp-text-string-region-preserves-outside-props ()
"Splicing keeps the original string's properties outside the region."
(let* ((source (propertize "abc" 'face 'italic 'my-prop 1))
(result (tp-set 1 2 '(tp-text "X") source)))
(should (equal result "aXc"))
;; Prefix and suffix keep their original props
(should (eq (get-text-property 0 'face result) 'italic))
(should (eq (get-text-property 2 'face result) 'italic))
;; Replaced span preserves non-conflicting props (tp-set preserves)
(should (eq (get-text-property 1 'my-prop result) 1))))
(ert-deftest tp-render-test-tp-text-whole-string-still-replaces ()
"Whole-string form still returns just the replacement (legacy semantics)."
(let ((result (tp-set "2" 'face '(:background "green") 'tp-text "6")))
(should (equal result "6"))
(should (equal (get-text-property 0 'face result) '(:background "green")))
(should (equal (get-text-property 0 'tp-text result) "6"))))
;;; B10: computed-variable path must not clobber sibling static attributes
(ert-deftest tp-render-test-computed-update-keeps-static-siblings ()
"A computed update deep-merges, keeping static nested attributes."
(tp-rt-with-cleanup (tp-rt-b10-layer) (tp-rt-b10-data tp-rt-b10-full)
(setq tp-rt-b10-data "red")
(define-tp tp-rt-b10-layer ()
:props '(face (:foreground $tp-rt-b10-full :background "green"))
:data '(tp-rt-b10-data)
:compute '((tp-rt-b10-full (lambda () (concat "col-" tp-rt-b10-data)))))
(setq tp-rt-b10-data "blue")
(let ((face (plist-get (cdr (assoc 'tp-rt-b10-layer tp-layer-alist)) 'face)))
(should (equal (plist-get face :foreground) "col-blue"))
;; The sibling static attribute must survive the update
(should (equal (plist-get face :background) "green")))))
;;; B11: reactive refresh replaces the layer's own keys instead of accumulating
(ert-deftest tp-render-test-reactive-refresh-replaces-face ()
"Changing a symbol-valued face variable replaces the face, not stacks it."
(tp-rt-with-cleanup (tp-rt-b11-layer) (tp-rt-b11-face)
(setq tp-rt-b11-face 'bold)
(define-tp tp-rt-b11-layer () '(face $tp-rt-b11-face))
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 'tp-rt-b11-layer)
(should (eq (get-text-property 1 'face) 'bold))
(setq tp-rt-b11-face 'italic)
;; Must be italic alone, not (italic bold)
(should (eq (get-text-property 1 'face) 'italic)))))
(ert-deftest tp-render-test-reactive-refresh-keeps-unrelated-props ()
"Reactive refresh leaves property keys the layer does not own alone."
(tp-rt-with-cleanup (tp-rt-b11b-layer) (tp-rt-b11b-color)
(setq tp-rt-b11b-color "red")
(define-tp tp-rt-b11b-layer () '(face (:foreground $tp-rt-b11b-color)))
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 'tp-rt-b11b-layer)
(put-text-property 1 6 'help-echo "keep me")
(setq tp-rt-b11b-color "green")
(should (equal (plist-get (get-text-property 1 'face) :foreground) "green"))
(should (equal (get-text-property 1 'help-echo) "keep me")))))
;;; B12: setq-local must not leak into the global layer definition
(ert-deftest tp-render-test-setq-local-does-not-touch-global-def ()
"A buffer-local change re-renders the buffer but keeps the global def."
(tp-rt-with-cleanup (tp-rt-b12-layer) ()
(setq-default tp-rt-b12-color "red")
(define-tp tp-rt-b12-layer () '(face (:foreground $tp-rt-b12-color)))
(let ((buf-a (generate-new-buffer " tp-rt-b12-a"))
(buf-b (generate-new-buffer " tp-rt-b12-b")))
(unwind-protect
(progn
(with-current-buffer buf-a
(insert "Hello")
(tp-set 1 6 'tp-rt-b12-layer))
(with-current-buffer buf-b
(insert "Hello")
(tp-set 1 6 'tp-rt-b12-layer))
(with-current-buffer buf-a
(setq-local tp-rt-b12-color "purple"))
;; Buffer A is re-rendered with its local value
(with-current-buffer buf-a
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"purple")))
;; The GLOBAL definition must not absorb the local value
(should (equal (plist-get
(plist-get (cdr (assoc 'tp-rt-b12-layer tp-layer-alist))
'face)
:foreground)
"red"))
(should (equal (default-value 'tp-rt-b12-color) "red"))
;; Other buffers keep rendering the global value
(with-current-buffer buf-b
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"red"))))
(kill-buffer buf-a)
(kill-buffer buf-b)
(setq-default tp-rt-b12-color nil)))))
;;; B13: reactive tp-text replacement preserves unrelated properties
(ert-deftest tp-render-test-reactive-text-update-preserves-other-props ()
"Replacing reactive text keeps properties other layers put on the region."
(tp-rt-with-cleanup (tp-rt-b13-layer) (tp-rt-b13-text)
(setq tp-rt-b13-text "aaa")
(define-tp tp-rt-b13-layer () '(face bold tp-text $tp-rt-b13-text))
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 'tp-rt-b13-layer)
(put-text-property 1 3 'my-other-prop 42)
(setq tp-rt-b13-text "bbb")
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"bbb"))
;; The unrelated property survives the text replacement
(should (eq (get-text-property 1 'my-other-prop) 42))
;; The layer's own props are still applied
(should (eq (get-text-property 1 'face) 'bold)))))
(ert-deftest tp-render-test-reactive-text-same-text-preserves-other-props ()
"A same-text properties-only update keeps unrelated properties too."
(tp-rt-with-cleanup (tp-rt-b13b-layer) (tp-rt-b13b-text)
(setq tp-rt-b13b-text "emacs")
(define-tp tp-rt-b13b-layer () '(tp-text $tp-rt-b13b-text))
(with-temp-buffer
(insert "emacs")
(tp-set 1 6 'tp-rt-b13b-layer)
(put-text-property 1 6 'my-other-prop 'yes)
;; Same text, new embedded properties
(setq tp-rt-b13b-text (propertize "emacs" 'face 'bold))
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 1 'my-other-prop) 'yes)))))
;;; B14: computed values of nil must propagate
(ert-deftest tp-render-test-computed-nil-propagates-on-update ()
"A compute function returning nil updates the variable and the layer."
(tp-rt-with-cleanup (tp-rt-b14-layer) (tp-rt-b14-flag tp-rt-b14-inv)
(setq tp-rt-b14-flag t)
(define-tp tp-rt-b14-layer ()
:props '(invisible $tp-rt-b14-inv)
:data '(tp-rt-b14-flag)
:compute '((tp-rt-b14-inv (lambda () tp-rt-b14-flag))))
(should (eq tp-rt-b14-inv t))
(setq tp-rt-b14-flag nil)
;; nil is a legitimate computed value, not an error sentinel
(should (eq tp-rt-b14-inv nil))
(should (eq (plist-get (cdr (assoc 'tp-rt-b14-layer tp-layer-alist))
'invisible)
nil))))
(ert-deftest tp-render-test-computed-nil-applies-initially ()
"An initial computed value of nil overwrites a stale non-nil value."
(tp-rt-with-cleanup (tp-rt-b14b-layer) (tp-rt-b14b-init)
(setq tp-rt-b14b-init 'stale)
(define-tp tp-rt-b14b-layer ()
:props '(invisible $tp-rt-b14b-init)
:compute '((tp-rt-b14b-init (lambda () nil))))
(should (eq tp-rt-b14b-init nil))))
;;; B16: no watcher recursion from nested variable writes
(ert-deftest tp-render-test-compute-runs-once-per-change ()
"One data change runs each compute function exactly once (no recursion)."
(tp-rt-with-cleanup (tp-rt-b16-layer) (tp-rt-b16-data tp-rt-b16-comp)
(setq tp-rt-b16-data "a" tp-rt-b16-count 0)
(define-tp tp-rt-b16-layer ()
:props '(help-echo $tp-rt-b16-comp)
:data '(tp-rt-b16-data)
:compute '((tp-rt-b16-comp
(lambda ()
(setq tp-rt-b16-count (1+ tp-rt-b16-count))
(concat tp-rt-b16-data "!")))))
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 'tp-rt-b16-layer)
(setq tp-rt-b16-count 0)
(setq tp-rt-b16-data "b")
;; The nested (set comp ...) must queue its re-render, not re-enter
;; the compute machinery.
(should (= tp-rt-b16-count 1))
;; The nested change's re-render still lands in the buffer
(should (equal tp-rt-b16-comp "b!"))
(should (equal (get-text-property 1 'help-echo) "b!")))))
;;; B17: batched entries must union WHERE and the tp-text-affected flag
(ert-deftest tp-render-test-batch-tp-text-flag-is-sticky ()
"A tp-text change deferred after a non-tp-text change still replaces text."
(tp-rt-with-cleanup (tp-rt-b17-layer) (tp-rt-b17-color tp-rt-b17-text)
(setq tp-rt-b17-color "red" tp-rt-b17-text "one")
(define-tp tp-rt-b17-layer ()
'(face (:foreground $tp-rt-b17-color) tp-text $tp-rt-b17-text))
(with-temp-buffer
(insert "one")
(tp-set 1 4 'tp-rt-b17-layer)
(tp-with-batch-updates
(setq tp-rt-b17-color "blue") ; first change: no tp-text
(setq tp-rt-b17-text "two")) ; second change: tp-text affected
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"two"))
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"blue")))))
(ert-deftest tp-render-test-batch-where-widens-to-all-buffers ()
"A global change after a buffer-local one must reach other buffers."
(tp-rt-with-cleanup (tp-rt-b17b-layer) ()
(setq-default tp-rt-b17b-color "red")
(setq-default tp-rt-b17b-echo "old")
(define-tp tp-rt-b17b-layer ()
'(face (:foreground $tp-rt-b17b-color) help-echo $tp-rt-b17b-echo))
(let ((buf-a (generate-new-buffer " tp-rt-b17b-a"))
(buf-b (generate-new-buffer " tp-rt-b17b-b")))
(unwind-protect
(progn
(with-current-buffer buf-a
(insert "Hello") (tp-set 1 6 'tp-rt-b17b-layer))
(with-current-buffer buf-b
(insert "Hello") (tp-set 1 6 'tp-rt-b17b-layer))
(with-current-buffer buf-a
(tp-with-batch-updates
(setq-local tp-rt-b17b-color "blue") ; WHERE = buf-a
(setq tp-rt-b17b-echo "new"))) ; WHERE = global
;; The global change must not be trapped in buf-a's WHERE
(with-current-buffer buf-b
(should (equal (get-text-property 1 'help-echo) "new"))
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"red")))
;; buf-a gets both, with its local color honored
(with-current-buffer buf-a
(should (equal (get-text-property 1 'help-echo) "new"))
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"blue"))))
(kill-buffer buf-a)
(kill-buffer buf-b)
(setq-default tp-rt-b17b-color nil)
(setq-default tp-rt-b17b-echo nil)))))
;;; B18: multi-interval reactive strings keep per-interval styling
(ert-deftest tp-render-test-reactive-text-keeps-per-interval-props ()
"A propertized reactive string renders each interval's own props."
(tp-rt-with-cleanup (tp-rt-b18-layer) (tp-rt-b18-text)
(setq tp-rt-b18-text "init")
(define-tp tp-rt-b18-layer () '(tp-text $tp-rt-b18-text))
(with-temp-buffer
(insert "init")
(tp-set 1 5 'tp-rt-b18-layer)
(setq tp-rt-b18-text (concat (propertize "AB" 'face 'bold)
(propertize "CD" 'face 'italic)))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"ABCD"))
;; Position-0 props must not smear over the whole region
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 2 'face) 'bold))
(should (eq (get-text-property 3 'face) 'italic))
(should (eq (get-text-property 4 'face) 'italic)))))
;;; B19: :transform applies on the initial nil-tp-text render too
(ert-deftest tp-render-test-transform-applies-on-initial-render ()
"First render of a nil tp-text layer shows the transformed text."
(tp-rt-with-cleanup (tp-rt-b19-layer) (tp-rt-b19-amount)
(setq tp-rt-b19-amount nil)
(define-tp tp-rt-b19-layer ()
:props '(face bold tp-text $tp-rt-b19-amount)
:transform (lambda (s) (concat "$" s)))
(with-temp-buffer
(insert "5.00")
(tp-set 1 5 'tp-rt-b19-layer)
;; Initial rendering must match later reactive renderings
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"$5.00"))
;; The model (variable and tp-text prop) keeps the raw value
(should (equal tp-rt-b19-amount "5.00"))
(should (equal (get-text-property 1 'tp-text) "5.00"))
(should (eq (get-text-property 1 'face) 'bold))
;; And a later update stays consistent
(setq tp-rt-b19-amount "6.00")
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"$6.00")))))
(ert-deftest tp-render-test-transform-applies-on-initial-string-render ()
"String form of a nil tp-text layer also shows the transformed text."
(tp-rt-with-cleanup (tp-rt-b19s-layer) (tp-rt-b19s-amount)
(setq tp-rt-b19s-amount nil)
(define-tp tp-rt-b19s-layer ()
:props '(face bold tp-text $tp-rt-b19s-amount)
:transform (lambda (s) (concat "$" s)))
(let ((result (tp-set "5.00" 'tp-rt-b19s-layer)))
(should (equal result "$5.00"))
;; Model keeps the raw value
(should (equal tp-rt-b19s-amount "5.00"))
(should (equal (get-text-property 0 'tp-text result) "5.00"))
(should (eq (get-text-property 0 'face result) 'bold)))))
;;; R1 (0.3.0): reactive buffer registry replaces the buffer-list scan
(ert-deftest tp-render-test-registry-update-visits-only-registered ()
"A reactive update walks only registered buffers, not `buffer-list'."
(tp-rt-with-cleanup (tp-rt-r1-layer) (tp-rt-r1-color)
(setq tp-rt-r1-color "red")
(define-tp tp-rt-r1-layer () '(face (:foreground $tp-rt-r1-color)))
(let ((buf-a (generate-new-buffer " tp-rt-r1-a"))
(buf-b (generate-new-buffer " tp-rt-r1-b"))
(visited nil))
(unwind-protect
(progn
(with-current-buffer buf-a
(insert "Hello")
(tp-set 1 6 'tp-rt-r1-layer))
(with-current-buffer buf-b (insert "Hello"))
;; Applying through tp-ops registered the buffer
(should (equal (tp-reactive-layer-buffers 'tp-rt-r1-layer)
(list buf-a)))
;; Count per-buffer visits of the update walk
(let ((orig (symbol-function 'tp--render-visit-buffer)))
(cl-letf (((symbol-function 'tp--render-visit-buffer)
(lambda (buf fn)
(push buf visited)
(funcall orig buf fn))))
(setq tp-rt-r1-color "blue")))
;; Only the registered buffer was visited
(should (equal visited (list buf-a)))
(with-current-buffer buf-a
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"blue"))))
(kill-buffer buf-a)
(kill-buffer buf-b)))))
(ert-deftest tp-render-test-registry-prunes-on-kill-buffer ()
"Killing a buffer removes it from the layer-buffer registry."
(tp-rt-with-cleanup (tp-rt-r1b-layer) (tp-rt-r1b-color)
(setq tp-rt-r1b-color "red")
(define-tp tp-rt-r1b-layer () '(face (:foreground $tp-rt-r1b-color)))
(let ((buf (generate-new-buffer " tp-rt-r1b")))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 'tp-rt-r1b-layer))
(should (equal (tp-reactive-layer-buffers 'tp-rt-r1b-layer)
(list buf)))
(kill-buffer buf)
;; The kill-buffer hook pruned the raw registry entry ...
(should-not (memq buf (gethash 'tp-rt-r1b-layer
tp--layer-buffers)))
;; ... and the accessor answers "known: none", NOT `unknown'.
(should (null (tp-reactive-layer-buffers 'tp-rt-r1b-layer)))
(should-not (eq (tp-reactive-layer-buffers 'tp-rt-r1b-layer)
'unknown)))
(when (buffer-live-p buf) (kill-buffer buf))))))
(ert-deftest tp-render-test-registry-unknown-full-scan-learns ()
"An `unknown' layer falls back to a full scan and learns its buffers."
(tp-rt-with-cleanup (tp-rt-r1c-layer) (tp-rt-r1c-color)
(setq tp-rt-r1c-color "red")
(define-tp tp-rt-r1c-layer () '(face (:foreground $tp-rt-r1c-color)))
(let ((buf (generate-new-buffer " tp-rt-r1c")))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 'tp-rt-r1c-layer))
;; Simulate a buffer that got the layer outside the
;; registering paths: erase the registry knowledge.
(remhash 'tp-rt-r1c-layer tp--layer-buffers)
(should (eq (tp-reactive-layer-buffers 'tp-rt-r1c-layer)
'unknown))
;; The update still reaches the buffer (conservative fallback)
(setq tp-rt-r1c-color "blue")
(with-current-buffer buf
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"blue")))
;; ... and the scan registered the buffer it found (learning)
(should (equal (tp-reactive-layer-buffers 'tp-rt-r1c-layer)
(list buf))))
(kill-buffer buf)))))
(ert-deftest tp-render-test-track-buffer-closes-string-insert-gap ()
"`tp-reactive-track-buffer' registers a buffer filled by string insert."
(tp-rt-with-cleanup (tp-rt-r1d-layer) (tp-rt-r1d-color)
(setq tp-rt-r1d-color "red")
(define-tp tp-rt-r1d-layer () '(face (:foreground $tp-rt-r1d-color)))
(let ((buf-a (generate-new-buffer " tp-rt-r1d-a"))
(buf-b (generate-new-buffer " tp-rt-r1d-b")))
(unwind-protect
(progn
(with-current-buffer buf-a
(insert "Hello")
(tp-set 1 6 'tp-rt-r1d-layer))
;; Inserting an already-propertized STRING bypasses the
;; registering buffer operations.
(let ((s (tp-set "Hi" 'tp-rt-r1d-layer)))
(with-current-buffer buf-b (insert s)))
(should-not (memq buf-b
(tp-reactive-layer-buffers 'tp-rt-r1d-layer)))
;; The layer is known, so buf-b is NOT updated (the gap) ...
(setq tp-rt-r1d-color "blue")
(with-current-buffer buf-b
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"red")))
;; ... until tp-reactive-track-buffer closes it.
(should (equal (with-current-buffer buf-b
(tp-reactive-track-buffer))
'(tp-rt-r1d-layer)))
(should (memq buf-b
(tp-reactive-layer-buffers 'tp-rt-r1d-layer)))
(setq tp-rt-r1d-color "green")
(with-current-buffer buf-b
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"green")))
(with-current-buffer buf-a
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"green"))))
(kill-buffer buf-a)
(kill-buffer buf-b)))))
;;; R2 (0.3.0): minimal-diff tp-text replacement
(ert-deftest tp-render-test-minimal-diff-point-in-prefix-stays ()
"Point in the common prefix survives a reactive text edit unmoved."
(tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
(setq tp-rt-r2-text "abcdef")
(define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
(with-temp-buffer
(insert "abcdef")
(tp-set 1 7 'tp-rt-r2-layer)
(goto-char 2) ; inside the common prefix "ab"
(setq tp-rt-r2-text "abXYef")
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"abXYef"))
(should (= (point) 2)))))
(ert-deftest tp-render-test-minimal-diff-point-in-suffix-stays ()
"Point in the common suffix stays glued to its character."
(tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
(setq tp-rt-r2-text "abcdef")
(define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
(with-temp-buffer
(insert "abcdef")
(tp-set 1 7 'tp-rt-r2-layer)
(goto-char 6) ; on the "f" of the suffix "ef"
;; Same-length edit: point must not move at all
(setq tp-rt-r2-text "abXYef")
(should (= (point) 6))
(should (eq (char-after) ?f))
;; Length-changing edit: point stays glued to its character
(setq tp-rt-r2-text "abXYZWef")
(should (= (point) 8))
(should (eq (char-after) ?f)))))
(ert-deftest tp-render-test-minimal-diff-point-inside-diff-clamps ()
"Point inside the differing span ends up at the edit start."
(tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
(setq tp-rt-r2-text "abcdef")
(define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
(with-temp-buffer
(insert "abcdef")
(tp-set 1 7 'tp-rt-r2-layer)
(goto-char 4) ; on "d", inside the "cd" -> "XY" span
(setq tp-rt-r2-text "abXYef")
(should (= (point) 3)))))
(ert-deftest tp-render-test-minimal-diff-markers-survive ()
"Markers in the unchanged prefix and suffix survive a text update."
(tp-rt-with-cleanup (tp-rt-r2m-layer) (tp-rt-r2m-text)
(setq tp-rt-r2m-text "abcdef")
(define-tp tp-rt-r2m-layer () '(tp-text $tp-rt-r2m-text))
(with-temp-buffer
(insert "abcdef")
(tp-set 1 7 'tp-rt-r2m-layer)
(let ((m-prefix (copy-marker 2)) ; on "b"
(m-suffix (copy-marker 6))) ; on "f"
(setq tp-rt-r2m-text "abXYZef") ; "cd" -> "XYZ", one char longer
(should (equal (buffer-substring-no-properties (point-min)
(point-max))
"abXYZef"))
(should (= (marker-position m-prefix) 2))
(should (eq (char-after m-prefix) ?b))
(should (= (marker-position m-suffix) 7))
(should (eq (char-after m-suffix) ?f))
(set-marker m-prefix nil)
(set-marker m-suffix nil)))))
;;; TXT-1: the suffix-boundary marker must track its character
(defun tp-rt--txt1-marker-after-edit (old new marker-offset)
"Run a minimal-diff replacement of OLD by NEW with a boundary marker.
Insert \"HEAD \" OLD \" TAIL\" in a temp buffer, tag OLD with a
tp-name, put an insertion-type-nil marker at OLD's start plus
MARKER-OFFSET, replace via `tp--replace-reactive-text-in-buffer' and
return (MARKER-POSITION CHAR-AT-MARKER ORIGINAL-CHAR)."
(with-temp-buffer
(insert "HEAD ")
(let ((m-start (point)))
(insert old " TAIL")
(put-text-property m-start (+ m-start (length old))
'tp-name 'tp-rt-txt1-layer)
(let* ((mpos (+ m-start marker-offset))
(mchar (char-after mpos))
(mk (copy-marker mpos)))
(tp--replace-reactive-text-in-buffer 'tp-rt-txt1-layer new nil)
(prog1 (list (marker-position mk) (char-after mk) mchar)
(set-marker mk nil))))))
(ert-deftest tp-render-test-minimal-diff-suffix-start-marker-tracks ()
"A marker on the FIRST character of the preserved suffix tracks it.
TXT-1: delete-then-insert collapsed such a marker onto the edit
start, stranding it before the inserted text; insert-then-delete
shifts it right with its character. Grow, same-length (the clearest
docstring violation) and shrink edits are all covered."
;; Grow: "0" -> "42"; marker on the space before "items" (offset 8).
(pcase-let ((`(,pos ,got ,want)
(tp-rt--txt1-marker-after-edit
"count: 0 items" "count: 42 items" 8)))
(should (eq got want))
(should (= pos 15))) ; 14 shifted right by 1
;; Same length: "0" -> "9"; the marker's correct position is
;; numerically unchanged.
(pcase-let ((`(,pos ,got ,want)
(tp-rt--txt1-marker-after-edit
"count: 0 items" "count: 9 items" 8)))
(should (eq got want))
(should (= pos 14)))
;; Shrink: "42" -> "0".
(pcase-let ((`(,pos ,got ,want)
(tp-rt--txt1-marker-after-edit
"count: 42 items" "count: 0 items" 9)))
(should (eq got want))
(should (= pos 14))))
(ert-deftest tp-render-test-minimal-diff-deleted-char-marker-at-edit-end ()
"A marker whose character was deleted ends at the END of the edit.
The documented side effect of inserting before deleting; previously
such markers collapsed to the edit start. Either way they stay
inside the replacement span."
;; "100" -> "42": marker on the middle "0" (strictly inside the
;; edited span) ends after the inserted "42".
(pcase-let ((`(,pos ,_got ,_want)
(tp-rt--txt1-marker-after-edit
"count: 100 items" "count: 42 items" 8)))
;; Edit span starts at buffer position 13 ("100"), insert "42":
;; the marker lands at the end of the inserted text.
(should (= pos 15))))
(ert-deftest tp-render-test-minimal-diff-suffix-marker-real-path ()
"The suffix-start marker tracks through a real setq-driven update."
(tp-rt-with-cleanup (tp-rt-r2s-layer) (tp-rt-r2s-text)
(setq tp-rt-r2s-text "count: 0 items")
(define-tp tp-rt-r2s-layer () '(tp-text $tp-rt-r2s-text))
(with-temp-buffer
(insert "count: 0 items")
(tp-set 1 15 'tp-rt-r2s-layer)
(let ((m (copy-marker 9))) ; the space before "items"
(setq tp-rt-r2s-text "count: 42 items")
(should (equal (buffer-substring-no-properties (point-min)
(point-max))
"count: 42 items"))
(should (eq (char-after m) ?\s))
(should (= (marker-position m) 10))
(set-marker m nil)))))
(ert-deftest tp-render-test-minimal-diff-identical-update-is-noop ()
"An identical-text reactive replacement leaves the buffer unmodified."
(tp-rt-with-cleanup (tp-rt-r2n-layer) (tp-rt-r2n-text)
(setq tp-rt-r2n-text "emacs")
(define-tp tp-rt-r2n-layer () '(face bold tp-text $tp-rt-r2n-text))
(with-temp-buffer
(insert "emacs")
(tp-set 1 6 'tp-rt-r2n-layer)
(set-buffer-modified-p nil)
(save-excursion
(tp--replace-reactive-text-in-buffer
'tp-rt-r2n-layer "emacs" (tp-layer-props 'tp-rt-r2n-layer t)))
;; No text edit and no property churn: the flag must stay clear
(should-not (buffer-modified-p))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"emacs"))
(should (eq (get-text-property 1 'face) 'bold)))))
;;; ARCH-4: the pending queue must survive neither reset nor errors
(defvar tp-rt-a4-face nil)
(defvar tp-rt-a4-color nil)
(ert-deftest tp-render-test-reactive-reset-clears-pending-queue ()
"tp-reactive-reset drops queued batch re-renders (ARCH-4).
Stranded entries would otherwise survive the reset and replay against
freshly (re)defined layers on the next flush."
(unwind-protect
(progn
(tp--queue-batch-update 'tp-rt-a4-ghost 'tp-rt-a4-ghost-var nil nil)
(should tp--batch-update-pending)
(tp-reactive-reset)
(should (null tp--batch-update-pending)))
(setq tp--batch-update-pending nil)))
(ert-deftest tp-render-test-error-escaping-update-flushes-nested-queue ()
"An error escaping a re-render cannot strand nested queued updates.
A modification hook that writes a second reactive variable and then
signals used to strand the nested entry in the global queue - the
flush tail sat outside any unwind-protect. The flush now runs as the
update unwinds, so the nested variable's re-render still lands and
the queue is drained (ARCH-4)."
(setq tp-rt-a4-face 'bold
tp-rt-a4-color "red")
(unwind-protect
(progn
(define-tp tp-rt-a4-layer-a () '(face $tp-rt-a4-face))
(define-tp tp-rt-a4-layer-b ()
'(face (:foreground $tp-rt-a4-color)))
(with-temp-buffer
(insert "Hello world")
(tp-set 1 6 'tp-rt-a4-layer-a)
(tp-set 7 12 'tp-rt-a4-layer-b)
(let ((armed t))
(add-hook 'before-change-functions
(lambda (_beg _end)
(when armed
(setq armed nil)
;; Nested reactive write from within the
;; re-render: goes to the global queue.
(setq tp-rt-a4-color "green")
(error "boom from modification hook")))
nil t)
(should-error (setq tp-rt-a4-face 'italic))
;; The nested entry was flushed on the way out, not
;; stranded...
(should (null tp--batch-update-pending))
;; ...and its re-render landed despite the error.
(should (equal (get-text-property 7 'face)
'(:foreground "green"))))))
(tp-undefine-layer 'tp-rt-a4-layer-a)
(tp-undefine-layer 'tp-rt-a4-layer-b)
(setq tp-rt-a4-face nil
tp-rt-a4-color nil
tp--batch-update-pending nil)))
;;; R3 (0.3.0): anonymous-layer garbage collection
(ert-deftest tp-render-test-gc-collects-unreferenced-anonymous-layer ()
"GC collects an anonymous layer whose only buffer was killed."
(setq tp-rt-r3a-color "red")
(let ((buf (generate-new-buffer " tp-rt-r3a"))
(name nil))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 '(face (:foreground $tp-rt-r3a-color)))
(setq name (get-text-property 1 'tp-name)))
(should name)
(should (assoc name tp-layer-alist))
(kill-buffer buf)
(should (memq name (tp-gc-anonymous-layers)))
(should-not (assoc name tp-layer-alist))
(should-not (rassq name tp--anonymous-layer-registry)))
(when (buffer-live-p buf) (kill-buffer buf))
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(setq tp-rt-r3a-color nil))))
(ert-deftest tp-render-test-gc-keeps-layer-still-displayed ()
"GC keeps an anonymous layer that a live buffer still shows."
(setq tp-rt-r3b-color "red")
(let ((buf (generate-new-buffer " tp-rt-r3b"))
(name nil))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 '(face (:foreground $tp-rt-r3b-color)))
(setq name (get-text-property 1 'tp-name)))
(should name)
(should-not (memq name (tp-gc-anonymous-layers)))
(should (assoc name tp-layer-alist)))
(kill-buffer buf)
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(setq tp-rt-r3b-color nil))))
(ert-deftest tp-render-test-gc-keeps-unknown-registry-layer ()
"GC keeps an anonymous layer whose registry state is `unknown'."
(setq tp-rt-r3c-color "red")
(let* ((s (tp-set "Hello" '(face (:foreground $tp-rt-r3c-color))))
(name (get-text-property 0 'tp-name s)))
(unwind-protect
(progn
(should name)
;; Applied to a string only: the registry knows nothing
(should (eq (tp-reactive-layer-buffers name) 'unknown))
(should-not (memq name (tp-gc-anonymous-layers)))
(should (assoc name tp-layer-alist)))
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(setq tp-rt-r3c-color nil))))
;;; GC-1: buried and hidden layers are ALIVE for GC and track-buffer
(defvar tp-rt-gc1-color nil)
(defvar tp-rt-gc1b-color nil)
(defvar tp-rt-gc1c-color nil)
(ert-deftest tp-render-test-gc-keeps-layer-buried-under-push ()
"GC keeps an anonymous layer buried below a pushed top layer.
The buried layer's tp-name lives inside `tp-layers' storage, not as a
direct property; the stack-aware liveness scan must still see it, and
reactivity must survive a later pop (GC-1)."
(setq tp-rt-gc1-color "blue")
(let ((buf (generate-new-buffer " tp-rt-gc1"))
(name nil))
(unwind-protect
(progn
(define-tp tp-rt-gc1-top () '(face bold))
(with-current-buffer buf
(insert "0123456789")
(tp-set 1 6 '(face (:foreground $tp-rt-gc1-color)))
(setq name (get-text-property 1 'tp-name))
(should name)
(tp-push-layer 1 6 'tp-rt-gc1-top)
;; Now buried: direct tp-name is the pushed top's.
(should (eq (get-text-property 1 'tp-name) 'tp-rt-gc1-top))
;; The buffer is live and still holds the layer: GC must
;; keep it.
(should-not (memq name (tp-gc-anonymous-layers)))
(should (assoc name tp-layer-alist))
;; Reactivity survives: pop and update.
(tp-pop-layer 1 6)
(setq tp-rt-gc1-color "red")
(should (equal (get-text-property 1 'face)
'(:foreground "red")))))
(kill-buffer buf)
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(tp-undefine-layer 'tp-rt-gc1-top)
(setq tp-rt-gc1-color nil))))
(ert-deftest tp-render-test-gc-keeps-hidden-layer ()
"GC keeps an anonymous layer hidden via tp-hide-layer.
An all-hidden run carries no direct tp-name at all; the layer lives
only inside `tp-layers' storage yet is queryable and re-showable, so
GC must not collect it and show+setq must still re-render (GC-1,
XM-02)."
(setq tp-rt-gc1b-color "green")
(let ((buf (generate-new-buffer " tp-rt-gc1b"))
(name nil))
(unwind-protect
(with-current-buffer buf
(insert "abcdefghij")
(tp-set 1 6 '(face (:foreground $tp-rt-gc1b-color)))
(setq name (get-text-property 1 'tp-name))
(should name)
(tp-hide-layer 1 6 name)
(should-not (get-text-property 1 'tp-name))
;; Live buffer still holds the hidden layer: keep it.
(should-not (memq name (tp-gc-anonymous-layers)))
(should (assoc name tp-layer-alist))
;; Show and update: reactivity must be intact.
(tp-show-layer 1 6 name)
(setq tp-rt-gc1b-color "purple")
(should (equal (get-text-property 1 'face)
'(:foreground "purple"))))
(kill-buffer buf)
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(setq tp-rt-gc1b-color nil))))
(ert-deftest tp-render-test-track-buffer-finds-buried-and-hidden-layers ()
"tp-reactive-track-buffer registers layers buried or hidden in storage.
A propertized string carrying a stacked (buried) layer and an
all-hidden string are inserted into a fresh buffer; the track scan
must register every layer name, not just the rendered top ones
\(GC-1, XM-04)."
(setq tp-rt-gc1c-color "gold")
(let ((buf (generate-new-buffer " tp-rt-gc1c"))
(name nil))
(unwind-protect
(progn
(define-tp tp-rt-gc1c-top () '(face bold))
(define-tp tp-rt-gc1c-hidden () '(face italic))
(let ((s (with-temp-buffer
(insert "trackme")
(tp-set 1 6 '(face (:foreground $tp-rt-gc1c-color)))
(setq name (get-text-property 1 'tp-name))
(tp-push-layer 1 6 'tp-rt-gc1c-top)
(buffer-string)))
(h (let ((h (copy-sequence " hideme")))
(tp-push-layer h 'tp-rt-gc1c-hidden)
(tp-hide-layer h 'tp-rt-gc1c-hidden)
h)))
(with-current-buffer buf
(insert s)
(insert h)
(let ((found (tp-reactive-track-buffer)))
;; Rendered top, buried layer, and all-hidden layer.
(should (memq 'tp-rt-gc1c-top found))
(should (memq name found))
(should (memq 'tp-rt-gc1c-hidden found)))
(should (memq buf (tp-reactive-layer-buffers name)))
(should (memq buf (tp-reactive-layer-buffers
'tp-rt-gc1c-hidden))))))
(kill-buffer buf)
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(tp-undefine-layer 'tp-rt-gc1c-top)
(tp-undefine-layer 'tp-rt-gc1c-hidden)
(setq tp-rt-gc1c-color nil))))
(provide 'tp-render-tests)
;;; tp-render-tests.el ends here

556
tp-render.el Normal file
View File

@ -0,0 +1,556 @@
;;; 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--update-layer-computed (layer-name override-alist)
"Update computed reactive variables for LAYER-NAME with OVERRIDE-ALIST.
Evaluates compute functions and updates the reactive variable values.
A compute function returning nil is a legitimate result and is
propagated; only computes that signal an error are skipped (see
`tp--compute-error').
Returns an updated override-alist with the new computed values."
(when-let ((computed (cdr (assoc layer-name tp-layer-computed))))
(dolist (comp computed)
(let* ((var-sym (car comp))
(compute-fn (cdr comp))
;; Temporarily bind variables to their new values from override-alist
;; before calling the compute function
(computed-val
(condition-case err
(cl-progv
(mapcar #'car override-alist)
(mapcar #'cdr override-alist)
(funcall compute-fn))
(error
(message "tp: compute error for %s.%s: %s"
layer-name var-sym err)
tp--compute-error))))
(unless (eq computed-val tp--compute-error)
;; Update the global variable
(set var-sym computed-val)
;; Add to override-alist for property resolution
(push (cons var-sym computed-val) override-alist)
;; Also update the layer properties if the computed var is used in props
(let ((current-props (cdr (assoc layer-name tp-layer-alist))))
(when current-props
(when-let ((all-reactive-props (tp--layer-reactive-props layer-name)))
(let ((resolved-props (tp--resolve-reactive-symbols
all-reactive-props override-alist)))
(when resolved-props
;; Deep-merge the resolved props into the current layer
;; props so sibling static attributes nested in plists
;; (e.g. a :background next to a reactive :foreground)
;; survive the update.
(tp--set-layer-props
layer-name
(tp--deep-merge-plist current-props resolved-props)))))))))))
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--merge-props-into-stack-entry (entry props)
"Return stack-storage plist ENTRY with its keys updated from PROPS.
Every key of PROPS except `tp-name' and `tp-layers' replaces ENTRY's
value for that key (or extends ENTRY when the key is new), so ENTRY's
`tp-hidden' flag and identity survive the update. Returns a fresh
plist; ENTRY itself is not modified."
(let ((new-entry (copy-sequence entry)))
(cl-loop for (key val) on props by #'cddr
unless (memq key '(tp-name tp-layers))
do (setq new-entry (plist-put new-entry key val)))
new-entry))
(defun tp--write-layer-through-stack-storage (layer-name 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. For every run of the current buffer whose `tp-layers'
holds an entry whose `tp-name' equals LAYER-NAME, replace the layer's
own keys in that entry with their values from PROPS - preserving the
entry's `tp-hidden' flag and stack position - and rewrite the run via
`tp--stack-props-to-list' / `tp--stack-build-props', which also
refreshes the topmost-visible render cache in full-stack storage
mode. Runs already storing the current values are left untouched, so
an update that changes nothing does not mark the buffer as modified."
(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* ((stack (tp--stack-props-to-list (text-properties-at pos)))
(new-stack
(mapcar (lambda (entry)
(if (equal (plist-get entry 'tp-name) layer-name)
(tp--merge-props-into-stack-entry entry 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)
"Update text regions that have LAYER-NAME applied.
Re-applies the layer's current properties to every region tagged with
the layer's `tp-name'. The layer's OWN property keys are replaced
with their current values (so refresh is idempotent: a face variable
changing from bold to italic yields italic, not (italic bold)), while
properties contributed by other sources are left untouched.
The update also writes through to `tp-layers' stack storage (see
`tp--write-layer-through-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 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; layer props are
re-resolved against it in each target buffer, so buffer-local
variable values are honored."
(let ((update-buffer
(lambda ()
(let ((props (tp--layer-render-props layer-name override-alist)))
(when props
(save-excursion
;; Callback for tp-search-map: replaces the layer's own
;; property keys on the matched region. Returns nil to
;; prevent tp-search-map from replacing the text.
(tp-search-map
(lambda (_text start end)
(cl-loop for (key val) on props by #'cddr
do (put-text-property start end key val))
nil)
'tp-name layer-name)
;; Write through to stack storage so hidden or buried
;; copies of the layer do not go stale (HID-1).
(tp--write-layer-through-stack-storage layer-name
props)))))))
(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

View File

@ -20,8 +20,7 @@
;; shuffled names and runs each test on its own. ;; shuffled names and runs each test on its own.
;; ;;
;; Usage (after loading tp and all *-tests.el files): ;; Usage (after loading tp and all *-tests.el files):
;; emacs -Q --batch -L . -L tests -l tp.el -l tp-tests.el ... \ ;; emacs -Q --batch -L . -l tp.el -l tp-tests.el ... -l tp-run-shuffled.el
;; -l tp-run-shuffled.el
;; or: make test-shuffled ;; or: make test-shuffled
;; ;;
;; The shuffle seed is printed; reproduce a failing order with ;; The shuffle seed is printed; reproduce a failing order with

View File

@ -127,7 +127,7 @@ left unchanged."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 6 11 '(marker t) str) (tp-set 6 11 '(marker t) str)
(should-error (tp-forward-do (lambda (txt) (concat (upcase txt) "XYZ")) (should-error (tp-forward-do (lambda (txt) (concat (upcase txt) "XYZ"))
'marker tp-any-value str)) 'marker nil str))
(should (equal (substring-no-properties str) "hello world")))) (should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-forward-do-longer-in-bounds-errors () (ert-deftest tp-search-test-forward-do-longer-in-bounds-errors ()
@ -136,7 +136,7 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str) (tp-set 0 5 '(marker t) str)
(should-error (tp-forward-do (lambda (txt) (concat txt txt)) (should-error (tp-forward-do (lambda (txt) (concat txt txt))
'marker tp-any-value str)) 'marker nil str))
(should (equal (substring-no-properties str) "hello world")))) (should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-backward-do-longer-replacement-errors () (ert-deftest tp-search-test-backward-do-longer-replacement-errors ()
@ -144,7 +144,7 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 6 11 '(marker t) str) (tp-set 6 11 '(marker t) str)
(should-error (tp-backward-do (lambda (txt) (concat (upcase txt) "12345")) (should-error (tp-backward-do (lambda (txt) (concat (upcase txt) "12345"))
'marker tp-any-value str)) 'marker nil str))
(should (equal (substring-no-properties str) "hello world")))) (should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-search-map-longer-replacement-errors () (ert-deftest tp-search-test-search-map-longer-replacement-errors ()
@ -152,15 +152,14 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 6 11 '(marker t) str) (tp-set 6 11 '(marker t) str)
(should-error (tp-search-map (lambda (txt) (concat (upcase txt) "!!!")) (should-error (tp-search-map (lambda (txt) (concat (upcase txt) "!!!"))
'marker tp-any-value str)) 'marker nil str))
(should (equal (substring-no-properties str) "hello world")))) (should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-forward-do-shorter-replacement-errors () (ert-deftest tp-search-test-forward-do-shorter-replacement-errors ()
"A shorter replacement errors instead of leaving residue (\"ABllo\")." "A shorter replacement errors instead of leaving residue (\"ABllo\")."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str) (tp-set 0 5 '(marker t) str)
(should-error (should-error (tp-forward-do (lambda (_txt) "AB") 'marker nil str))
(tp-forward-do (lambda (_txt) "AB") 'marker tp-any-value str))
(should (equal (substring-no-properties str) "hello world")))) (should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-search-map-same-length-string-ok () (ert-deftest tp-search-test-search-map-same-length-string-ok ()
@ -168,7 +167,7 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"."
(let ((str (copy-sequence "hello world hello"))) (let ((str (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) str) (tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str) (tp-set 12 17 '(marker t) str)
(should (= (tp-search-map #'upcase 'marker tp-any-value str) 2)) (should (= (tp-search-map #'upcase 'marker nil str) 2))
(should (equal (substring-no-properties str) "HELLO world HELLO")))) (should (equal (substring-no-properties str) "HELLO world HELLO"))))
;;; B43: -do shortfall is all-or-nothing on strings and buffers alike ;;; B43: -do shortfall is all-or-nothing on strings and buffers alike
@ -178,7 +177,7 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"."
The count of available matches is still returned." The count of available matches is still returned."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str) (tp-set 0 5 '(marker t) str)
(should (= (tp-forward-do #'upcase 'marker tp-any-value str 3) 1)) (should (= (tp-forward-do #'upcase 'marker nil str 3) 1))
(should (equal (substring-no-properties str) "hello world")))) (should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-forward-do-shortfall-buffer () (ert-deftest tp-search-test-forward-do-shortfall-buffer ()
@ -194,7 +193,7 @@ The count of available matches is still returned."
"tp-backward-do shortfall applies nothing on strings." "tp-backward-do shortfall applies nothing on strings."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 6 11 '(marker t) str) (tp-set 6 11 '(marker t) str)
(should (= (tp-backward-do #'upcase 'marker tp-any-value str 2) 1)) (should (= (tp-backward-do #'upcase 'marker nil str 2) 1))
(should (equal (substring-no-properties str) "hello world")))) (should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-forward-do-exact-count-applies () (ert-deftest tp-search-test-forward-do-exact-count-applies ()
@ -202,7 +201,7 @@ The count of available matches is still returned."
(let ((str (copy-sequence "aaa bbb aaa"))) (let ((str (copy-sequence "aaa bbb aaa")))
(tp-set 0 3 '(marker t) str) (tp-set 0 3 '(marker t) str)
(tp-set 8 11 '(marker t) str) (tp-set 8 11 '(marker t) str)
(should (= (tp-forward-do #'upcase 'marker tp-any-value str 2) 2)) (should (= (tp-forward-do #'upcase 'marker nil str 2) 2))
(should (equal (substring-no-properties str) "aaa bbb AAA")))) (should (equal (substring-no-properties str) "aaa bbb AAA"))))
(ert-deftest tp-search-test-forward-do-buffer-longer-replacement-grows () (ert-deftest tp-search-test-forward-do-buffer-longer-replacement-grows ()
@ -228,8 +227,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(put-text-property 1 4 'marker t)) (put-text-property 1 4 'marker t))
(with-temp-buffer (with-temp-buffer
(insert "current buffer text") (insert "current buffer text")
(let ((count (tp-search-map (let ((count (tp-search-map #'upcase 'marker nil target)))
#'upcase 'marker tp-any-value target)))
(should (= count 1))) (should (= count 1)))
;; Current buffer untouched. ;; Current buffer untouched.
(should (equal (buffer-string) "current buffer text"))) (should (equal (buffer-string) "current buffer text")))
@ -253,7 +251,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(insert "x") (insert "x")
(let ((seen nil)) (let ((seen nil))
(tp--search-do (lambda (match _obj) (push match seen)) (tp--search-do (lambda (match _obj) (push match seen))
'marker tp-any-value target) 'marker nil target)
(should (equal seen '((9 12 t))))))) (should (equal seen '((9 12 t)))))))
(kill-buffer target)))) (kill-buffer target))))
@ -266,8 +264,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(put-text-property 1 4 'marker t) (put-text-property 1 4 'marker t)
(put-text-property 5 8 'marker t) (put-text-property 5 8 'marker t)
(put-text-property 9 12 'marker t) (put-text-property 9 12 'marker t)
(let ((count (tp-search-map (let ((count (tp-search-map (lambda (_txt) "XXXXXX") 'marker nil nil)))
(lambda (_txt) "XXXXXX") 'marker tp-any-value nil)))
(should (= count 3)) (should (= count 3))
(should (equal (buffer-substring-no-properties (point-min) (point-max)) (should (equal (buffer-substring-no-properties (point-min) (point-max))
"XXXXXX XXXXXX XXXXXX"))))) "XXXXXX XXXXXX XXXXXX")))))
@ -279,7 +276,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(put-text-property 1 4 'marker t) (put-text-property 1 4 'marker t)
(put-text-property 5 8 'marker t) (put-text-property 5 8 'marker t)
(put-text-property 9 12 'marker t) (put-text-property 9 12 'marker t)
(tp-search-map (lambda (_txt) "-") 'marker tp-any-value nil) (tp-search-map (lambda (_txt) "-") 'marker nil nil)
(should (equal (buffer-substring-no-properties (point-min) (point-max)) (should (equal (buffer-substring-no-properties (point-min) (point-max))
"- - -")))) "- - -"))))
@ -294,7 +291,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(tp-search-map (lambda (txt _start _end idx) (tp-search-map (lambda (txt _start _end idx)
(push txt texts) (push txt texts)
(format "<%d>%s" idx txt)) (format "<%d>%s" idx txt))
'marker tp-any-value nil) 'marker nil nil)
;; Each callback received the intact matched text, not garbage ;; Each callback received the intact matched text, not garbage
;; from stale positions. ;; from stale positions.
(should (equal (nreverse texts) '("aaa" "bbb" "ccc"))) (should (equal (nreverse texts) '("aaa" "bbb" "ccc")))
@ -349,7 +346,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t face bold) str) (tp-set 0 5 '(marker t face bold) str)
(tp-search-map (lambda (txt) (substring-no-properties txt)) (tp-search-map (lambda (txt) (substring-no-properties txt))
'marker tp-any-value str) 'marker nil str)
(should (null (text-properties-at 0 str))) (should (null (text-properties-at 0 str)))
(should (equal (substring-no-properties str) "hello world")))) (should (equal (substring-no-properties str) "hello world"))))
@ -360,18 +357,17 @@ with predicate t, where VALUE nil matches property-absent runs."
(tp-search-map (lambda (txt) (tp-search-map (lambda (txt)
(remove-text-properties 0 (length txt) '(face nil) txt) (remove-text-properties 0 (length txt) '(face nil) txt)
txt) txt)
'marker tp-any-value str) 'marker nil str)
(should (null (get-text-property 0 'face str))) (should (null (get-text-property 0 'face str)))
(should (eq (get-text-property 0 'marker str) t)))) (should (eq (get-text-property 0 'marker str) t))))
;;; Guard: nil return still means "no replacement". ;;; Guard: nil return still means "no replacement" (used by tp-render)
(ert-deftest tp-search-test-search-map-nil-return-no-replacement () (ert-deftest tp-search-test-search-map-nil-return-no-replacement ()
"A callback returning nil leaves text and properties untouched." "A callback returning nil leaves text and properties untouched."
(let ((str (copy-sequence "hello world"))) (let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t face bold) str) (tp-set 0 5 '(marker t face bold) str)
(let ((count (tp-search-map (let ((count (tp-search-map (lambda (_txt) nil) 'marker nil str)))
(lambda (_txt) nil) 'marker tp-any-value str)))
(should (= count 1)) (should (= count 1))
(should (equal (substring-no-properties str) "hello world")) (should (equal (substring-no-properties str) "hello world"))
(should (eq (get-text-property 0 'face str) 'bold))))) (should (eq (get-text-property 0 'face str) 'bold)))))
@ -494,7 +490,7 @@ with predicate t, where VALUE nil matches property-absent runs."
"A function PREDICATE selects buffer matches by property value." "A function PREDICATE selects buffer matches by property value."
(tp-search-tests--with-lvl-buffer (tp-search-tests--with-lvl-buffer
(goto-char (point-min)) (goto-char (point-min))
(let ((m (tp-forward 'lvl tp-any-value nil 1 (let ((m (tp-forward 'lvl nil nil 1
(lambda (_ v) (and (numberp v) (> v 1)))))) (lambda (_ v) (and (numberp v) (> v 1))))))
(should m) (should m)
(should (equal (list (prop-match-beginning m) (should (equal (list (prop-match-beginning m)
@ -508,7 +504,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(tp-set 0 3 '(lvl 1) s) (tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s) (tp-set 3 6 '(lvl 2) s)
(tp-set 6 9 '(lvl 3) s) (tp-set 6 9 '(lvl 3) s)
(should (equal (tp-forward 'lvl tp-any-value s 2 (should (equal (tp-forward 'lvl nil s 2
(lambda (_ v) (and (numberp v) (> v 1)))) (lambda (_ v) (and (numberp v) (> v 1))))
'((3 6 2) (6 9 3)))))) '((3 6 2) (6 9 3))))))
@ -516,7 +512,7 @@ with predicate t, where VALUE nil matches property-absent runs."
"tp-backward accepts the same function PREDICATE as tp-forward." "tp-backward accepts the same function PREDICATE as tp-forward."
(tp-search-tests--with-lvl-buffer (tp-search-tests--with-lvl-buffer
(goto-char (point-max)) (goto-char (point-max))
(let ((m (tp-backward 'lvl tp-any-value nil 1 (let ((m (tp-backward 'lvl nil nil 1
(lambda (_ v) (and (numberp v) (< v 3)))))) (lambda (_ v) (and (numberp v) (< v 3))))))
(should m) (should m)
(should (equal (list (prop-match-beginning m) (should (equal (list (prop-match-beginning m)
@ -530,7 +526,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(tp-set 0 3 '(lvl 1) s) (tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s) (tp-set 3 6 '(lvl 2) s)
(tp-set 6 9 '(lvl 3) s) (tp-set 6 9 '(lvl 3) s)
(should (equal (tp-backward 'lvl tp-any-value s 2 (should (equal (tp-backward 'lvl nil s 2
(lambda (_ v) (and (numberp v) (> v 1)))) (lambda (_ v) (and (numberp v) (> v 1))))
'((6 9 3) (3 6 2)))))) '((6 9 3) (3 6 2))))))
@ -581,8 +577,7 @@ value changes when a non-nil predicate is given."
(let ((s (copy-sequence "abcdef"))) (let ((s (copy-sequence "abcdef")))
(tp-set 0 3 '(lvl 1) s) (tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s) (tp-set 3 6 '(lvl 2) s)
(should (equal (tp-forward 'lvl tp-any-value s 5 (should (equal (tp-forward 'lvl nil s 5 (lambda (_ v) (numberp v)))
(lambda (_ v) (numberp v)))
'((0 3 1) (3 6 2)))))) '((0 3 1) (3 6 2))))))
(ert-deftest tp-search-test-forward-do-predicate () (ert-deftest tp-search-test-forward-do-predicate ()
@ -590,7 +585,7 @@ value changes when a non-nil predicate is given."
(let ((s (copy-sequence "abc def"))) (let ((s (copy-sequence "abc def")))
(tp-set 0 3 '(lvl 1) s) (tp-set 0 3 '(lvl 1) s)
(tp-set 4 7 '(lvl 2) s) (tp-set 4 7 '(lvl 2) s)
(should (= (tp-forward-do #'upcase 'lvl tp-any-value s 1 nil nil (should (= (tp-forward-do #'upcase 'lvl nil s 1 nil nil
(lambda (_ v) (eq v 2))) (lambda (_ v) (eq v 2)))
1)) 1))
(should (equal (substring-no-properties s) "abc DEF")))) (should (equal (substring-no-properties s) "abc DEF"))))
@ -601,8 +596,7 @@ value changes when a non-nil predicate is given."
(insert "abc def") (insert "abc def")
(put-text-property 1 4 'lvl 1) (put-text-property 1 4 'lvl 1)
(put-text-property 5 8 'lvl 2) (put-text-property 5 8 'lvl 2)
(should (= (tp-backward-do (should (= (tp-backward-do #'upcase 'lvl nil (current-buffer) 1 nil nil
#'upcase 'lvl tp-any-value (current-buffer) 1 nil nil
(lambda (_ v) (eq v 1))) (lambda (_ v) (eq v 1)))
1)) 1))
(should (equal (buffer-substring-no-properties (point-min) (point-max)) (should (equal (buffer-substring-no-properties (point-min) (point-max))
@ -616,6 +610,80 @@ value changes when a non-nil predicate is given."
(should (= (tp-forward-do #'upcase 'lvl 2 s) 1)) (should (= (tp-forward-do #'upcase 'lvl 2 s) 1))
(should (equal (substring-no-properties s) "abc DEF")))) (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 ;;; SRC-1: reversed START/END bounds are swapped on both object paths
(ert-deftest tp-search-test-reversed-bounds-string-swaps () (ert-deftest tp-search-test-reversed-bounds-string-swaps ()
@ -717,64 +785,5 @@ the nil-PREDICATE default keeps the primitive's not-`equal' matching."
;; Fewer matches than N: return what exists, not nil. ;; Fewer matches than N: return what exists, not nil.
(should (equal (tp-forward 'k 'v s 5) '((0 2 v) (4 6 v)))))) (should (equal (tp-forward 'k 'v s 5) '((0 2 v) (4 6 v))))))
;;; Stage 2 canonical match storage
(ert-deftest tp-search-test-internal-matches-are-canonical ()
"The shared scanner returns canonical matches in native coordinates."
(let ((str (copy-sequence "abcde")))
(put-text-property 1 3 'state nil str)
(put-text-property 3 5 'state 'ready str)
(let ((matches (tp--property-matches
str 0 5 'state tp-any-value nil)))
(should (= (length matches) 2))
(should (seq-every-p #'tp--match-p matches))
(should (equal (mapcar #'tp--match-to-list matches)
'((1 3 nil) (3 5 ready)))))))
(ert-deftest tp-search-test-public-search-adapts-canonical-matches ()
"Public search retains list returns while its scanner stays canonical."
(let ((str (copy-sequence "abcde")))
(put-text-property 0 2 'state 1 str)
(put-text-property 3 5 'state 2 str)
(should (equal (tp-search str 'state)
'((0 2 1) (3 5 2))))
(should (equal (tp-forward 'state tp-any-value str 2)
'((0 2 1) (3 5 2))))))
;;; TP-A04: omitted values and explicit nil are distinct
(ert-deftest tp-search-test-explicit-nil-is-presence-aware-for-strings ()
"Explicit nil matches only a present nil property, never a non-nil run."
(let ((s (copy-sequence "abc")))
(put-text-property 0 1 'p 'x s)
(put-text-property 2 3 'p nil s)
(should (equal (tp-forward 'p nil s) '((2 3 nil))))))
(ert-deftest tp-search-test-omitted-value-matches-present-values ()
"Omitting VALUE matches any present direct value, including nil."
(let ((s (copy-sequence "abc")))
(put-text-property 0 1 'p 'x s)
(put-text-property 2 3 'p nil s)
(should (equal (tp-search s 'p)
'((0 1 x) (2 3 nil))))))
(ert-deftest tp-search-test-explicit-nil-string-buffer-parity ()
"String and buffer paths both match the present nil-valued run."
(let ((s (copy-sequence "abc")))
(put-text-property 0 1 'p 'x s)
(put-text-property 2 3 'p nil s)
(should (equal (tp-forward 'p nil s) '((2 3 nil))))
(with-temp-buffer
(insert "abc")
(put-text-property 1 2 'p 'x)
(put-text-property 3 4 'p nil)
(goto-char (point-min))
(let ((match (tp-forward 'p nil)))
(should match)
(should (equal (list (prop-match-beginning match)
(prop-match-end match)
(prop-match-value match))
'(3 4 nil)))))))
(provide 'tp-search-tests) (provide 'tp-search-tests)
;;; tp-search-tests.el ends here ;;; tp-search-tests.el ends here

View File

@ -20,26 +20,37 @@
(require 'cl-lib) (require 'cl-lib)
(require 'text-property-search) (require 'text-property-search)
(require 'tp-core) (require 'tp-core)
(require 'tp-reactive)
(require 'tp-layer) (require 'tp-layer)
(require 'tp-ops) (require 'tp-ops)
(defconst tp-any-value (make-symbol "tp-any-value") (defun tp--search-register-layer-buffer (props object)
"Unique wildcard used by tp property-search APIs. "Record OBJECT in the reactive buffer registry for PROPS's layers.
Omitting VALUE selects this sentinel automatically. Pass the variable When OBJECT is a buffer or nil (the current buffer) and the applied
`tp-any-value' explicitly when a later positional argument is needed PROPS carry a `tp-name' - directly, or inside a `tp-layers' entry
and any present direct value should match. An explicit nil VALUE is from a group application - register that buffer under each layer name
therefore available for exact, presence-aware nil matching.") 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 (defun tp--pattern-apply-single (pattern properties apply-fn object literal
&optional start end subexp) &optional start end subexp)
"Apply PROPERTIES with APPLY-FN to matches of single PATTERN in OBJECT. "Apply APPLY-FN to matches of single PATTERN in OBJECT.
When LITERAL is non-nil, PATTERN is matched literally; otherwise it When LITERAL is non-nil, PATTERN is matched literally; otherwise it
is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for
each match. each match.
START and END restrict matching to the [START, END) portion of START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds 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 behavior, now uniform across object types). Matching behaves as if
OBJECT consisted only of that portion (the buffer path narrows, the OBJECT consisted only of that portion (the buffer path narrows, the
string path matches against the substring), so no match crosses the string path matches against the substring), so no match crosses the
@ -130,7 +141,7 @@ position past them, so the search always terminates."
(defun tp--pattern-apply (pattern properties apply-fn object literal (defun tp--pattern-apply (pattern properties apply-fn object literal
&optional start end subexp) &optional start end subexp)
"Apply PROPERTIES with APPLY-FN to matches of PATTERN. "Apply APPLY-FN to matches of PATTERN (one pattern or a list).
When LITERAL is non-nil, patterns are matched literally; otherwise When LITERAL is non-nil, patterns are matched literally; otherwise
they are regexps. APPLY-FN is called with (START END PROPS OBJECT) they are regexps. APPLY-FN is called with (START END PROPS OBJECT)
for each match. for each match.
@ -162,14 +173,14 @@ For buffers, returns list of regions."
(defun tp--match-apply-single (pattern properties apply-fn object (defun tp--match-apply-single (pattern properties apply-fn object
&optional start end) &optional start end)
"Apply PROPERTIES with APPLY-FN to literal matches of PATTERN in OBJECT. "Apply APPLY-FN to literal matches of single PATTERN in OBJECT.
START and END restrict matching to [START, END) in native coordinates. START and END restrict matching to [START, END) in native coordinates.
For strings, returns a new string with properties applied (non-destructive). For strings, returns a new string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions." For buffers, modifies in-place and returns list of regions."
(tp--pattern-apply-single pattern properties apply-fn object t start end)) (tp--pattern-apply-single pattern properties apply-fn object t start end))
(defun tp--match-apply (pattern properties apply-fn &optional object start end) (defun tp--match-apply (pattern properties apply-fn &optional object start end)
"Apply PROPERTIES with APPLY-FN to matches of PATTERN. "Internal function to apply APPLY-FN to matches of PATTERN.
PATTERN can be a string or a list of strings (multiple patterns). PATTERN can be a string or a list of strings (multiple patterns).
When PATTERN is a list, each element is a pattern to match. When PATTERN is a list, each element is a pattern to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match. APPLY-FN is called with (START END PROPS OBJECT) for each match.
@ -180,7 +191,7 @@ For buffers, returns list of regions."
(defun tp--regexp-apply-single (pattern properties apply-fn object (defun tp--regexp-apply-single (pattern properties apply-fn object
&optional start end subexp) &optional start end subexp)
"Apply PROPERTIES with APPLY-FN to regexp matches of PATTERN in OBJECT. "Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
APPLY-FN is called with (START END PROPS OBJECT) for each match. APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target. coordinates; SUBEXP names a capture group to target.
@ -191,7 +202,7 @@ For buffers, modifies in-place and returns list of regions."
(defun tp--regexp-apply (pattern properties apply-fn (defun tp--regexp-apply (pattern properties apply-fn
&optional object start end subexp) &optional object start end subexp)
"Apply PROPERTIES with APPLY-FN to regexp matches of PATTERN. "Internal function to apply APPLY-FN to regexp matches of PATTERN.
PATTERN can be a string (single regexp) or a list of strings (multiple regexps). 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. When PATTERN is a list, each element is a regexp to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match. APPLY-FN is called with (START END PROPS OBJECT) for each match.
@ -201,6 +212,40 @@ For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions." For buffers, returns list of regions."
(tp--pattern-apply pattern properties apply-fn object nil start end subexp)) (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) (defun tp-match-set (pattern plist &optional object start end)
"Set properties on all occurrences of PATTERN. "Set properties on all occurrences of PATTERN.
@ -222,7 +267,7 @@ Returns:
- For strings: a NEW string with properties applied (the original - For strings: a NEW string with properties applied (the original
string is not modified) string is not modified)
- For buffers: list of (START . END) pairs for all matches." - For buffers: list of (START . END) pairs for all matches."
(tp--match-apply pattern (tp--prepare-direct-properties plist) #'tp-set object (tp--match-apply pattern (tp--ensure-props plist) #'tp-set object
start end)) start end))
(defun tp-match-reset (pattern plist &optional object start end) (defun tp-match-reset (pattern plist &optional object start end)
@ -245,10 +290,22 @@ Unlike `tp-match-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified). For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END) For buffers, modifies in-place and returns list of (START . END)
regions." regions."
(tp--match-apply pattern (tp--prepare-direct-properties plist) (tp--match-apply pattern (tp--ensure-props plist)
#'tp--reset-apply #'tp--reset-apply
object start end)) 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) (defun tp-match-add (pattern plist &optional object start end)
"Add/update properties on all occurrences of PATTERN. "Add/update properties on all occurrences of PATTERN.
@ -269,7 +326,7 @@ Unlike `tp-match-set', this deeply merges nested properties.
For strings, returns a NEW string (original is not modified). For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END) For buffers, modifies in-place and returns list of (START . END)
regions." regions."
(tp--match-apply pattern (tp--prepare-direct-properties plist) #'tp--deep-merge-apply (tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
object start end)) object start end))
(defun tp-regexp-set (pattern plist &optional object start end subexp) (defun tp-regexp-set (pattern plist &optional object start end subexp)
@ -298,7 +355,7 @@ Returns:
- For strings: a NEW string with properties applied (the original - For strings: a NEW string with properties applied (the original
string is not modified) string is not modified)
- For buffers: list of (START . END) pairs for all matches." - For buffers: list of (START . END) pairs for all matches."
(tp--regexp-apply pattern (tp--prepare-direct-properties plist) #'tp-set object (tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object
start end subexp)) start end subexp))
(defun tp-regexp-reset (pattern plist &optional object start end subexp) (defun tp-regexp-reset (pattern plist &optional object start end subexp)
@ -325,7 +382,7 @@ Unlike `tp-regexp-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified). For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END) For buffers, modifies in-place and returns list of (START . END)
regions." regions."
(tp--regexp-apply pattern (tp--prepare-direct-properties plist) (tp--regexp-apply pattern (tp--ensure-props plist)
#'tp--reset-apply #'tp--reset-apply
object start end subexp)) object start end subexp))
@ -353,7 +410,7 @@ Unlike `tp-regexp-set', this deeply merges nested properties.
For strings, returns a NEW string (original is not modified). For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END) For buffers, modifies in-place and returns list of (START . END)
regions." regions."
(tp--regexp-apply pattern (tp--prepare-direct-properties plist) #'tp--deep-merge-apply (tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
object start end subexp)) object start end subexp))
(defun tp-search-forward (property &optional value predicate not-current) (defun tp-search-forward (property &optional value predicate not-current)
@ -394,127 +451,88 @@ PREDICATE follows the convention tp uses for
`text-property-search-forward': nil and t both mean the values must `text-property-search-forward': nil and t both mean the values must
be `equal' (tp's 0.2.0 symmetric matching contract); a function is be `equal' (tp's 0.2.0 symmetric matching contract); a function is
called with VALUE and PROP-VALUE and matches when it returns called with VALUE and PROP-VALUE and matches when it returns
non-nil. `tp-any-value' matches every PROP-VALUE." non-nil."
(if (functionp predicate) (if (functionp predicate)
(funcall predicate value prop-value) (funcall predicate value prop-value)
(or (eq value tp-any-value) (equal value prop-value)))
(equal value prop-value))))
(defun tp--property-matches (object start end property value predicate) (defun tp--string-property-matches (string property value predicate)
"Collect direct PROPERTY matches in OBJECT between START and END. "Collect PROPERTY runs of STRING matching VALUE under PREDICATE.
Each result is a canonical `tp--match'. A run is eligible only when Returns a list of (START END VALUE) lists with 0-based positions. A
PROPERTY is present in `text-properties-at', so an explicit nil value run is a maximal stretch with one `eq' PROPERTY value, and it matches
is distinct from absence. Boundaries caused only by unrelated when `tp--property-match-p' accepts that value. Adjacent matching
properties are joined back into one PROPERTY run." runs with different values stay separate entries, mirroring how
(let ((obj (or object (current-buffer))) `text-property-search-forward' ends a match where the property value
(pos start) changes when a non-nil predicate is given."
(results nil)) (let ((results nil))
(while (< pos end) (tp--map-intervals
(let* ((next (or (next-property-change pos object end) end)) string 0 (length string)
(presence (tp--presence-at pos property object)) (lambda (beg end val)
(prop-value (tp--presence-value presence))) (when (tp--property-match-p value val predicate)
(when (and (tp--presence-present-p presence) (push (list beg end val) results))
(tp--property-match-p value prop-value predicate)) nil)
(let ((previous (car results))) property)
(if (and previous
(= (tp--native-range-end
(tp--match-range previous))
pos)
(equal (tp--match-value previous) prop-value))
(setf (tp--native-range-end
(tp--match-range previous))
next)
(push (tp--make-match
(tp--make-native-range
obj (tp--object-kind obj) pos next)
property prop-value)
results))))
(setq pos next)))
(nreverse results))) (nreverse results)))
(defun tp--property-search-backward (property value (defun tp--property-search-backward (property value
&optional predicate not-current) &optional predicate not-current)
"Search backward for the previous region where PROPERTY matches VALUE. "Search backward for the previous region where PROPERTY matches VALUE.
Only direct PROPERTY runs are candidates. VALUE and PREDICATE follow
`tp--property-match-p'. NOT-CURRENT skips the run containing point." This is the backward mirror of (text-property-search-forward PROPERTY
(unless (bobp) VALUE t): by default a region matches when its PROPERTY value is
(let* ((origin (point)) `equal' to VALUE. It deliberately does not call
(matches (nreverse `text-property-search-backward' with predicate t, because that
(tp--property-matches primitive's non-default-predicate branch skips every other property
(current-buffer) (point-min) (point-max) run when non-matching runs intervene (observed through Emacs 30.2),
property value predicate))) silently missing valid matches.
(found
(seq-find PREDICATE follows `tp--property-match-p': nil and t both mean `equal'
(lambda (match) matching (the 0.2.0 contract); a function is called with VALUE and
(and (< (tp--native-range-start (tp--match-range match)) the region's PROPERTY value. When NOT-CURRENT is non-nil, the
origin) matching region containing point (or ending exactly at point) is
(not (and not-current skipped, mirroring the primitive's NOT-CURRENT argument.
(<= (tp--native-range-start
(tp--match-range match)) If a matching region is found, move point to its beginning and
origin) return a `prop-match' object whose end is clipped to the starting
(>= (tp--native-range-end point (matching the primitive's behavior when point starts inside a
(tp--match-range match)) matching region). Otherwise return nil and leave point alone."
origin))))) (if (bobp)
matches))) nil
(let ((origin (point))
(found nil))
;; Walk PROPERTY runs before point; remember the last matching one.
;; tp--map-intervals clips the run containing ORIGIN to end there.
(tp--map-intervals
(current-buffer) (point-min) origin
(lambda (ibeg iend val)
(when (and (tp--property-match-p value val predicate)
;; With NOT-CURRENT, the run point is inside (or
;; just after) is not a candidate.
(not (and not-current (= iend origin))))
(setq found (list ibeg iend val)))
nil)
property)
(when found (when found
(let ((range (tp--match-range found))) (goto-char (car found))
(goto-char (tp--native-range-start range)) (make-prop-match :beginning (car found)
(setf (tp--native-range-end range) :end (cadr found)
(min origin (tp--native-range-end range))) :value (caddr found))))))
(tp--match-to-prop-match found))))))
(defun tp--property-search-forward (property value predicate not-current) (defun tp-forward (property &optional value object n predicate not-current)
"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
(lambda (match)
(and (> (tp--native-range-end (tp--match-range match))
origin)
(not (and not-current
(<= (tp--native-range-start
(tp--match-range match))
origin)
(< origin
(tp--native-range-end
(tp--match-range match)))))))
(tp--property-matches
(current-buffer) (point-min) (point-max)
property value predicate))))
(when found
(let ((range (tp--match-range found)))
(goto-char (tp--native-range-end range))
(setf (tp--native-range-start range)
(max origin (tp--native-range-start range)))
(tp--match-to-prop-match found)))))
(defun tp--search-result-value (object start end property value)
"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
:value value :public-return :matches))
(matches (tp--property-matches
(tp--native-range-object range)
(tp--native-range-start range)
(tp--native-range-end range)
property value nil)))
(tp--result-public-value
(tp--make-result :request request :matches matches))))
(cl-defun tp-forward
(property &optional (value tp-any-value) object n predicate not-current)
"Search forward N times for text with PROPERTY. "Search forward N times for text with PROPERTY.
Omitted VALUE matches any present direct value; explicit nil matches a VALUE is the optional value to match; N is the number of searches,
present nil value. Pass `tp-any-value' when later positional defaulting to 1.
arguments are needed with wildcard matching. N is the number of
searches, defaulting to 1.
OBJECT can be a buffer or string; nil defaults to current buffer. OBJECT can be a buffer or string; nil defaults to current buffer.
PREDICATE customizes matching: nil (the default) and t both keep the PREDICATE customizes matching: nil (the default) and t both keep the
`equal' contract; a function is called with VALUE and the run value. 0.2.0 contract where a region matches when its PROPERTY value is
NOT-CURRENT skips a matching buffer run containing point. `equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil. For buffers it
is passed to `text-property-search-forward'.
NOT-CURRENT is passed to `text-property-search-forward' and, when
non-nil, makes the search skip a matching region containing point.
It only applies to the buffer path; strings have no point, so it is
ignored there.
For buffers, each search starts from point and each successful one For buffers, each search starts from point and each successful one
moves point to the end of its matched region; the return value is moves point to the end of its matched region; the return value is
@ -528,30 +546,30 @@ the N-th match alone. Fewer than N matches return however many
exist." exist."
(let ((count (or n 1))) (let ((count (or n 1)))
(cond (cond
;; String object - use tp-search (or the predicate-aware matcher)
((stringp object) ((stringp object)
(let ((matches (tp--property-matches (let ((matches (if (functionp predicate)
object 0 (length object) property value predicate))) (tp--string-property-matches object property
(mapcar #'tp--match-to-list (seq-take matches count)))) value predicate)
(tp-search object property value))))
(seq-take matches count)))
;; Buffer or nil
(t (t
(let ((result nil) (let ((result nil)
(buf (or object (current-buffer)))) (buf (or object (current-buffer))))
(tp-with-current-buffer buf (tp-with-current-buffer buf
(catch 'done
(dotimes (_ count) (dotimes (_ count)
(setq result (tp--property-search-forward (setq result (text-property-search-forward
property value predicate not-current)) property value
(unless result (if (functionp predicate) predicate t)
(throw 'done nil))))) not-current))))
result))))) result)))))
(cl-defun tp-backward (defun tp-backward (property &optional value object n predicate not-current)
(property &optional (value tp-any-value) object n predicate not-current)
"Search backward N times for text with PROPERTY. "Search backward N times for text with PROPERTY.
N is the number of searches, defaulting to 1. N is the number of searches, defaulting to 1.
Omitted VALUE matches any present direct value; explicit nil matches a VALUE is the optional value to match.
present nil value. Pass `tp-any-value' when later positional
arguments are needed with wildcard matching.
OBJECT can be a buffer or string; nil defaults to current buffer. OBJECT can be a buffer or string; nil defaults to current buffer.
PREDICATE customizes matching: nil (the default) and t both keep the PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is 0.2.0 contract where a region matches when its PROPERTY value is
@ -566,37 +584,40 @@ For buffers, returns the prop-match object from the last successful search.
For strings, returns a list of (START END VALUE) for the last N matches For strings, returns a list of (START END VALUE) for the last N matches
in reverse order (from end to start). in reverse order (from end to start).
Uses the same presence-aware run scanner for strings and buffers." Uses `tp--property-search-backward' for buffers and `tp-search' (or
the predicate-aware matcher) for strings."
(let ((count (or n 1))) (let ((count (or n 1)))
(cond (cond
;; String object - use tp-search and reverse
((stringp object) ((stringp object)
(let ((matches (let ((matches (nreverse (if (functionp predicate)
(nreverse (tp--string-property-matches
(tp--property-matches object property value predicate)
object 0 (length object) property value predicate)))) (tp-search object property value)))))
(mapcar #'tp--match-to-list (seq-take matches count)))) (seq-take matches count)))
;; Buffer or nil
(t (t
(let ((result nil) (let ((result nil)
(buf (or object (current-buffer)))) (buf (or object (current-buffer))))
(tp-with-current-buffer buf (tp-with-current-buffer buf
(catch 'done
(dotimes (_ count) (dotimes (_ count)
;; `equal' matching by default, mirroring the predicate t
;; that `tp-forward' passes. The previous code used the
;; default nil predicate, which matches values NOT `equal'
;; to VALUE and so inverted the match when VALUE was
;; non-nil.
(setq result (tp--property-search-backward (setq result (tp--property-search-backward
property value predicate not-current)) property value predicate not-current))))
(unless result
(throw 'done nil)))))
result))))) result)))))
(cl-defun tp--forward-do (defun tp--forward-do (function property &optional value object times
(function property &optional (value tp-any-value) object times
start end predicate not-current) start end predicate not-current)
"Internal: search forward TIMES for PROPERTY, call FUNCTION on last match. "Internal: search forward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings) FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT. and OBJECT.
TIMES is the number of searches, defaulting to 1. TIMES is the number of searches, defaulting to 1.
Omitted VALUE matches any present value; explicit nil matches a VALUE is the optional value to match.
present nil value.
OBJECT can be a buffer or string; nil defaults to current buffer. OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end. START and END define the search range; defaults are object start and end.
PREDICATE and NOT-CURRENT are passed to each underlying search (see PREDICATE and NOT-CURRENT are passed to each underlying search (see
@ -611,10 +632,15 @@ Returns the number of matches found (at most TIMES)."
((stringp object) ((stringp object)
(let* ((start-pos (or start 0)) (let* ((start-pos (or start 0))
(end-pos (or end (length object))) (end-pos (or end (length object)))
(all-matches (tp--property-matches (all-matches (if (functionp predicate)
object start-pos end-pos (tp--string-property-matches object property
property value predicate)) value predicate)
(matches (seq-take all-matches count))) (tp-search object property value)))
(filtered-matches (seq-filter (lambda (m)
(and (>= (car m) start-pos)
(<= (cadr m) end-pos)))
all-matches))
(matches (seq-take filtered-matches count)))
;; All-or-nothing, mirroring the buffer path: FUNCTION targets ;; All-or-nothing, mirroring the buffer path: FUNCTION targets
;; the TIMES-th match specifically, so when fewer matches exist ;; the TIMES-th match specifically, so when fewer matches exist
;; acting on a different one would hit the wrong target. ;; acting on a different one would hit the wrong target.
@ -631,8 +657,10 @@ Returns the number of matches found (at most TIMES)."
(save-excursion (save-excursion
(goto-char search-start) (goto-char search-start)
(dotimes (i count) (dotimes (i count)
(when-let* ((match (tp--property-search-forward (when-let ((match (text-property-search-forward
property value predicate not-current))) property value
(if (functionp predicate) predicate t)
not-current)))
(when (<= (prop-match-end match) search-end) (when (<= (prop-match-end match) search-end)
(when (= i (1- count)) (when (= i (1- count))
(funcall function match buf)) (funcall function match buf))
@ -649,20 +677,16 @@ prop-match struct (buffer matches). ARITY is the precomputed
FUNCTION accepts a 4th argument - (TEXT START END IDX). FUNCTION accepts a 4th argument - (TEXT START END IDX).
If FUNCTION returns a string, it replaces the matched text: If FUNCTION returns a string, it replaces the matched text:
- For string OBJ the replacement happens in place and must have the - For string OBJ the replacement happens in place; since strings have
same length as the match. A different length signals an error. fixed length, a longer replacement is truncated to the match length
The replacement's text properties (including their absence) are and a shorter one only replaces that portion. The replacement's
copied onto the replaced portion. text properties (including their absence) are copied onto the
replaced portion.
- For buffer OBJ the match is replaced via `delete-region' + `insert' - For buffer OBJ the match is replaced via `delete-region' + `insert'
\(the buffer may grow or shrink). \(the buffer may grow or shrink).
Any non-string return value leaves OBJ untouched." Any non-string return value leaves OBJ untouched."
(let* ((range (when (tp--match-p match) (tp--match-range match))) (let* ((m-start (if (listp match) (car match) (prop-match-beginning match)))
(m-start (cond (range (tp--native-range-start range)) (m-end (if (listp match) (cadr match) (prop-match-end match)))
((listp match) (car match))
(t (prop-match-beginning match))))
(m-end (cond (range (tp--native-range-end range))
((listp match) (cadr match))
(t (prop-match-end match))))
(text (if (stringp obj) (text (if (stringp obj)
(substring obj m-start m-end) (substring obj m-start m-end)
(buffer-substring m-start m-end))) (buffer-substring m-start m-end)))
@ -687,7 +711,7 @@ Any non-string return value leaves OBJ untouched."
;; (truncation or residue); reject it clearly instead. ;; (truncation or residue); reject it clearly instead.
(let ((len (- m-end m-start))) (let ((len (- m-end m-start)))
(unless (= (length new-text) len) (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 \ strings cannot change length in place -- use a buffer OBJECT for \
length-changing replacements" new-text (length new-text) len)) length-changing replacements" new-text (length new-text) len))
(store-substring obj m-start new-text) (store-substring obj m-start new-text)
@ -711,8 +735,7 @@ length-changing replacements" new-text (length new-text) len))
(goto-char m-start) (goto-char m-start)
(insert new-text))))))) (insert new-text)))))))
(cl-defun tp-forward-do (defun tp-forward-do (function property &optional value object times
(function property &optional (value tp-any-value) object times
start end predicate not-current) start end predicate not-current)
"Search forward TIMES times for PROPERTY; apply FUNCTION at the Nth match. "Search forward TIMES times for PROPERTY; apply FUNCTION at the Nth match.
@ -725,10 +748,9 @@ FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
START and END are the positions of the match. The return value of FUNCTION START and END are the positions of the match. The return value of FUNCTION
replaces the matched text in the string or buffer. replaces the matched text in the string or buffer.
PROPERTY is the text property to search for. Omitted VALUE matches any PROPERTY is the text property to search for.
present value; explicit nil matches a present nil value. Pass VALUE is the optional value to match; nil means search for PROPERTY without
`tp-any-value' when later positional arguments are needed with matching value.
wildcard matching.
OBJECT can be a buffer or string; nil defaults to current buffer. OBJECT can be a buffer or string; nil defaults to current buffer.
TIMES is the number of searches, defaulting to 1. The function searches TIMES is the number of searches, defaulting to 1. The function searches
TIMES times but only applies FUNCTION to the last (Nth) match found. TIMES times but only applies FUNCTION to the last (Nth) match found.
@ -743,41 +765,39 @@ path (strings have no point).
Returns the number of successful matches. Returns the number of successful matches.
Note: For string objects, the replacement text must have the same Note: For string objects, the replacement text must have the same length
length as the original matched text, since strings have fixed length as the original matched text, since strings have fixed length in Emacs.
in Emacs; a different length signals an error. Buffer replacements If the replacement is shorter, only that portion will be replaced.
may grow or shrink. If the replacement is longer, it will be truncated.
Example: Example:
;; Upcase only the last (2nd) match ;; Upcase only the last (2nd) match
(setq my-string (copy-sequence \"hello world hello\")) (setq my-string (copy-sequence \"hello world hello\"))
(tp-set 0 5 \\='(marker t) my-string) (tp-set 0 5 \\='(marker t) my-string)
(tp-set 12 17 \\='(marker t) my-string) (tp-set 12 17 \\='(marker t) my-string)
(tp-forward-do #\\='upcase \\='marker tp-any-value my-string 2) (tp-forward-do #\\='upcase \\='marker nil my-string 2)
;; => \"hello world HELLO\" - only the 2nd match is upcased ;; => \"hello world HELLO\" - only the 2nd match is upcased
;; Use start and end positions in function ;; Use start and end positions in function
(tp-forward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt)) (tp-forward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt))
\\='marker tp-any-value my-string 2) \\='marker nil my-string 2)
;; Search within a range ;; Search within a range
(tp-forward-do #\\='upcase \\='marker tp-any-value my-string 1 0 10)" (tp-forward-do #\\='upcase \\='marker nil my-string 1 0 10)"
(let ((arity (func-arity function))) (let ((arity (func-arity function)))
(tp--forward-do (tp--forward-do
(lambda (match obj) (lambda (match obj)
(tp--replace-match-text function arity match obj)) (tp--replace-match-text function arity match obj))
property value object times start end predicate not-current))) property value object times start end predicate not-current)))
(cl-defun tp--backward-do (defun tp--backward-do (function property &optional value object times
(function property &optional (value tp-any-value) object times
start end predicate not-current) start end predicate not-current)
"Internal: search backward TIMES for PROPERTY, call FUNCTION on last match. "Internal: search backward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings) FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT. and OBJECT.
TIMES is the number of searches, defaulting to 1. TIMES is the number of searches, defaulting to 1.
Omitted VALUE matches any present value; explicit nil matches a VALUE is the optional value to match.
present nil value.
OBJECT can be a buffer or string; nil defaults to current buffer. OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end. START and END define the search range; defaults are object start and end.
PREDICATE and NOT-CURRENT are passed to each underlying search (see PREDICATE and NOT-CURRENT are passed to each underlying search (see
@ -792,10 +812,16 @@ Returns the number of matches found (at most TIMES)."
((stringp object) ((stringp object)
(let* ((start-pos (or start 0)) (let* ((start-pos (or start 0))
(end-pos (or end (length object))) (end-pos (or end (length object)))
(all-matches (tp--property-matches (all-matches (if (functionp predicate)
object start-pos end-pos (tp--string-property-matches object property
property value predicate)) value predicate)
(matches (seq-take (nreverse all-matches) count))) (tp-search object property value)))
(filtered-matches
(seq-filter (lambda (m)
(and (>= (car m) start-pos)
(<= (cadr m) end-pos)))
all-matches))
(matches (seq-take (nreverse filtered-matches) count)))
;; All-or-nothing; see tp--forward-do. ;; All-or-nothing; see tp--forward-do.
(when (= (length matches) count) (when (= (length matches) count)
(funcall function (car (last matches)) object)) (funcall function (car (last matches)) object))
@ -812,7 +838,7 @@ Returns the number of matches found (at most TIMES)."
(dotimes (i count) (dotimes (i count)
;; `equal' matching by default, same as tp--forward-do's ;; `equal' matching by default, same as tp--forward-do's
;; predicate t. ;; predicate t.
(when-let* ((match (tp--property-search-backward (when-let ((match (tp--property-search-backward
property value predicate not-current))) property value predicate not-current)))
(when (>= (prop-match-beginning match) search-start) (when (>= (prop-match-beginning match) search-start)
(when (= i (1- count)) (when (= i (1- count))
@ -820,8 +846,7 @@ Returns the number of matches found (at most TIMES)."
(cl-incf matches))))))) (cl-incf matches)))))))
matches))))) matches)))))
(cl-defun tp-backward-do (defun tp-backward-do (function property &optional value object times
(function property &optional (value tp-any-value) object times
start end predicate not-current) start end predicate not-current)
"Search backward TIMES times for PROPERTY; apply FUNCTION at the Nth match. "Search backward TIMES times for PROPERTY; apply FUNCTION at the Nth match.
@ -834,10 +859,9 @@ FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
START and END are the positions of the match. The return value of FUNCTION START and END are the positions of the match. The return value of FUNCTION
replaces the matched text in the string or buffer. replaces the matched text in the string or buffer.
PROPERTY is the text property to search for. Omitted VALUE matches any PROPERTY is the text property to search for.
present value; explicit nil matches a present nil value. Pass VALUE is the optional value to match; nil means search for PROPERTY without
`tp-any-value' when later positional arguments are needed with matching value.
wildcard matching.
OBJECT can be a buffer or string; nil defaults to current buffer. OBJECT can be a buffer or string; nil defaults to current buffer.
TIMES is the number of searches, defaulting to 1. The function searches TIMES is the number of searches, defaulting to 1. The function searches
TIMES times but only applies FUNCTION to the last (Nth) match found. TIMES times but only applies FUNCTION to the last (Nth) match found.
@ -852,37 +876,33 @@ on each underlying search; it only applies to the buffer path
Returns the number of successful matches. Returns the number of successful matches.
Note: For string objects, the replacement text must have the same Note: For string objects, the replacement text must have the same length
length as the original matched text, since strings have fixed length as the original matched text, since strings have fixed length in Emacs.
in Emacs; a different length signals an error. Buffer replacements If the replacement is shorter, only that portion will be replaced.
may grow or shrink. If the replacement is longer, it will be truncated.
Example: Example:
;; Upcase only the last (2nd) match ;; Upcase only the last (2nd) match
(setq my-string (copy-sequence \"hello world hello\")) (setq my-string (copy-sequence \"hello world hello\"))
(tp-set 0 5 \\='(marker t) my-string) (tp-set 0 5 \\='(marker t) my-string)
(tp-set 12 17 \\='(marker t) my-string) (tp-set 12 17 \\='(marker t) my-string)
(tp-backward-do #\\='upcase \\='marker tp-any-value my-string 2) (tp-backward-do #\\='upcase \\='marker nil my-string 2)
;; => \"HELLO world hello\" - only the 2nd (last) match is upcased ;; => \"HELLO world hello\" - only the 2nd (last) match is upcased
;; Use start and end positions in function ;; Use start and end positions in function
(tp-backward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt)) (tp-backward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt))
\\='marker tp-any-value my-string 2) \\='marker nil my-string 2)
;; Search within a range ;; Search within a range
(tp-backward-do #\\='upcase \\='marker tp-any-value my-string 1 0 10)" (tp-backward-do #\\='upcase \\='marker nil my-string 1 0 10)"
(let ((arity (func-arity function))) (let ((arity (func-arity function)))
(tp--backward-do (tp--backward-do
(lambda (match obj) (lambda (match obj)
(tp--replace-match-text function arity match obj)) (tp--replace-match-text function arity match obj))
property value object times start end predicate not-current))) property value object times start end predicate not-current)))
(cl-defun tp-search (defun tp-search (start-or-string
(start-or-string &optional end-or-property property-or-value value object)
&optional end-or-property
(property-or-value tp-any-value property-value-supplied-p)
(value tp-any-value value-supplied-p)
object)
"Search for all text with PROPERTY in a buffer/string range or entire string. "Search for all text with PROPERTY in a buffer/string range or entire string.
This function supports two calling conventions: This function supports two calling conventions:
@ -893,37 +913,94 @@ This function supports two calling conventions:
2. Entire string: 2. Entire string:
(tp-search STRING PROPERTY &optional VALUE) (tp-search STRING PROPERTY &optional VALUE)
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. Returns a list of (START END VALUE) lists for all matching regions.
Each element contains the start position, end position, and property value." Each element contains the start position, end position, and property value."
(cond (cond
;; Entire string form: (tp-search string property &optional value)
((stringp start-or-string) ((stringp start-or-string)
(tp--search-result-value (let* ((str start-or-string)
start-or-string 0 (length start-or-string) end-or-property (property end-or-property)
(if property-value-supplied-p property-or-value tp-any-value))) (value property-or-value)
(results nil)
(pos 0)
(len (length str)))
(while (< pos len)
(let* ((props (text-properties-at pos str))
(has-prop (plist-member props property))
(prop-val (plist-get props property)))
(if (and has-prop
(or (null value)
(equal prop-val value)))
;; Find the extent of this property
(let ((next-change
(or (next-single-property-change
pos property str len)
len)))
(push (list pos next-change prop-val) results)
(setq pos next-change))
;; No match, move to next change
(setq pos (or (next-single-property-change
pos property str len)
len)))))
(nreverse results)))
;; Buffer/string region form: (tp-search start end property &optional value object)
((numberp start-or-string) ((numberp start-or-string)
(tp--search-result-value (let* ((start start-or-string)
(or object (current-buffer)) start-or-string end-or-property (end end-or-property)
property-or-value (property property-or-value)
(if value-supplied-p value tp-any-value))) (value value)
(obj (or object (current-buffer)))
(results nil)
(pos start))
(if (stringp obj)
;; String object
(while (< pos end)
(let* ((props (text-properties-at pos obj))
(has-prop (plist-member props property))
(prop-val (plist-get props property)))
(if (and has-prop
(or (null value)
(equal prop-val value)))
(let ((next-change
(or (next-single-property-change
pos property obj end)
end)))
(push (list pos next-change prop-val) results)
(setq pos next-change))
(setq pos (or (next-single-property-change
pos property obj end)
end)))))
;; Buffer object
(tp-with-current-buffer obj
(while (< pos end)
(let* ((props (text-properties-at pos))
(has-prop (plist-member props property))
(prop-val (plist-get props property)))
(if (and has-prop
(or (null value)
(equal prop-val value)))
(let ((next-change
(or (next-single-property-change
pos property nil end)
end)))
(push (list pos next-change prop-val) results)
(setq pos next-change))
(setq pos (or (next-single-property-change
pos property nil end)
end)))))))
(nreverse results)))
(t (error "Invalid first argument: %S" start-or-string)))) (t (error "Invalid first argument: %S" start-or-string))))
(cl-defun tp--search-do (defun tp--search-do (function property &optional value object start end)
(function property &optional (value tp-any-value) object start end)
"Internal: Execute FUNCTION on all matches of PROPERTY. "Internal: Execute FUNCTION on all matches of PROPERTY.
Signature: (tp--search-do FUNCTION PROPERTY &optional VALUE OBJECT START END) Signature: (tp--search-do FUNCTION PROPERTY &optional VALUE OBJECT START END)
FUNCTION receives two arguments: the match, as a (START END VALUE) FUNCTION receives two arguments: the match, as a (START END VALUE)
list, and OBJECT. list, and OBJECT.
PROPERTY is the text property to search for. Omitted VALUE matches any PROPERTY is the text property to search for.
present value; explicit nil matches a present nil value. VALUE is the optional value to match; nil means search for PROPERTY
without matching value.
OBJECT can be a buffer or string; nil defaults to current buffer. OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end. START and END define the search range; defaults are object start and end.
@ -935,32 +1012,31 @@ FUNCTION may safely change the length of earlier matches (e.g. replace
their text): later matches still receive their up-to-date positions." their text): later matches still receive their up-to-date positions."
(let ((obj (or object (current-buffer)))) (let ((obj (or object (current-buffer))))
(if (stringp obj) (if (stringp obj)
(let* ((s (or start 0)) (let* ((all-matches (tp-search obj property value))
(s (or start 0))
(e (or end (length obj))) (e (or end (length obj)))
(matches (tp--property-matches (filtered-matches
obj s e property value nil))) (seq-filter (lambda (m)
(dolist (match matches) (and (>= (car m) s)
(funcall function (tp--match-to-list match) obj)) (<= (cadr m) e)))
(length matches)) all-matches)))
(dolist (match filtered-matches)
(funcall function match obj))
(length filtered-matches))
;; Buffer: do all the work with OBJ current, and track match ;; Buffer: do all the work with OBJ current, and track match
;; positions with markers so length-changing edits made by ;; positions with markers so length-changing edits made by
;; FUNCTION on earlier matches don't invalidate later positions. ;; FUNCTION on earlier matches don't invalidate later positions.
(tp-with-current-buffer obj (tp-with-current-buffer obj
(let* ((s (or start (point-min))) (let* ((s (or start (point-min)))
(e (or end (point-max))) (e (or end (point-max)))
(matches (tp--property-matches (matches (tp-search s e property value obj))
obj s e property value nil))
(marked (mapcar (lambda (m) (marked (mapcar (lambda (m)
;; Begin markers advance on insertion at ;; Begin markers advance on insertion at
;; their position so adjacent runs stay ;; their position so adjacent runs stay
;; correct after a replacement. ;; correct after a replacement.
(let ((range (tp--match-range m))) (list (copy-marker (car m) t)
(list (copy-marker (copy-marker (cadr m))
(tp--native-range-start range) (caddr m)))
t)
(copy-marker
(tp--native-range-end range))
(tp--match-value m))))
matches))) matches)))
(unwind-protect (unwind-protect
(dolist (m marked) (dolist (m marked)
@ -974,8 +1050,7 @@ their text): later matches still receive their up-to-date positions."
(set-marker (cadr m) nil))) (set-marker (cadr m) nil)))
(length marked)))))) (length marked))))))
(cl-defun tp-search-map (defun tp-search-map (function property &optional value object start end)
(function property &optional (value tp-any-value) object start end)
"Apply FUNCTION to all matches of PROPERTY in OBJECT. "Apply FUNCTION to all matches of PROPERTY in OBJECT.
Signature: (tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END) Signature: (tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END)
@ -990,35 +1065,33 @@ FUNCTION can either:
- Modify the text properties of the argument and return it - Modify the text properties of the argument and return it
- Return nil to skip replacement - Return nil to skip replacement
PROPERTY is the text property to search for. Omitted VALUE matches any PROPERTY is the text property to search for.
present value; explicit nil matches a present nil value. Pass VALUE is the optional value to match; nil means search for PROPERTY without
`tp-any-value' when later positional arguments are needed with matching value.
wildcard matching.
OBJECT can be a buffer or string; nil defaults to current buffer. OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end. START and END define the search range; defaults are object start and end.
Returns the number of matches processed. Returns the number of matches processed.
Note: For string objects, replacement text must have the same length Note: For string objects, replacement text must have the same length
as the original matched text, since strings have fixed length in as the original matched text, since strings have fixed length in Emacs.
Emacs; a different length signals an error. Buffer replacements may If the replacement is shorter, only that portion will be replaced.
grow or shrink. If the replacement is longer, it will be truncated.
Example: Example:
;; Upcase all matched text ;; Upcase all matched text
(tp-search-map #\\='upcase \\='marker tp-any-value my-string) (tp-search-map #\\='upcase \\='marker nil my-string)
;; Add properties to matched text ;; Add properties to matched text
(tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold)) (tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold)) \\='marker nil str)
\\='marker tp-any-value str)
;; Use start, end, and index ;; Use start, end, and index
(tp-search-map (lambda (txt start end idx) (tp-search-map (lambda (txt start end idx)
(format \"[%d:%d-%d]%s\" idx start end txt)) (format \"[%d:%d-%d]%s\" idx start end txt))
\\='marker tp-any-value str) \\='marker nil str)
;; Search within a range ;; Search within a range
(tp-search-map #\\='upcase \\='marker tp-any-value my-string 0 10)" (tp-search-map #\\='upcase \\='marker nil my-string 0 10)"
(let ((idx 0) (let ((idx 0)
(arity (func-arity function))) (arity (func-arity function)))
(tp--search-do (tp--search-do

1264
tp-stack-tests.el Normal file

File diff suppressed because it is too large Load Diff

1143
tp-stack.el Normal file

File diff suppressed because it is too large Load Diff

View File

@ -1,372 +0,0 @@
;;; tp-style.el --- Native text property policies -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Native Emacs text-property policies, named direct declarations, and
;; explicit computed value sources. This module does not implement selectors,
;; stylesheets, CSS precedence, inheritance, or custom properties.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(define-error 'tp-property-error "TP property error")
(define-error 'tp-invalid-property-policy
"Invalid TP property policy" 'tp-property-error)
(define-error 'tp-invalid-declaration
"Invalid TP direct declaration" 'tp-property-error)
(cl-defstruct (tp-property-policy
(:constructor tp--make-property-policy))
"Policy governing one namespaced direct text property."
id normalizer validator equality merge projector)
(cl-defstruct (tp--computed-source (:constructor tp--make-computed-source))
function)
(cl-defstruct (tp-paint-slot (:constructor tp--make-paint-slot))
"Stable named-face address for one mutable paint contribution."
face spec installed-p)
(defvar tp--paint-slot-counter 0
"Monotonic id source for private paint-slot faces.")
(defconst tp--property-policy-option-keys
'(:normalizer :validator :equality :merge :projector)
"Accepted property policy option keys.")
(defvar tp--property-policies (make-hash-table :test #'eq)
"Registered property policies by namespaced id.")
(defvar tp--property-policy-order nil
"Property ids in stable registration order.")
(defvar tp--named-styles (make-hash-table :test #'eq)
"Named direct declaration sets.")
(defun tp--paint-slot-face-spec (spec)
"Return validated face SPEC for a paint slot."
(unless (and (listp spec) (zerop (% (length spec) 2))
(cl-loop for key in spec by #'cddr always (keywordp key)))
(signal 'tp-invalid-declaration (list :paint-slot spec)))
(copy-tree spec))
;;;###autoload
(defun tp-paint-slot-create (spec)
"Create a stable paint slot initialized from anonymous face SPEC."
(let* ((face (intern (format "tp-paint-slot-%d"
(cl-incf tp--paint-slot-counter))))
(slot (tp--make-paint-slot
:face face :spec (tp--paint-slot-face-spec spec)
:installed-p nil)))
(make-face face)
slot))
;;;###autoload
(defun tp-paint-slot-update (slot spec)
"Update SLOT to anonymous face SPEC without changing its address."
(unless (tp-paint-slot-p slot)
(signal 'wrong-type-argument (list 'tp-paint-slot-p slot)))
(let* ((face (tp-paint-slot-face slot))
(next (tp--paint-slot-face-spec spec))
(previous (tp-paint-slot-spec slot)))
(condition-case err
(progn
(face-spec-reset-face face)
(when next
(face-spec-set face `((t ,next))))
(setf (tp-paint-slot-spec slot) next))
(error
(face-spec-reset-face face)
(when previous
(face-spec-set face `((t ,previous))))
(signal (car err) (cdr err))))
slot))
(defun tp-paint-slot-apply-updates (buffer updates)
"Apply `(SLOT . SPEC)' UPDATES to BUFFER in one face-remap swap.
Return a rollback journal containing the previous buffer map and slot specs."
(unless (buffer-live-p buffer)
(signal 'wrong-type-argument (list 'buffer-live-p buffer)))
(let ((normalized
(mapcar
(lambda (entry)
(unless (tp-paint-slot-p (car entry))
(signal 'wrong-type-argument
(list 'tp-paint-slot-p (car entry))))
(cons (car entry) (tp--paint-slot-face-spec (cdr entry))))
updates))
slot-journal next)
(with-current-buffer buffer
(setq next (copy-tree face-remapping-alist))
(dolist (entry normalized)
(let* ((slot (car entry))
(spec (cdr entry))
(face (tp-paint-slot-face slot)))
(push (list slot (copy-tree (tp-paint-slot-spec slot))
(tp-paint-slot-installed-p slot))
slot-journal)
(setq next (assq-delete-all face next))
(when spec
(push (list face spec) next))
(setf (tp-paint-slot-spec slot) spec
(tp-paint-slot-installed-p slot) t)))
(prog1
(list :buffer buffer
:face-remapping-alist (copy-tree face-remapping-alist)
:slot-specs (nreverse slot-journal))
(setq-local face-remapping-alist next)))))
(defun tp-paint-slot-rollback-updates (journal)
"Restore paint slots from reverse-safe JOURNAL."
(when-let* ((buffer (plist-get journal :buffer)))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq-local face-remapping-alist
(copy-tree
(plist-get journal :face-remapping-alist))))))
(dolist (entry (reverse (plist-get journal :slot-specs)))
(setf (tp-paint-slot-spec (nth 0 entry)) (copy-tree (nth 1 entry))
(tp-paint-slot-installed-p (nth 0 entry)) (nth 2 entry)))
nil)
(defun tp--canonical-property-id-p (id)
"Return non-nil when ID is a namespaced property symbol."
(and (symbolp id)
(let ((name (symbol-name id)))
(and (string-match-p "/" name)
(not (string-prefix-p "/" name))
(not (string-suffix-p "/" name))))))
(defun tp--declaration-list-p (declarations)
"Return non-nil when DECLARATIONS is an even property/value list."
(and (listp declarations) (zerop (% (length declarations) 2))))
(defun tp--policy-options-valid-p (options)
"Return non-nil when OPTIONS is a supported property policy plist."
(and (listp options)
(zerop (% (length options) 2))
(cl-loop for key in options by #'cddr
always (memq key tp--property-policy-option-keys))))
(defun tp--policy-option (options key fallback)
"Return KEY from OPTIONS when present, otherwise FALLBACK."
(if (plist-member options key) (plist-get options key) fallback))
(defun tp--validate-policy-functions (options)
"Validate callable property policy fields in OPTIONS."
(dolist (key tp--property-policy-option-keys)
(let ((value (plist-get options key)))
(unless (or (null value) (functionp value))
(signal 'tp-invalid-property-policy (list key value))))))
(defun tp--build-property-policy (id options)
"Build and validate a property policy for ID from OPTIONS."
(unless (and (tp--canonical-property-id-p id)
(tp--policy-options-valid-p options))
(signal 'tp-invalid-property-policy (list :property id options)))
(tp--validate-policy-functions options)
(tp--make-property-policy
:id id
:normalizer (tp--policy-option options :normalizer #'identity)
:validator (tp--policy-option options :validator (lambda (_value) t))
:equality (tp--policy-option options :equality #'equal)
:merge (tp--policy-option options :merge (lambda (_old new) new))
:projector (plist-get options :projector)))
;;;###autoload
(defun tp-define-property-policy (id &rest options)
"Atomically register namespaced property ID using policy OPTIONS.
OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
(let ((policy (tp--build-property-policy id options)))
(unless (gethash id tp--property-policies)
(setq tp--property-policy-order
(append tp--property-policy-order (list id))))
(puthash id policy tp--property-policies)
policy))
(defun tp-property-policy (id)
"Return the registered property policy for ID, or nil."
(gethash id tp--property-policies))
(defun tp-text-property-id (property)
"Return the canonical `text/' policy id for Emacs PROPERTY."
(unless (symbolp property)
(signal 'wrong-type-argument (list 'symbolp property)))
(intern (format "text/%s" property)))
(defun tp--text-property-merge-function (property)
"Return the contribution merge function for Emacs PROPERTY."
(if (memq property tp-face-properties)
#'tp--merge-face-values
(lambda (_old new) new)))
(defun tp--native-keymap-equal-p (left right)
"Compare native snapshots LEFT and RIGHT, retaining commands and menu order."
(let ((seen (make-hash-table :test #'eq)))
(cl-labels
((bindings (map)
(let ((local (copy-sequence (if (symbolp map)
(indirect-function map) map)))
entries)
(set-keymap-parent local nil)
(map-keymap (lambda (key value) (push (cons key value) entries)) local)
entries))
(same (old new)
(cond
((eq old new) t)
((memq new (gethash old seen)) t)
((and (keymapp old) (keymapp new))
(puthash old (cons new (gethash old seen)) seen)
(and (equal-including-properties (keymap-prompt old)
(keymap-prompt new))
(same (bindings old) (bindings new))
(same (keymap-parent old) (keymap-parent new))))
((or (functionp old) (functionp new)) nil)
((and (consp old) (consp new))
(puthash old (cons new (gethash old seen)) seen)
(and (same (car old) (car new)) (same (cdr old) (cdr new))))
((and (vectorp old) (vectorp new) (= (length old) (length new)))
(puthash old (cons new (gethash old seen)) seen)
(cl-loop for index below (length old)
always (same (aref old index) (aref new index))))
(t (equal old new)))))
(same left right))))
(defun tp--native-property-value-equal-p (left right)
"Compare native values LEFT and RIGHT while preserving callable identity."
(cond
((and (keymapp left) (keymapp right)) (tp--native-keymap-equal-p left right))
((or (functionp left) (functionp right)) (eq left right))
(t (equal left right))))
(defun tp-register-text-property (property)
"Register and return a direct policy for Emacs PROPERTY."
(let ((id (tp-text-property-id property)))
(or (tp-property-policy id)
(tp-define-property-policy
id :equality #'tp--native-property-value-equal-p
:merge (tp--text-property-merge-function property)
:projector (lambda (value) (list property value))))))
(defun tp--register-default-text-properties ()
"Register policies for TP's known native Emacs properties."
(dolist (property tp--builtin-text-properties)
(tp-register-text-property property)))
(defun tp-text-declarations (properties)
"Convert raw Emacs PROPERTIES to namespaced direct declarations."
(unless (tp--declaration-list-p properties)
(signal 'tp-invalid-declaration (list :text-properties properties)))
(cl-loop for (property value) on properties by #'cddr
append (list (tp-property-policy-id
(tp-register-text-property property))
(tp--copy-property-value value))))
;;;###autoload
(defun tp-computed (function)
"Return an explicit computed value source wrapping FUNCTION."
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(tp--make-computed-source :function function))
(defun tp-computed-p (value)
"Return non-nil when VALUE is an explicit computed source."
(tp--computed-source-p value))
;;;###autoload
(defun tp-resolve-value (value &optional _property _subject)
"Resolve VALUE only when it is an explicit `tp-computed' source.
Ordinary function values remain literal. PROPERTY and SUBJECT are accepted
so this function can be passed directly as a consumer value resolver."
(if (tp--computed-source-p value)
(funcall (tp--computed-source-function value))
value))
(defun tp--validate-direct-property (property)
"Return PROPERTY when it has a registered direct policy."
(unless (tp-property-policy property)
(signal 'tp-invalid-declaration (list :unknown-property property)))
property)
(defun tp--copy-direct-declarations (declarations)
"Validate and defensively copy direct DECLARATIONS."
(unless (tp--declaration-list-p declarations)
(signal 'tp-invalid-declaration (list :declarations declarations)))
(cl-loop for (property value) on declarations by #'cddr
do (tp--validate-direct-property property)
append (list property (tp--copy-property-value value))))
;;;###autoload
(defun tp-merge-declarations (&rest declaration-groups)
"Merge direct DECLARATION-GROUPS without CSS interpretation.
Later values replace earlier values for the same registered property. An
explicit nil remains present and is distinct from an absent declaration."
(let (result)
(dolist (declarations declaration-groups result)
(cl-loop for (property value)
on (tp--copy-direct-declarations declarations) by #'cddr
do (setq result (plist-put result property value))))))
;;;###autoload
(defun tp-define-style (name declarations)
"Define named direct style NAME from DECLARATIONS and return NAME."
(unless (symbolp name)
(signal 'tp-invalid-declaration (list :style-name name)))
(puthash name (tp-merge-declarations declarations) tp--named-styles)
name)
(defun tp-style-declarations (name)
"Return a defensive copy of named direct style NAME declarations."
(when-let* ((declarations (gethash name tp--named-styles)))
(tp--copy-property-value declarations)))
(defun tp-undefine-style (name)
"Remove named direct style NAME and return nil."
(remhash name tp--named-styles)
nil)
(defun tp--normalized-policy-value (policy value)
"Resolve, normalize, and validate VALUE using POLICY."
(let ((normalized
(funcall (tp-property-policy-normalizer policy)
(tp-resolve-value value (tp-property-policy-id policy)))))
(unless (funcall (tp-property-policy-validator policy) normalized)
(signal 'tp-invalid-declaration
(list :property (tp-property-policy-id policy)
:value normalized)))
normalized))
(defun tp--project-policy-value (policy value)
"Project VALUE through POLICY into direct Emacs text properties."
(when-let* ((projector (tp-property-policy-projector policy)))
(let ((projected (funcall projector value)))
(unless (tp--declaration-list-p projected)
(signal 'tp-invalid-declaration
(list :projection (tp-property-policy-id policy) projected)))
projected)))
(defun tp--project-declarations (declarations)
"Project namespaced direct DECLARATIONS into Emacs text properties."
(let (result)
(cl-loop for (property source)
on (tp--copy-direct-declarations declarations) by #'cddr
for policy = (tp-property-policy property)
for value = (tp--normalized-policy-value policy source)
for projected = (tp--project-policy-value policy value)
when projected
do (setq result (tp--deep-merge-plist result projected)))
result))
(defun tp--project-text-declarations (declarations)
"Project native text property DECLARATIONS through direct policies."
(tp--project-declarations (tp-text-declarations declarations)))
(tp--register-default-text-properties)
(provide 'tp-style)
;;; tp-style.el ends here

File diff suppressed because it is too large Load Diff

4153
tp-tests.el Normal file

File diff suppressed because it is too large Load Diff

View File

@ -1,822 +0,0 @@
;;; tp-transaction.el --- Structured publication transaction contracts -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; Author: Geekinney (kinneyzhang666@gmail.com)
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;;; Commentary:
;; Internal immutable artifacts and one-shot state machines for TP publication.
;; The package-owned entry-stage capability stored in a batch candidate drives
;; publication. This module never edits a buffer itself: `tp-reactive' drives
;; the state machine and `tp-surface' supplies and stages exact target entries
;; backed by the shared prepare journals and snapshots.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(define-error 'tp-transaction-contract-error
"Invalid TP publication transaction contract")
(define-error 'tp-publication-binding-error
"TP publication artifact binding mismatch"
'tp-transaction-contract-error)
(define-error 'tp-publication-state-error
"Invalid TP publication artifact state transition"
'tp-transaction-contract-error)
(define-error 'tp-final-marker-error
"Invalid TP final-accept marker"
'tp-transaction-contract-error)
(defconst tp-transaction-protocol 'tp-transaction-protocol-v2
"Transaction protocol implemented by this TP package version.")
(defconst tp--publication-batch-transitions
'((prepared staged rolled-back discarded)
(staged participants rolled-back)
(participants precommit rolled-back)
(precommit final-accepting rolled-back)
(final-accepting committed rolled-back))
"Allowed one-way state transitions for publication batch candidates.")
(defconst tp--publication-batch-terminal-states
'(committed rolled-back discarded)
"Terminal publication batch candidate states.")
(defconst tp--publication-batch-stage-entry-functions
'(tp--surface-stage-publication-entries)
"Closed package-owned publication entry stage capabilities.")
(defconst tp--final-marker-max-count 8
"Maximum number of opaque final markers in one transaction.")
(defconst tp--final-marker-max-slot-writes 16
"Maximum total fixed marker slot writes in one transaction.")
(defvar tp--transaction-id-counter 0)
(defvar tp--publication-batch-id-counter 0)
(defvar tp--publication-candidate-id-counter 0)
(defvar tp--final-accept-id-counter 0)
(defun tp--next-transaction-id ()
"Return a fresh monotonic internal transaction identifier."
(cl-incf tp--transaction-id-counter))
(defun tp--next-publication-batch-id ()
"Return a fresh monotonic publication batch identifier."
(cl-incf tp--publication-batch-id-counter))
(defun tp--next-publication-candidate-id ()
"Return a fresh monotonic target candidate identifier."
(cl-incf tp--publication-candidate-id-counter))
(defun tp--next-final-accept-id ()
"Return a fresh monotonic final-accept identifier."
(cl-incf tp--final-accept-id-counter))
(defun tp--proper-unique-list-p (items)
"Return non-nil when ITEMS is a proper list with no equal duplicates."
(and (proper-list-p items)
(let ((seen (make-hash-table :test #'equal))
(unique t))
(dolist (item items unique)
(if (gethash item seen)
(setq unique nil)
(puthash item t seen))))))
(cl-defstruct (tp-publication-target-entry
(:constructor tp--make-publication-target-entry)
(:copier nil))
"One exact, immutable target binding in a publication candidate."
(transaction-id nil :read-only t)
(batch-id nil :read-only t)
(candidate-id nil :read-only t)
(surface-id nil :read-only t)
(mount-ids nil :read-only t)
(buffer nil :read-only t)
(old-revision nil :read-only t)
(new-revision nil :read-only t)
(plan nil :read-only t)
(diff nil :read-only t)
(ledger nil :read-only t)
(objects nil :read-only t)
(ranges nil :read-only t)
(client-state nil :read-only t)
(rollback-snapshot nil :read-only t)
(authority-token nil :read-only t)
(mapping-generation nil :read-only t)
operation-counts
(shadow-expected nil :read-only t)
(shadow-validator nil :read-only t)
rollback-result post-rollback-state shadow-actual shadow-proven-p)
(defun tp--publication-target-entry-arguments-valid-p
(transaction-id batch-id candidate-id surface-id mount-ids buffer
old-revision new-revision authority-token shadow-validator)
"Return non-nil when target arguments bind TRANSACTION-ID and BATCH-ID.
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION,
AUTHORITY-TOKEN, and SHADOW-VALIDATOR must have valid publication shapes."
(and transaction-id batch-id candidate-id surface-id
(bufferp buffer) (buffer-live-p buffer)
(integerp old-revision) (>= old-revision 0)
(integerp new-revision) (= new-revision (1+ old-revision))
(tp--proper-unique-list-p mount-ids)
authority-token
(or (null shadow-validator) (functionp shadow-validator))))
(cl-defun tp--publication-target-entry-create
(&key transaction-id batch-id candidate-id surface-id mount-ids buffer
old-revision new-revision plan diff ledger objects ranges client-state
rollback-snapshot authority-token mapping-generation shadow-expected
shadow-validator operation-counts)
"Create an exact TRANSACTION-ID and BATCH-ID target binding.
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION, PLAN,
DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
AUTHORITY-TOKEN describe the target. MAPPING-GENERATION is optional.
OPERATION-COUNTS is filled from the live report. SHADOW-EXPECTED and
SHADOW-VALIDATOR are private comparison artifacts."
(unless (tp--publication-target-entry-arguments-valid-p
transaction-id batch-id candidate-id surface-id mount-ids buffer
old-revision new-revision authority-token shadow-validator)
(signal 'tp-publication-binding-error
(list :target-entry transaction-id batch-id candidate-id surface-id
buffer old-revision new-revision mount-ids authority-token)))
(tp--make-publication-target-entry
:transaction-id transaction-id
:batch-id batch-id
:candidate-id candidate-id
:surface-id (tp--copy-property-value surface-id)
:mount-ids (tp--copy-property-value mount-ids)
:buffer buffer
:old-revision old-revision
:new-revision new-revision
:plan plan
:diff (tp--copy-property-value diff)
:ledger ledger
:objects objects
:ranges ranges
:client-state (tp--copy-property-value client-state)
:rollback-snapshot rollback-snapshot
:authority-token authority-token
:mapping-generation mapping-generation
:operation-counts (tp--copy-property-value operation-counts)
:shadow-expected shadow-expected
:shadow-validator shadow-validator))
(cl-defstruct (tp-publication-outcome-entry
(:constructor tp--make-publication-outcome-entry)
(:copier nil))
"Frozen observational binding copied from one target entry."
(batch-id nil :read-only t)
(candidate-id nil :read-only t)
(surface-id nil :read-only t)
(mount-ids nil :read-only t)
(buffer nil :read-only t)
(authority-token nil :read-only t)
(old-revision nil :read-only t)
(new-revision nil :read-only t)
(mapping-generation nil :read-only t)
(operation-counts nil :read-only t))
(defun tp--publication-outcome-entry-from-target (entry)
"Return an observational outcome entry frozen from target ENTRY."
(tp--make-publication-outcome-entry
:batch-id (tp-publication-target-entry-batch-id entry)
:candidate-id (tp-publication-target-entry-candidate-id entry)
:surface-id
(tp--copy-property-value (tp-publication-target-entry-surface-id entry))
:mount-ids
(tp--copy-property-value (tp-publication-target-entry-mount-ids entry))
:buffer (tp-publication-target-entry-buffer entry)
:authority-token (tp-publication-target-entry-authority-token entry)
:old-revision (tp-publication-target-entry-old-revision entry)
:new-revision (tp-publication-target-entry-new-revision entry)
:mapping-generation
(tp-publication-target-entry-mapping-generation entry)
:operation-counts
(tp--copy-property-value
(tp-publication-target-entry-operation-counts entry))))
(cl-defstruct (tp-committed-success-outcome
(:constructor tp--make-committed-success-outcome)
(:copier nil))
"Preallocated immutable evidence finalized only after final accept."
(tag nil :read-only t)
(transaction-id nil :read-only t)
(final-accept-id nil :read-only t)
(batch-id nil :read-only t)
(entries nil :read-only t)
(mapping-generation nil :read-only t)
(operation-counts nil :read-only t)
(phase-timings nil :read-only t)
(diagnostics nil :read-only t)
(marker-count nil :read-only t))
(defconst tp--committed-success-outcome-tag-slot 1
"Private record offset for the sole postaccept success-tag write.")
(cl-defstruct (tp-publication-failure-outcome
(:constructor tp--make-publication-failure-outcome)
(:copier nil))
"Immutable observational evidence built after publication rollback."
(tag 'publication-failure :read-only t)
(transaction-id nil :read-only t)
(batch-id nil :read-only t)
(failure-stage nil :read-only t)
(primary-condition nil :read-only t)
(target-results nil :read-only t)
(rollback-failures nil :read-only t)
(post-rollback-state nil :read-only t)
(diagnostics nil :read-only t))
(cl-defstruct (tp-publication-batch-candidate
(:constructor tp--make-publication-batch-candidate)
(:copier nil))
"A one-shot structured publication authority over shared rollback state."
(transaction-id nil :read-only t)
(id nil :read-only t)
state
resolution
(entries nil :read-only t)
(participants nil :read-only t)
(journals nil :read-only t)
(stage-entries nil :read-only t)
final-accept
(final-accept-id nil :read-only t)
diagnostics
operation-counts
phase-timings
markers
success-outcome-draft
outcome
shadow-proof)
(defun tp--publication-target-entry-bound-p (entry transaction-id batch-id)
"Return non-nil when ENTRY is exactly bound to TRANSACTION-ID and BATCH-ID."
(and (tp-publication-target-entry-p entry)
(equal transaction-id
(tp-publication-target-entry-transaction-id entry))
(equal batch-id (tp-publication-target-entry-batch-id entry))))
(defun tp--publication-batch-entries-valid-p
(entries transaction-id batch-id)
"Return non-nil when ENTRIES bind TRANSACTION-ID and BATCH-ID exactly."
(and (proper-list-p entries)
entries
(cl-every (lambda (entry)
(tp--publication-target-entry-bound-p
entry transaction-id batch-id))
entries)
(tp--proper-unique-list-p
(mapcar #'tp-publication-target-entry-candidate-id entries))
(tp--proper-unique-list-p
(mapcar #'tp-publication-target-entry-surface-id entries))
(tp--proper-unique-list-p
(mapcar #'tp-publication-target-entry-authority-token entries))
(let ((generation
(tp-publication-target-entry-mapping-generation (car entries))))
(cl-every
(lambda (entry)
(equal generation
(tp-publication-target-entry-mapping-generation entry)))
entries))))
(cl-defun tp--publication-batch-prepare
(&key transaction-id batch-id entries participants journals stage-entries
final-accept diagnostics)
"Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES.
PARTICIPANTS is an ordered reference vector, JOURNALS is the shared rollback
view, STAGE-ENTRIES is an optional package-owned execution capability,
FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains known
preaccept observations."
(unless (and transaction-id batch-id
(tp--publication-batch-entries-valid-p
entries transaction-id batch-id)
(vectorp participants)
(or (null stage-entries)
(and (symbolp stage-entries)
(memq stage-entries
tp--publication-batch-stage-entry-functions)
(fboundp stage-entries)))
(functionp final-accept))
(signal 'tp-publication-binding-error
(list :batch transaction-id batch-id entries participants)))
(tp--make-publication-batch-candidate
:transaction-id transaction-id
:id batch-id
:state 'prepared
:entries (copy-sequence entries)
:participants participants
:journals journals
:stage-entries stage-entries
:final-accept final-accept
:final-accept-id (tp--next-final-accept-id)
:diagnostics (tp--copy-property-value diagnostics)))
(defun tp--publication-batch-execute-stage (candidate)
"Execute CANDIDATE's package-owned entry stage capability exactly once."
(unless (and (tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate) 'staged)
(memq (tp-publication-batch-candidate-stage-entries candidate)
tp--publication-batch-stage-entry-functions))
(signal 'tp-publication-state-error
(list :batch-stage candidate)))
(funcall (tp-publication-batch-candidate-stage-entries candidate) candidate))
(defun tp--publication-batch-terminal-p (candidate)
"Return non-nil when CANDIDATE has one terminal disposition."
(and (tp-publication-batch-candidate-p candidate)
(memq (tp-publication-batch-candidate-state candidate)
tp--publication-batch-terminal-states)))
(defun tp--publication-batch-transition (candidate next)
"Move CANDIDATE to NEXT through its one-way state machine."
(unless (tp-publication-batch-candidate-p candidate)
(signal 'wrong-type-argument
(list 'tp-publication-batch-candidate-p candidate)))
(let* ((current (tp-publication-batch-candidate-state candidate))
(allowed (cdr (assq current tp--publication-batch-transitions))))
(unless (memq next allowed)
(signal 'tp-publication-state-error
(list :batch-state current next
(tp-publication-batch-candidate-id candidate))))
(setf (tp-publication-batch-candidate-state candidate) next)
(when (memq next tp--publication-batch-terminal-states)
(setf (tp-publication-batch-candidate-resolution candidate) next))
candidate))
(defun tp--publication-batch-discard (candidate reason)
"Discard prepared CANDIDATE for REASON and return nil."
(unless (and (tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate) 'prepared))
(signal 'tp-publication-state-error
(list :discard
(and (tp-publication-batch-candidate-p candidate)
(tp-publication-batch-candidate-state candidate)))))
(setf (tp-publication-batch-candidate-diagnostics candidate)
(append (tp-publication-batch-candidate-diagnostics candidate)
(list (list :discard reason))))
(tp--publication-batch-transition candidate 'discarded)
nil)
(defun tp--committed-success-outcome-draft
(candidate operation-counts phase-timings diagnostics marker-count)
"Preallocate CANDIDATE evidence using OPERATION-COUNTS and PHASE-TIMINGS.
DIAGNOSTICS contains known preaccept failures and MARKER-COUNT is fixed."
(unless (tp-publication-batch-candidate-p candidate)
(signal 'wrong-type-argument
(list 'tp-publication-batch-candidate-p candidate)))
(setf (tp-publication-batch-candidate-operation-counts candidate)
(tp--copy-property-value operation-counts)
(tp-publication-batch-candidate-phase-timings candidate)
(tp--copy-property-value phase-timings)
(tp-publication-batch-candidate-diagnostics candidate)
(tp--copy-property-value diagnostics))
(tp--make-committed-success-outcome
:transaction-id
(tp-publication-batch-candidate-transaction-id candidate)
:final-accept-id
(tp-publication-batch-candidate-final-accept-id candidate)
:batch-id (tp-publication-batch-candidate-id candidate)
:entries
(mapcar #'tp--publication-outcome-entry-from-target
(tp-publication-batch-candidate-entries candidate))
:mapping-generation
(let ((entries (tp-publication-batch-candidate-entries candidate)))
(and entries
(tp-publication-target-entry-mapping-generation (car entries))))
:operation-counts
(tp--copy-property-value
(tp-publication-batch-candidate-operation-counts candidate))
:phase-timings
(tp--copy-property-value
(tp-publication-batch-candidate-phase-timings candidate))
:diagnostics
(tp--copy-property-value
(tp-publication-batch-candidate-diagnostics candidate))
:marker-count marker-count))
(defun tp--committed-success-outcome-finalize (outcome)
"Finalize preallocated OUTCOME exactly once after final accept."
(unless (and (tp-committed-success-outcome-p outcome)
(null (tp-committed-success-outcome-tag outcome)))
(signal 'tp-publication-state-error (list :success-outcome outcome)))
;; The slot is read-only to every accessor. This single fixed vector write is
;; the coordinator's postaccept tag finalization primitive.
(aset outcome tp--committed-success-outcome-tag-slot 'committed-success)
outcome)
(defun tp--publication-outcome-entry-matches-target-p (outcome-entry target)
"Return non-nil when OUTCOME-ENTRY is exactly bound to TARGET."
(and (tp-publication-outcome-entry-p outcome-entry)
(tp-publication-target-entry-p target)
(equal (tp-publication-outcome-entry-batch-id outcome-entry)
(tp-publication-target-entry-batch-id target))
(equal (tp-publication-outcome-entry-candidate-id outcome-entry)
(tp-publication-target-entry-candidate-id target))
(equal (tp-publication-outcome-entry-surface-id outcome-entry)
(tp-publication-target-entry-surface-id target))
(equal (tp-publication-outcome-entry-mount-ids outcome-entry)
(tp-publication-target-entry-mount-ids target))
(eq (tp-publication-outcome-entry-buffer outcome-entry)
(tp-publication-target-entry-buffer target))
(eq (tp-publication-outcome-entry-authority-token outcome-entry)
(tp-publication-target-entry-authority-token target))
(= (tp-publication-outcome-entry-old-revision outcome-entry)
(tp-publication-target-entry-old-revision target))
(= (tp-publication-outcome-entry-new-revision outcome-entry)
(tp-publication-target-entry-new-revision target))
(equal (tp-publication-outcome-entry-mapping-generation outcome-entry)
(tp-publication-target-entry-mapping-generation target))
(equal (tp-publication-outcome-entry-operation-counts outcome-entry)
(tp-publication-target-entry-operation-counts target))))
(defun tp--committed-success-outcome-valid-for-p
(outcome candidate &optional mapping-generation)
"Purely validate OUTCOME against exact CANDIDATE and MAPPING-GENERATION."
(and (tp-committed-success-outcome-p outcome)
(eq (tp-committed-success-outcome-tag outcome) 'committed-success)
(tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate) 'committed)
(equal (tp-committed-success-outcome-transaction-id outcome)
(tp-publication-batch-candidate-transaction-id candidate))
(equal (tp-committed-success-outcome-batch-id outcome)
(tp-publication-batch-candidate-id candidate))
(equal (tp-committed-success-outcome-operation-counts outcome)
(tp-publication-batch-candidate-operation-counts candidate))
(equal (tp-committed-success-outcome-phase-timings outcome)
(tp-publication-batch-candidate-phase-timings candidate))
(equal (tp-committed-success-outcome-diagnostics outcome)
(tp-publication-batch-candidate-diagnostics candidate))
(= (tp-committed-success-outcome-marker-count outcome)
(if (consp (tp-publication-batch-candidate-markers candidate))
(cdr (tp-publication-batch-candidate-markers candidate))
0))
(or (null mapping-generation)
(equal mapping-generation
(tp-committed-success-outcome-mapping-generation outcome)))
(let ((outcome-entries
(append (tp-committed-success-outcome-entries outcome) nil))
(targets (tp-publication-batch-candidate-entries candidate)))
(and (= (length outcome-entries) (length targets))
(cl-every #'identity
(cl-mapcar
#'tp--publication-outcome-entry-matches-target-p
outcome-entries targets))))))
(defun tp--committed-success-outcome-snapshot (outcome)
"Return a defensive observational plist for committed OUTCOME."
(unless (and (tp-committed-success-outcome-p outcome)
(eq (tp-committed-success-outcome-tag outcome)
'committed-success))
(signal 'tp-publication-binding-error (list :outcome outcome)))
(list
:tag 'committed-success
:transaction-id (tp-committed-success-outcome-transaction-id outcome)
:final-accept-id (tp-committed-success-outcome-final-accept-id outcome)
:batch-id (tp-committed-success-outcome-batch-id outcome)
:entries
(mapcar
(lambda (entry)
(list :batch-id (tp-publication-outcome-entry-batch-id entry)
:candidate-id (tp-publication-outcome-entry-candidate-id entry)
:surface-id
(tp--copy-property-value
(tp-publication-outcome-entry-surface-id entry))
:mount-ids
(tp--copy-property-value
(tp-publication-outcome-entry-mount-ids entry))
:buffer (tp-publication-outcome-entry-buffer entry)
:authority-token
(tp-publication-outcome-entry-authority-token entry)
:old-revision
(tp-publication-outcome-entry-old-revision entry)
:new-revision
(tp-publication-outcome-entry-new-revision entry)
:mapping-generation
(tp-publication-outcome-entry-mapping-generation entry)
:operation-counts
(tp--copy-property-value
(tp-publication-outcome-entry-operation-counts entry))))
(append (tp-committed-success-outcome-entries outcome) nil))
:mapping-generation
(tp-committed-success-outcome-mapping-generation outcome)
:operation-counts
(tp--copy-property-value
(tp-committed-success-outcome-operation-counts outcome))
:phase-timings
(tp--copy-property-value
(tp-committed-success-outcome-phase-timings outcome))
:diagnostics
(tp--copy-property-value
(tp-committed-success-outcome-diagnostics outcome))
:marker-count (tp-committed-success-outcome-marker-count outcome)))
(defun tp--publication-failure-outcome-valid-for-p (outcome candidate)
"Purely validate failure OUTCOME against rolled-back CANDIDATE."
(and (tp-publication-failure-outcome-p outcome)
(eq (tp-publication-failure-outcome-tag outcome)
'publication-failure)
(tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate) 'rolled-back)
(equal (tp-publication-failure-outcome-transaction-id outcome)
(tp-publication-batch-candidate-transaction-id candidate))
(equal (tp-publication-failure-outcome-batch-id outcome)
(tp-publication-batch-candidate-id candidate))
(let ((results (tp-publication-failure-outcome-target-results outcome))
(entries (tp-publication-batch-candidate-entries candidate)))
(and (= (length results) (length entries))
(cl-every
#'identity
(cl-mapcar
(lambda (result entry)
(and
(equal (plist-get result :candidate-id)
(tp-publication-target-entry-candidate-id entry))
(equal (plist-get result :surface-id)
(tp-publication-target-entry-surface-id entry))))
results entries))))))
(defun tp--publication-failure-outcome-create
(candidate stage primary-condition rollback-failures diagnostics)
"Build rolled-back CANDIDATE evidence for STAGE and PRIMARY-CONDITION.
ROLLBACK-FAILURES and DIAGNOSTICS are observational snapshots."
(unless (and (tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate)
'rolled-back))
(signal 'tp-publication-state-error (list :failure-outcome candidate)))
(let ((entries (tp-publication-batch-candidate-entries candidate)))
(tp--make-publication-failure-outcome
:transaction-id
(tp-publication-batch-candidate-transaction-id candidate)
:batch-id (tp-publication-batch-candidate-id candidate)
:failure-stage stage
:primary-condition (tp--copy-property-value primary-condition)
:target-results
(mapcar
(lambda (entry)
(list :candidate-id
(tp-publication-target-entry-candidate-id entry)
:surface-id
(tp--copy-property-value
(tp-publication-target-entry-surface-id entry))
:result
(tp--copy-property-value
(tp-publication-target-entry-rollback-result entry))))
entries)
:rollback-failures (tp--copy-property-value rollback-failures)
:post-rollback-state
(mapcar
(lambda (entry)
(list :candidate-id
(tp-publication-target-entry-candidate-id entry)
:surface-id
(tp--copy-property-value
(tp-publication-target-entry-surface-id entry))
:state
(tp--copy-property-value
(tp-publication-target-entry-post-rollback-state entry))))
entries)
:diagnostics (tp--copy-property-value diagnostics))))
(cl-defstruct (tp--final-marker-operation
(:constructor tp--make-final-marker-operation)
(:copier nil))
"One trusted operation descriptor resolved before final accept."
(key nil :read-only t)
(validate nil :read-only t)
(apply nil :read-only t)
(restore nil :read-only t)
(max-slot-writes nil :read-only t))
(cl-defstruct (tp-final-marker-expectation
(:constructor tp--make-final-marker-expectation)
(:copier nil))
"One prebuilt expected scalar stored in a fixed vector slot."
(target nil :read-only t)
(index nil :read-only t)
(value nil :read-only t))
(cl-defstruct (tp-final-marker-slot-write
(:constructor tp--make-final-marker-slot-write)
(:copier nil))
"One prebuilt fixed vector slot write."
(target nil :read-only t)
(index nil :read-only t)
(value nil :read-only t))
(defun tp--final-marker-vector-index-p (target index)
"Return non-nil when INDEX denotes a writable slot in TARGET."
(and (vectorp target) (integerp index) (<= 0 index) (< index (length target))))
(cl-defun tp--final-marker-expectation-create (&key target index value)
"Create an expectation that TARGET slot INDEX currently equals VALUE."
(unless (tp--final-marker-vector-index-p target index)
(signal 'tp-final-marker-error (list :expectation target index)))
(tp--make-final-marker-expectation
:target target :index index :value value))
(cl-defun tp-final-marker-expectation-create (&key target index value)
"Create a final-marker expectation for TARGET slot INDEX and VALUE."
(tp--final-marker-expectation-create
:target target :index index :value value))
(cl-defun tp--final-marker-slot-write-create (&key target index value)
"Create one prebuilt write of VALUE into TARGET slot INDEX."
(unless (tp--final-marker-vector-index-p target index)
(signal 'tp-final-marker-error (list :slot-write target index)))
(tp--make-final-marker-slot-write :target target :index index :value value))
(cl-defun tp-final-marker-slot-write-create (&key target index value)
"Create one bounded final-marker write to TARGET slot INDEX with VALUE."
(tp--final-marker-slot-write-create
:target target :index index :value value))
(defun tp--final-marker-expectation-current-p (expectation)
"Return non-nil when EXPECTATION matches its current fixed slot."
(and (tp-final-marker-expectation-p expectation)
(equal
(aref (tp-final-marker-expectation-target expectation)
(tp-final-marker-expectation-index expectation))
(tp-final-marker-expectation-value expectation))))
(defun tp--final-marker-slot-write-shape-p (write)
"Return non-nil when WRITE still denotes one valid fixed vector slot."
(and (tp-final-marker-slot-write-p write)
(tp--final-marker-vector-index-p
(tp-final-marker-slot-write-target write)
(tp-final-marker-slot-write-index write))))
(defun tp--final-marker-vector-payload-shape-p (marker)
"Return non-nil when MARKER has exact paired fixed vector slot payloads."
(let ((next (tp-final-accept-marker-next-values marker))
(inverse (tp-final-accept-marker-inverse-values marker))
(count (tp-final-accept-marker-slot-write-count marker))
seen valid)
(setq valid
(and (vectorp next) (vectorp inverse)
(= (length next) count) (= (length inverse) count)))
(let ((index 0))
(while (and valid (< index count))
(let ((next-write (aref next index))
(inverse-write (aref inverse index)))
(setq valid
(and
(tp--final-marker-slot-write-shape-p next-write)
(tp--final-marker-slot-write-shape-p inverse-write)
(eq (tp-final-marker-slot-write-target next-write)
(tp-final-marker-slot-write-target inverse-write))
(= (tp-final-marker-slot-write-index next-write)
(tp-final-marker-slot-write-index inverse-write))
(not
(cl-find-if
(lambda (entry)
(and
(eq (car entry)
(tp-final-marker-slot-write-target next-write))
(= (cdr entry)
(tp-final-marker-slot-write-index next-write))))
seen))))
(when valid
(push (cons (tp-final-marker-slot-write-target next-write)
(tp-final-marker-slot-write-index next-write))
seen)))
(setq index (1+ index))))
valid))
(defun tp--final-marker-vector-slots-validate (marker)
"Validate MARKER expectations and inverse values without changing state."
(and
(tp--final-marker-vector-payload-shape-p marker)
(tp--final-marker-expectation-current-p
(tp-final-accept-marker-expected-token marker))
(tp--final-marker-expectation-current-p
(tp-final-accept-marker-expected-version marker))
(let* ((inverse (tp-final-accept-marker-inverse-values marker))
(count (length inverse))
(index 0)
(valid t))
(while (and valid (< index count))
(let ((write (aref inverse index)))
(setq valid
(equal
(aref (tp-final-marker-slot-write-target write)
(tp-final-marker-slot-write-index write))
(tp-final-marker-slot-write-value write))))
(setq index (1+ index)))
valid)))
(defun tp--final-marker-vector-slots-apply (marker)
"Apply MARKER's fixed next-value vector slots in order."
(let* ((writes (tp-final-accept-marker-next-values marker))
(count (length writes))
(index 0))
(while (< index count)
(let ((write (aref writes index)))
(aset (tp-final-marker-slot-write-target write)
(tp-final-marker-slot-write-index write)
(tp-final-marker-slot-write-value write)))
(setq index (1+ index)))))
(defun tp--final-marker-vector-slots-restore (marker)
"Restore MARKER's fixed inverse-value vector slots in reverse order."
(let* ((writes (tp-final-accept-marker-inverse-values marker))
(index (1- (length writes))))
(while (>= index 0)
(let ((write (aref writes index)))
(aset (tp-final-marker-slot-write-target write)
(tp-final-marker-slot-write-index write)
(tp-final-marker-slot-write-value write)))
(setq index (1- index)))))
(defconst tp--final-marker-operation-whitelist
(list
(tp--make-final-marker-operation
:key 'tp-vector-slots/v1
:validate (symbol-function 'tp--final-marker-vector-slots-validate)
:apply (symbol-function 'tp--final-marker-vector-slots-apply)
:restore (symbol-function 'tp--final-marker-vector-slots-restore)
:max-slot-writes tp--final-marker-max-slot-writes))
"Closed package-owned final-marker primitive whitelist.")
(defun tp--final-marker-operation-resolve (key)
"Return the trusted final marker operation registered for KEY."
(let ((operation
(cl-find key tp--final-marker-operation-whitelist
:key #'tp--final-marker-operation-key :test #'eq)))
(or operation
(signal 'tp-final-marker-error (list :operation-not-whitelisted key)))))
(cl-defstruct (tp-final-accept-marker
(:constructor tp--make-final-accept-marker)
(:copier nil))
"One opaque, bounded, one-shot final-accept authority marker."
(owner-key nil :read-only t)
(expected-token nil :read-only t)
(expected-version nil :read-only t)
(next-values nil :read-only t)
(inverse-values nil :read-only t)
(slot-write-count nil :read-only t)
(operation-key nil :read-only t)
(operation nil :read-only t)
state)
(cl-defun tp--final-accept-marker-create
(&key owner-key expected-token expected-version next-values inverse-values
slot-write-count operation-key)
"Create an OWNER-KEY marker after resolving OPERATION-KEY.
EXPECTED-TOKEN and EXPECTED-VERSION bind owner state. NEXT-VALUES and
INVERSE-VALUES are opaque prebuilt payloads with fixed SLOT-WRITE-COUNT."
(let ((operation (tp--final-marker-operation-resolve operation-key)))
(unless (and owner-key
(tp-final-marker-expectation-p expected-token)
(tp-final-marker-expectation-p expected-version)
(integerp
(tp-final-marker-expectation-value expected-version))
(>= (tp-final-marker-expectation-value expected-version) 0)
(integerp slot-write-count) (> slot-write-count 0)
(<= slot-write-count
(tp--final-marker-operation-max-slot-writes operation)))
(signal 'tp-final-marker-error
(list :marker owner-key expected-token expected-version
slot-write-count operation-key)))
(let ((marker
(tp--make-final-accept-marker
:owner-key (tp--copy-property-value owner-key)
:expected-token expected-token
:expected-version expected-version
:next-values (and (vectorp next-values)
(copy-sequence next-values))
:inverse-values (and (vectorp inverse-values)
(copy-sequence inverse-values))
:slot-write-count slot-write-count
:operation-key operation-key
:operation operation
:state 'prepared)))
(unless (tp--final-marker-vector-payload-shape-p marker)
(signal 'tp-final-marker-error
(list :marker-payload owner-key slot-write-count)))
marker)))
(defun tp--final-accept-marker-validate (marker)
"Validate MARKER's expected owner state before the critical section."
(unless (and (tp-final-accept-marker-p marker)
(eq (tp-final-accept-marker-state marker) 'prepared)
(funcall
(tp--final-marker-operation-validate
(tp-final-accept-marker-operation marker))
marker))
(signal 'tp-final-marker-error
(list :expected-state
(and (tp-final-accept-marker-p marker)
(tp-final-accept-marker-owner-key marker)))))
marker)
(provide 'tp-transaction)
;;; tp-transaction.el ends here

52
tp.el
View File

@ -1,11 +1,11 @@
;;; tp.el --- Retained reactive text runtime -*- lexical-binding: t -*- ;;; tp.el --- Text Properties manipulation library for Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 2024-2026 Geekinney ;; Copyright (C) 2024-2026 Geekinney
;; Version: 2.0.0 ;; Version: 0.3.0
;; Keywords: convenience text-properties ;; Keywords: convenience text-properties
;; Author: Geekinney (kinneyzhang666@gmail.com) ;; Author: Geekinney (kinneyzhang666@gmail.com)
;; Package-Requires: ((emacs "28.1")) ;; Package-Requires: ((emacs "28.1") (dash "2.19.1"))
;; URL: https://github.com/Kinneyzhang/tp ;; URL: https://github.com/Kinneyzhang/tp
;; This program is free software; you can redistribute it and/or ;; This program is free software; you can redistribute it and/or
@ -15,29 +15,24 @@
;;; Commentary: ;;; Commentary:
;; TP projects declarative properties, reactive data, and retained text ;; tp.el is a comprehensive text property manipulation library.
;; objects onto Emacs strings and buffers.
;; ;;
;; It is organized as a stack of modules, each depending only on the ;; It is organized as a stack of modules, each depending only on the
;; ones before it: ;; ones before it:
;; ;;
;; tp-core.el Foundation: ranges, intervals, plist/face merge, ;; tp-core.el Foundation: intervals, plist/face merge engine,
;; canonical requests/results, and debug logging. ;; debug logging, pure $var utilities.
;; tp-style.el Native property policies, contribution composition, ;; tp-reactive.el Reactive state: dependency registry, variable
;; named declarations, and explicit computed values. ;; watchers, batching queue.
;; tp-transaction.el ;; tp-layer.el Layer registry: `define-tp', `define-tps',
;; Structured publication batch, marker, and outcome contracts. ;; layer/group resolution and expansion.
;; 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 Named declaration recipes: `define-tp', `define-tps',
;; and direct property expansion.
;; tp-ops.el Core primitives: `tp-set', `tp-reset', `tp-add', ;; tp-ops.el Core primitives: `tp-set', `tp-reset', `tp-add',
;; `tp-get', `tp-at', `tp-remove', `tp-clear'. ;; `tp-get', `tp-at', `tp-remove', `tp-clear'.
;; tp-search.el Pattern matching (`tp-match-*', `tp-regexp-*') and ;; tp-search.el Pattern matching (`tp-match-*', `tp-regexp-*') and
;; property search/navigation (`tp-search', ...). ;; property search/navigation (`tp-search', ...).
;; tp-query.el Native lookup/change wrappers and mutation policy. ;; 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-palette.el Color palette data (light/dark aware). ;; tp-palette.el Color palette data (light/dark aware).
;; tp-builtins.el Built-in layers (tp-fg, tp-link, tp-action, ...) ;; tp-builtins.el Built-in layers (tp-fg, tp-link, tp-action, ...)
;; and display helpers. ;; and display helpers.
@ -54,31 +49,14 @@
;;; Code: ;;; Code:
(require 'tp-core) (require 'tp-core)
(require 'tp-style)
(require 'tp-transaction)
(require 'tp-reactive) (require 'tp-reactive)
(require 'tp-surface)
(require 'tp-layer) (require 'tp-layer)
(require 'tp-ops) (require 'tp-ops)
(require 'tp-search) (require 'tp-search)
(require 'tp-query) (require 'tp-render)
(require 'tp-stack)
(require 'tp-palette) (require 'tp-palette)
(require 'tp-builtins) (require 'tp-builtins)
(defconst tp--runtime-manifest
`(:package tp :version "2.0.0"
:transaction-protocol ,tp-transaction-protocol
:batch-artifacts t
:batch-execute t
:structured-participant-api tp-transaction-participate-v2
:single-live-writer t
:final-marker-operation tp-vector-slots/v1)
"Immutable package capability facts for cross-package compatibility checks.")
;;;###autoload
(defun tp-runtime-manifest ()
"Return a defensive snapshot of TP's package capability manifest."
(tp--copy-property-value tp--runtime-manifest))
(provide 'tp) (provide 'tp)
;;; tp.el ends here ;;; tp.el ends here