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

Merge dev/0.3.0: CI matrix, feature tracks, architecture review fixes

Browse Source 
0.3.0: GitHub Actions CI (Emacs 28.1/29.4/30.1, warnings-as-errors,
shuffled-order rerun, doctests); layer visibility and stack
introspection; reactive layer-buffer registry, minimal-diff tp-text,
anonymous-layer GC; search capture groups, bounds, predicates;
multi-argument parameterized layers; a five-dimension adversarial
architecture/API review whose 29-item fix plan is fully applied
(six confirmed seam bugs fixed, module boundaries tightened to two
hook variables, additive API polish, deprecations); bilingual docs
with 88 executable doctests. Suite 578/578 green.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
Kinneyzhang 2026-07-27 03:44:45 +08:00
commit a65d79921a
25 changed files with 7454 additions and 1134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
.github/workflows/ci.yml vendored Normal file
View File

@ -0,0 +1,56 @@
name: CI
on:
push:
branches: [main, 'dev/**']
pull_request:
branches: [main]
jobs:
test:
runs-on: ubuntu-latest
strategy:
fail-fast: false
matrix:
emacs_version: ['28.1', '29.4', '30.1']
steps:
- uses: actions/checkout@v6
- uses: purcell/setup-emacs@master
with:
version: ${{ matrix.emacs_version }}
- name: Install dash from GNU ELPA
run: |
emacs -Q --batch --eval "(progn \
(require 'package) \
(setq package-user-dir (expand-file-name \".elpa\")) \
(add-to-list 'package-archives '(\"gnu\" . \"https://elpa.gnu.org/packages/\")) \
(package-initialize) \
(package-refresh-contents) \
(package-install 'dash))"
# Trailing slash: match only the package directory, not the
# adjacent dash-N.N.N.signed marker GNU ELPA leaves behind.
echo "LOAD_EXTRA=-L $(ls -d "$PWD"/.elpa/dash-*/ | head -1)" >> "$GITHUB_ENV"
- name: Byte-compile (warnings are errors)
run: make compile-all WERROR=t LOAD_EXTRA="$LOAD_EXTRA"
- name: ERT suite
run: make test LOAD_EXTRA="$LOAD_EXTRA"
- name: ERT suite (shuffled order)
run: make test-shuffled LOAD_EXTRA="$LOAD_EXTRA"
- name: README doctests
run: |
set -o pipefail
make doctest LOAD_EXTRA="$LOAD_EXTRA" 2>&1 | tee doctest.log || {
# Surface failing assertions as annotations (job logs are
# not readable anonymously; annotations are).
grep -E '^(FAIL| expected:| got:)' doctest.log | head -30 \
| while IFS= read -r l; do echo "::error::${l}"; done
grep -q '^FAIL' doctest.log || tail -n 8 doctest.log \
| while IFS= read -r l; do echo "::error::${l}"; done
exit 1
}

142
CHANGELOG.md
View File

@ -2,6 +2,148 @@
All notable changes to the tp library are documented here.
## 0.3.0 (2026-07-27)
### Added
Layer stack:
- **Layer visibility**: `tp-hide-layer` / `tp-show-layer` — a hidden
layer stays in the stack (and keeps receiving reactive updates) but
does not render; hiding the visible top reveals the next visible
layer, and with every layer hidden the text renders bare.
`tp-flatten-layers` merges only visible layers; `tp-merge-layers`
excludes hidden matched layers' props.
- `tp-lower-layer` (mirror of `tp-raise-layer`) and a
family-consistent `tp-rotate-layer` calling order
`(START END DIRECTION [COUNT] [OBJECT])`, selected unambiguously by
the symbols `up` / `down`; the legacy order keeps working.
- `tp-layer-stack-at` — the full ordered stack at one position as
`(NAME . PROPS)` conses, hidden layers marked by a `tp-hidden`
entry.
- Stack mutators return the number of property runs they modified
(including `tp-merge-layers` / `tp-flatten-layers`), and layer-name
lookups gained optional NOERROR arguments where they previously
signaled.
- `tp-describe-layer` — interactive help-buffer description of a
layer: storage format, arglist, stored body, expanded props,
reactive deps, transform, owning group.
Reactive engine:
- **Layer→buffer registry**: reactive updates now visit only the
buffers registered as showing the affected layer instead of scanning
the whole `(buffer-list)`; every buffer-mutating write path
registers (tp-set family, stack mutators, match/regexp appliers),
killed buffers are pruned, and an unknown layer falls back to one
learning full scan. `tp-reactive-layer-buffers` exposes the
registry; `tp-reactive-track-buffer` closes the
insert-a-propertized-string gap.
- **Minimal-diff `tp-text` re-render**: only the differing span is
edited (insert-before-delete), so point and markers in unchanged
text stay put and identical-text updates no longer touch the buffer
at all (buffer-modified flag preserved).
- `tp-gc-anonymous-layers` — collects interned anonymous layers that
no registered live buffer still shows (stack-aware: buried and
hidden layers count as alive; string-only layers are conservatively
kept).
Search and matching:
- `tp-regexp-set/reset/add` accept SUBEXP: properties apply to that
capture group per match (non-participating groups contribute
nothing); SUBEXP beyond the pattern's group count signals a clear
error.
- `tp-match-*` / `tp-regexp-*` accept START/END bounds with
as-if-only-that-portion semantics; reversed bounds are swapped.
- `tp-forward` / `tp-backward` / `tp-forward-do` / `tp-backward-do`
accept PREDICATE and NOT-CURRENT, passed through to the
text-property-search machinery; defaults keep the 0.2.0 symmetric
equal-matching contract exactly.
Layer definitions:
- **Multi-argument parameterized layers**: `define-tp` / `define-tps`
arglists may declare any number of parameters;
`(LAYER ARG1 ... ARGN)` and wrapped `(LAYER (ARG1 ... ARGN))` specs
work in `tp-set` and `tp-put-layer`; new `tp-layer-props-with-args`
/ `tp-group-props-with-args` / `tp-layer-arglist`. Wrong-arity
calls signal clear errors naming the layer and both counts.
- Prefix-conforming aliases `tp-define-layer` / `tp-define-group` /
`tp-define-palette` for discoverability (`C-h f tp-…`).
Core and palette:
- `tp-intervals` / `tp-intervals-map` accept an optional ABSOLUTE
argument returning native buffer coordinates (feedable straight
back into `tp-set`); the range-relative default is unchanged.
- `tp-palette-color` (generic theme-resolved accessor) and
`tp-palette-has-p` consolidate the palette query surface; all
existing query functions remain.
### Fixed
All six were found by an adversarial architecture/API review of the
new 0.3.0 code and confirmed with minimal reproductions before fixing:
- The reactive buffer registry only registered `tp-set`-family writes;
layers applied via `tp-push-layer`, `tp-match-set`, etc. never
re-rendered on variable updates.
- Reactive updates wrote only the rendered top layer; hidden or
buried layers kept stale props (visible again on `tp-show-layer`).
- `tp-gc-anonymous-layers` and `tp-reactive-track-buffer` scanned only
direct `tp-name` properties, so a layer buried in a stack (or
hidden) could be wrongly collected / missed.
- `tp-flatten-layers` / `tp-merge-layers` rendered hidden layers'
properties despite `tp-hide-layer`'s documented contract.
- Minimal-diff `tp-text` edits deleted before inserting, so markers at
the suffix boundary drifted to the wrong character.
- An error escaping a reactive update could strand queued batch
entries (now drained under `unwind-protect`; `tp-reactive-reset`
clears the queue).
### Changed
- **Module boundaries tightened** (behavior identical under
`(require 'tp)`): the `tp-text` handler chain moved from tp-render
into tp-ops — partial loads now get working `tp-text` replacement —
and `tp-with-batch-updates` moved up into tp-render; two of the four
upward hook variables are gone
(`tp--tp-text-handler-function`, `tp--reactive-flush-function`).
The layer-stack storage codec and the anonymous-layer machinery now
live in tp-layer; tp-stack's phantom dependency on tp-ops is gone;
67 lines of dead code deleted. tp-core holds no mutable state.
- String forms of all 16 stack mutators document that they modify the
string in place (unlike `tp-set`'s copy semantics); unifying this is
on the 0.4 ledger.
### Deprecated
- `tp-search-forward` / `tp-search-backward` (0.3.0) — thin wrappers
whose nil-PREDICATE default contradicts the rest of the library's
equal-matching; use `tp-forward` / `tp-backward`, or the Emacs
primitives for raw access.
- `tp-suffix-symbol` (0.3.0) — internal helper now private as
`tp--suffix-symbol`; a compatibility alias remains.
### Infrastructure
- GitHub Actions CI: Emacs 28.1 / 29.4 / 30.1 matrix running
byte-compilation with warnings-as-errors, the full ERT suite, a
shuffled-order rerun of every test (`make test-shuffled`,
`tp-run-shuffled.el`; `SHUFFLE_SEED=N` reproduces an order), and the
README doctests.
- The whole tree byte-compiles with zero warnings (57 fixed:
docstring rewraps and quoting, `defvar` declarations for reactive
test variables, prefixed doctest counters, one impossible `eq`
comparison corrected to `equal`).
- Autoload cookies for the interactive commands (`tp-debug-show`,
`tp-debug-clear`, `tp-reactive-reset`, `tp-layer-reset`,
`tp-palette-show`, `tp-clear`) and the `define-tp` / `define-tps`
macros.
- Two doctest assertions made property-order-insensitive (Emacs 28
prints text-property plists in a different order than 29+).
## 0.2.0 (2026-07-26)
### Architecture

22
Makefile
View File

@ -2,32 +2,48 @@
#
# Usage:
# make test # run all ERT test suites
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
# make doctest # execute README examples against the code
# make compile # byte-compile all modules
# make compile # byte-compile the library modules
# make compile-all # byte-compile modules + tests + dev scripts
# make clean # remove compiled files
#
# WERROR=t turns byte-compile warnings into errors (used in CI).
# If dash.el is not on the default load-path, point LOAD_EXTRA at it:
# make test LOAD_EXTRA="-L ~/.emacs.d/elpa/dash-20240510.1327"
EMACS ?= emacs
LOAD_EXTRA ?=
WERROR ?= nil
LOADPATH = -L . $(LOAD_EXTRA)
SRC = tp-core.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \
tp-render.el tp-stack.el tp-palette.el tp-builtins.el tp.el
TESTS = $(wildcard *-tests.el)
DEV = tp-doctest.el tp-run-shuffled.el
.PHONY: test doctest compile clean
.PHONY: test test-shuffled doctest compile compile-all clean
test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
-f ert-run-tests-batch-and-exit
test-shuffled:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
-l tp-run-shuffled.el
doctest:
$(EMACS) -Q --batch $(LOADPATH) -l tp-doctest.el
compile: clean
$(EMACS) -Q --batch $(LOADPATH) -f batch-byte-compile $(SRC)
$(EMACS) -Q --batch $(LOADPATH) \
--eval "(setq byte-compile-error-on-warn $(WERROR))" \
-f batch-byte-compile $(SRC)
compile-all: clean
$(EMACS) -Q --batch $(LOADPATH) \
--eval "(setq byte-compile-error-on-warn $(WERROR))" \
-f batch-byte-compile $(SRC) $(TESTS) $(DEV)
clean:
rm -f *.elc

1005
README.md
View File

File diff suppressed because it is too large Load Diff

959
README_CN.md
View File

File diff suppressed because it is too large Load Diff

367
docs/ARCHITECTURE.md
View File

@ -2,7 +2,7 @@
本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。
自 0.2.0 起，原来的单文件 tp.el 已拆分为九个分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。各模块的变更缘由见 [CHANGELOG.md](../CHANGELOG.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)。
## 目录
@ -10,14 +10,15 @@
- [模块分层](#模块分层)
- [tp-core.el：基础工具](#tp-coreel基础工具)
- [tp-reactive.el：响应式基础设施](#tp-reactiveel响应式基础设施)
- [tp-layer.el：层定义与解析](#tp-layerel层定义与解析)
- [tp-ops.el：核心属性操作](#tp-opsel核心属性操作)
- [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内置层与辅助工具)
- [钩子变量：唯一许可的反向调用](#钩子变量唯一许可的反向调用)
- [可变状态清单](#可变状态清单)
- [函数调用关系图](#函数调用关系图)
- [设计原则](#设计原则)
@ -32,6 +33,20 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
→ tp-render → tp-stack → tp-palette → tp-builtins
```
注意加载顺序是依赖顺序的**上界**：并非每个模块都依赖它前面的全部模块。各模块实际 `require` 的 tp- 模块如下（逐一核对自源码头部）：
| 模块 | 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 |
```
┌────────────────────────────────────────────────────────────────┐
│ tp.el —— 总入口，按序 require 全部模块 │
@ -41,25 +56,28 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
│ tp-palette-show、显示缓冲辅助宏 │
├────────────────────────────────────────────────────────────────┤
│ tp-palette.el 明/暗主题调色板数据、tp-parse-color │
│ （独立叶模块，不依赖任何 tp- 模块） │
├────────────────────────────────────────────────────────────────┤
│ tp-stack.el 层栈操作（push/pop/move/merge/flatten …） │
│ tp-stack.el 层栈操作（push/pop/move/hide/show/merge …） │
├────────────────────────────────────────────────────────────────┤
│ tp-render.el 响应式重渲染引擎 ──┐ │
├──────────────────────────────────── │ ─────────────────────────┤
│ tp-search.el tp-match-*/tp-regexp-*、tp-search、导航 │
├──────────────────────────────────── │ ─────────────────────────┤
│ tp-ops.el tp-set/reset/add/get/at/remove/clear │
│ ◁╌╌ tp--tp-text-handler-function ╌╌╌╌┤ │
├──────────────────────────────────── │ ─────────────────────────┤
│ tp-layer.el define-tp/define-tps、层注册表与解析 │
│ ◁╌╌ tp--layer-refresh-function ╌╌╌╌╌╌┤ │
├──────────────────────────────────── │ ─────────────────────────┤
│ tp-reactive.el 响应式依赖注册表、变量监听、批量队列 │
│ ◁╌╌ tp--reactive-update-function ╌╌╌╌┤ │
│ ◁╌╌ tp--reactive-flush-function ╌╌╌╌╌┘ │
│ 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 符号工具 │
│ 调试日志、$var 符号工具（无可变状态） │
└────────────────────────────────────────────────────────────────┘
实线层级：上层模块调用下层模块（require 依赖）。
@ -67,7 +85,7 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
由 tp-render.el 在加载时安装实现（见下文）。
```
早期文档把"响应式系统"画在高级 API 之下、却又让它向上调用 `tp-search-map`，与自身的分层原则矛盾。现在这一矛盾已在代码层面消除：需要向上调用的逻辑全部收拢进 `tp-render.el`（位于 `tp-search.el` 之上，可以直接调用它）；下层模块（tp-reactive、tp-layer、tp-ops）通过**钩子变量**触发渲染，自身不依赖任何上层模块。
需要"向上调用"的逻辑全部收拢在 `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）。
---
@ -75,14 +93,14 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
### tp-core.el：基础工具
最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。
最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。0.3.0 起 tp-core **不再持有任何可变状态**（匿名层计数器已迁至 tp-layer；仅剩 `tp-debug-mode` / `tp-debug-echo` 两个 defcustom 用户选项）。
#### 区间操作
| 函数 | 描述 | 主要调用者 |
|------|------|--------|
| `tp-intervals` | 获取区域内文本属性区间列表（裁剪到 [START, END)） | tp-intervals-map, tp-get |
| `tp-intervals-map` | 对区间应用函数 | 多个属性/层操作函数 |
| `tp--map-intervals` | 共享的裁剪式区间遍历引擎 | tp-intervals-map, tp-ops/tp-stack 的区域操作 |
| `tp-intervals` | 获取区域内文本属性区间列表（裁剪到 [START, END)；可选 ABSOLUTE 参数返回缓冲区原生坐标，默认仍为相对坐标） | tp-intervals-map, tp-get |
| `tp-intervals-map` | 对区间应用函数（同样支持 ABSOLUTE） | 多个属性/层操作函数 |
| `tp--map-intervals` | 共享的裁剪式区间遍历引擎 | tp-intervals-map, tp-ops/tp-stack 的区域操作, tp-reactive 的缓冲区扫描 |
| `tp-plist` | 获取区域中合并后的所有属性 | 用户 API |
| `tp-empty-p` | 检查对象是否没有文本属性 | 用户 API |
@ -94,6 +112,7 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
| `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 感知合并的属性家族。
@ -122,98 +141,139 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
### tp-reactive.el：响应式基础设施
只依赖 tp-core。维护响应式依赖注册表、变量监听器与批量更新队列；**不包含任何渲染逻辑**，重渲染通过钩子变量委托给 tp-render.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--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` | 重置全部响应式注册表 |
| `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-with-batch-updates` | 批量更新宏 |
| `tp--queue-batch-update` | 将更新加入待处理队列 |
| `tp--flush-batch-updates` | 刷新队列，经 `tp--reactive-flush-function` 委托重渲染 |
| `tp--queue-batch-update` | 将更新加入待处理队列 `tp--batch-update-pending`（刷新在 tp-render） |
钩子变量：`tp--reactive-update-function`、`tp--reactive-flush-function`（定义于此，由 tp-render.el 安装）。
钩子变量：`tp--reactive-update-function`（定义于此，由 tp-render.el 安装）。
---
### tp-layer.el：层定义与解析
### tp-layer.el：层定义、解析与层栈存储
依赖 tp-core、tp-reactive。提供 `define-tp` / `define-tps` 宏、层注册表、层名解析，以及层栈的数据结构原语。
依赖 tp-core、tp-reactive。提供 `define-tp` / `define-tps` 宏、层注册表、层名解析，以及 0.3.0 归位至此的**层栈存储编解码**与**匿名层完整生命周期**（铸造、驻留、注销、GC）。
#### 层定义
| 函数/宏 | 描述 | 依赖 |
|---------|------|------|
| `define-tp` | 定义单个自定义文本属性（层） | tp--define-layer-internal |
| `define-tps` | 定义自定义文本属性组（层组）；别名 `define-tp-group` | tp--define-layer-group-internal |
| `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 |
| `tp--anonymous-layer-name-for` | 匿名响应式层的驻留（`equal` 的 props 复用注册项） | - |
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` | 参数化层/层组的属性求值 |
| `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-layer-reset` | 重置层系统 |
| `tp-undefine-layer` / `tp-undefine-group` | 删除层/层组（含其响应式依赖与转换） |
| `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, tp--collect-reactive-symbols, tp--resolve-reactive-symbols, tp--register-reactive-deps |
| `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 |
| `tp--expand-layer-to-props-list` | 层名展开为属性列表 | tp--check-layer-cycle |
#### 层栈数据结构原语
#### 匿名层机制与 GC（0.3.0 归位/新增）
| 函数/变量 | 描述 |
|------|------|
| `tp--anonymous-layer-counter` | 匿名层名计数器。**刻意不被任何 reset 清零**：脱离缓冲区的字符串可能仍携带旧的 `tp-anon-N` 属性值，计数器单调递增保证新铸名字永不与之混淆 |
| `tp--generate-anonymous-layer-name` | 生成唯一的 `tp-anon-N` 符号 |
| `tp--anonymous-layer-registry` | 匿名响应式层驻留表：`equal` 的 props 规格复用既有注册项 |
| `tp--anonymous-layer-name-for` | 驻留查询/铸造入口 |
| `tp--buffer-has-layer-region-p` | 栈感知的存活检查：直接 `tp-name` 或 `tp-layers` 内（被覆盖/被隐藏）皆算存活 |
| `tp-gc-anonymous-layers` | 交互命令：回收已无任何已登记存活缓冲区展示的匿名层；注册表状态为 `unknown` 的层（可能仅被游离字符串引用）保守保留 |
#### 层栈存储编解码
层栈在原始文本属性上的编码/解码知识集中在这里，tp-stack（栈操作）与 tp-render（响应式写穿）都向下调用它，互不 require。
| 函数 | 描述 |
|------|------|
| `tp--normalize-layer-spec` | 规范化层规格 |
| `tp--get-layer-stack` | 获取位置的层栈 |
| `tp--build-layer-props` | 从层列表构建属性 |
| `tp--layer-stack-to-list` | 将层栈转换为列表 |
| `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-ops.el：核心属性操作与 tp-text 处理链
依赖 tp-core、tp-layer。面向用户的核心属性读写函数，直接调用 Emacs 原生文本属性 API。
依赖 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--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 | tp-match-set, 层操作 |
| `tp-reset` | 完全替换所有文本属性 | tp--parse-args, tp--handle-tp-text | tp-match-reset |
| `tp-add` | 深度合并属性 | tp--parse-args, tp--deep-merge-plist, tp--prepend-face | tp-match-add |
| `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 |
#### 获取属性
| 函数 | 描述 | 依赖 | 被依赖 |
@ -226,39 +286,39 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
| 函数 | 描述 | 依赖 | 被依赖 |
|------|------|------|--------|
| `tp-remove` | 移除属性或子属性 | tp--remove-property, tp--remove-sub, tp--remove-*-from-string | 用户 API |
| `tp-clear` | 清除所有属性 | - | 用户 API |
钩子变量：`tp--tp-text-handler-function`（定义于此，由 tp-render.el 安装为 `tp--handle-tp-text-property`）；`tp--handle-tp-text` 是它的调用入口，未安装时 `tp-text` 属性按普通属性处理。
| `tp-clear` | 清除所有属性（显式返回 nil） | - | 用户 API |
---
### tp-search.el：模式匹配与搜索
依赖 tp-core、tp-layer、tp-ops。提供模式匹配式属性应用、属性搜索与导航。
依赖 tp-core、tp-reactive、tp-layer、tp-ops（0.3.0 新增 tp-reactive 依赖：应用器写入缓冲区后经 `tp--search-register-layer-buffer` 登记层→缓冲区注册表）。提供模式匹配式属性应用、属性搜索与导航。
#### 模式匹配
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-match-set` / `tp-match-reset` / `tp-match-add` | 在字符串匹配处设置/重置/合并属性 | tp--match-apply |
| `tp-regexp-set` / `tp-regexp-reset` / `tp-regexp-add` | 在正则匹配处设置/重置/合并属性 | tp--regexp-apply |
| `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` | 共享的模式匹配引擎（空模式/零宽模式安全） | tp-set/tp-reset/tp-add 风格的 apply-fn |
| `tp--deep-merge-apply` / `tp--reset-apply` | 传给引擎的合并/重置回调 | tp--deep-merge-plist 等 |
| `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-search-forward` | 向前搜索属性 | text-property-search-forward |
| `tp-search-backward` | 向后搜索属性 | tp--property-search-backward |
| `tp--property-search-backward` | 带等值谓词的向后搜索（与向前语义对称） | text-property-search-backward |
| `tp-forward` | 向前搜索 N 次并移动点 | tp-search-forward |
| `tp-backward` | 向后搜索 N 次并移动点 | tp-search-backward |
| `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.0，make-obsolete）**：裸封装原语，nil-PREDICATE 默认语义与库内 `equal` 匹配相悖；请改用 `tp-forward` / `tp-backward`，或直接用 Emacs 原语 | text-property-search-* |
#### 遍历与替换
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-forward-do` / `tp-backward-do` | 向前/向后搜索并对匹配执行函数 | tp--forward-do / tp--backward-do |
| `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 |
@ -268,51 +328,64 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
### tp-render.el：响应式渲染引擎
依赖 tp-core、tp-reactive、tp-layer、tp-ops、tp-search。这是唯一"知道"渲染如何进行的模块：它可以直接调用 `tp-search-map`、`tp-add` 等前置模块的函数，并在加载末尾把自己的入口函数**安装**进下层模块预留的钩子变量。
依赖 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--layer-render-props, tp-search-map |
| `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--handle-tp-text-property` | 处理 `tp-text` 属性（文本替换） | tp--tp-text-replace |
| `tp--update-reactive-text` | 变量变化后更新响应式文本 | tp--replace-reactive-text-in-buffer |
| `tp--replace-reactive-text-in-buffer` | 在缓冲区中替换响应式文本 | - |
| `tp--tp-text-transform` | 应用 `:transform` 转换（首次渲染同样生效） | tp-layer-transforms |
| `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、合并层定义、重渲染或入批量队列（嵌套写入经队列而非递归）。安装为 `tp--reactive-update-function` |
| `tp--reactive-flush-entry` | 批量队列刷新时的重渲染入口。安装为 `tp--reactive-flush-function` |
| `tp--reactive-apply-update` | 变量变化的完整处理：更新 computed、合并层定义、重渲染或入批量队列（嵌套写入经队列而非递归）。尾部刷新置于 `unwind-protect` 清理段中，重渲染抛错也不会把队列条目困死。安装为 `tp--reactive-update-function` |
加载末尾执行安装：
加载末尾执行安装（与源码逐字一致）：
```elisp
(setq tp--reactive-update-function #'tp--reactive-apply-update)
(setq tp--reactive-flush-function #'tp--reactive-flush-entry)
(setq tp--tp-text-handler-function #'tp--handle-tp-text-property)
(setq tp--layer-refresh-function #'tp--update-layer-regions)
(setq tp--layer-refresh-function #'tp--update-layer-regions)
```
---
### tp-stack.el：属性层栈操作
依赖 tp-core、tp-layer、tp-ops。所有栈变更函数建立在共享的裁剪式区域遍历之上，区域操作不会影响 [START, END) 之外的文本。
依赖 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--parse-layer-args` | 解析层操作的灵活参数 | - |
| `tp--stack-map-region` | 按区间遍历区域内层栈的共享引擎 | tp--map-intervals 风格遍历 |
| `tp--stack-build-props` | 从层列表构建栈属性（单层栈不携带 `tp-layers`） | - |
| `tp--put-layer-specs` | 展开层规格（层名/内联 plist/层名列表/参数化/层组） | tp--normalize-layer-spec, tp-group-props(-with-arg) |
| `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 |
@ -320,25 +393,29 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
#### 层操作（公开 API）
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-put-layer` | 在指定索引放置层（区域局部） | tp--put-layer-specs, tp--stack-map-region |
| `tp-push-layer` | 将层推到顶部 | tp-put-layer |
| `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-rotate-layer` | 轮换层 | tp-move-layer |
| `tp-pin-layer` | 将层置顶 | tp-move-layer |
| `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-merge-layers` | 合并多个层（显式 nil 值保留） | tp--merge-layer-props, tp--stack-map-region |
| `tp-flatten-layers` | 扁平化所有层 | tp--merge-layer-props, 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 |
#### 层查询
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-layer-list` | 列出所有层名称 | tp--stack-map-region |
| `tp-layer-count` | 计算层数量 | tp--stack-map-region |
| `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-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 |
#### 层属性操作
@ -351,16 +428,18 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
### tp-palette.el：调色板数据
只依赖 tp-core（及 subr-x）。明/暗主题双值调色板系统，`tp-palette-alist` 是唯一数据源。
**不依赖任何 tp- 模块**（仅 subr-x），是独立的叶模块。明/暗主题双值调色板系统，`tp-palette-alist` 是唯一数据源。
| 函数/宏/变量 | 描述 |
|------|------|
| `define-tp-palette` | 定义调色板（重定义立即生效） |
| `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-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-color` | 通用的主题解析取色器（0.3.0 新增的首选查询入口） |
| `tp-palette-has-p` | 谓词整合入口：KIND 取 `:fg`/`:bg`/`:border`/nil（0.3.0 新增） |
| `tp-palette-fg-color` / `tp-palette-bg-color` / `tp-palette-border-color` | 取前景/背景/边框色（兼容便捷函数） |
| `tp-palette-p` / `tp-palette-fg-p` / `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p` | 调色板谓词（兼容便捷函数） |
| `tp-palette-pure` | 取纯色值 |
---
@ -374,20 +453,46 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
| 内置层 | `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` | 符号加后缀助手 |
| `tp--suffix-symbol` | 符号加后缀助手（0.3.0 起转为私有；`tp-suffix-symbol` 保留为废弃兼容别名） |
---
## 钩子变量：唯一许可的反向调用
分层规则的唯一例外是四个**钩子变量**：下层模块声明变量并在需要时 `funcall`，实现由 tp-render.el 在加载时安装。这样下层模块不必 `require` 上层模块，依赖图保持严格单向；而在未加载 tp-render 时，下层模块依然可用（钩子为 nil 时优雅降级）。
分层规则的唯一例外是两个**钩子变量**：下层模块声明变量并在需要时 `funcall`，实现由 tp-render.el 在加载时安装。这样下层模块不必 `require` 上层模块，依赖图保持严格单向；而在未加载 tp-render 时，下层模块依然可用（钩子为 nil 时优雅降级：层可以定义与应用，只是没有自动重渲染）。
| 钩子变量 | 声明于 | 安装的实现（tp-render.el） | 用途 |
|----------|--------|---------------------------|------|
| `tp--reactive-update-function` | tp-reactive.el | `tp--reactive-apply-update` | 变量监听器触发的重计算与重渲染 |
| `tp--reactive-flush-function` | tp-reactive.el | `tp--reactive-flush-entry` | 批量更新队列刷新时的重渲染 |
| `tp--layer-refresh-function` | tp-layer.el | `tp--update-layer-regions` | 层重定义后刷新已应用区域 |
| `tp--tp-text-handler-function` | tp-ops.el | `tp--handle-tp-text-property` | `tp-set` 等操作中处理 `tp-text` 属性 |
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 各注册表（计数器除外）。
---
@ -401,26 +506,31 @@ 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 / 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 [tp-ops]
│ ╌╌▷ tp--handle-tp-text-property [tp-render]（经钩子）
├── tp--handle-tp-text-property [tp-ops]（0.3.0 起同模块直接调用，不再经钩子）
│ └── tp--tp-text-transform / tp--tp-text-replace [tp-ops]
├── tp--apply-props-to-string [tp-ops]（整串形式，返回新字符串）
└── set-text-properties / put-text-property（Emacs 原生，区域形式）
├── set-text-properties / put-text-property（Emacs 原生，区域形式）
└── tp--ops-register-layer-buffer [tp-ops]（缓冲区目标）
└── tp-reactive--register-layer-buffer [tp-reactive]
```
### tp-add 调用链
```
tp-add [tp-ops]
├── tp--parse-args [tp-ops]
├── tp--handle-tp-text [tp-ops] ╌╌▷ tp--handle-tp-text-property [tp-render]
├── tp--handle-tp-text-property [tp-ops]（直接调用）
├── text-properties-at（Emacs 原生）
├── tp--prepend-face [tp-core]（face 家族属性）
│ └── tp--deep-merge-plist [tp-core]
├── tp--deep-merge-plist [tp-core]（其他嵌套属性）
└── put-text-property（Emacs 原生）
├── put-text-property（Emacs 原生）
└── tp--ops-register-layer-buffer [tp-ops]
└── tp-reactive--register-layer-buffer [tp-reactive]
```
### define-tp 调用链
@ -429,7 +539,7 @@ 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--unregister-reactive-deps [tp-reactive]（连带移除旧的缓冲区注册表条目）
├── tp--ensure-reactive-variables [tp-reactive]
├── tp--register-layer-data [tp-reactive]
│ └── add-variable-watcher（Emacs 原生）
@ -455,8 +565,11 @@ tp-push-layer [tp-stack]
│ │ └── 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-build-props [tp-stack]
└── set-text-properties（Emacs 原生）
├── tp--stack-props-to-list [tp-layer]（解码既有栈，含隐藏层）
├── tp--stack-build-props [tp-layer]（编码新栈/渲染缓存）
├── set-text-properties（Emacs 原生）
└── tp--stack-register-layers [tp-stack]
└── tp-reactive--register-layer-buffer [tp-reactive]
```
### 响应式更新调用链
@ -470,15 +583,27 @@ tp-push-layer [tp-stack]
│ └── tp--set-layer-props [tp-layer]
├── tp--set-layer-props [tp-layer]（深合并回层定义；setq-local 不写全局）
├── tp--update-layer-regions [tp-render]（属性更新）
│ └── tp-search-map [tp-search]
│ └── put-text-property
│ └── tp--map-layer-buffers [tp-render]
│ │（只访问注册表登记的缓冲区；unknown 层回退为
│ │ 一次学习性全扫描并登记命中缓冲区）
│ ├── tp-reactive-layer-buffers [tp-reactive]
│ ├── tp--buffer-has-layer-region-p [tp-layer]（回退路径）
│ └── 每缓冲区：
│ ├── tp-search-map [tp-search] → put-text-property
│ └── tp--write-layer-through-stack-storage [tp-render]
│ └── tp--stack-props-to-list /
│ tp--stack-build-props [tp-layer]
│ （隐藏/被覆盖的层副本同步刷新）
└── tp--update-reactive-text [tp-render]（tp-text 文本替换）
└── tp--replace-reactive-text-in-buffer [tp-render]
└── tp--edit-region-minimal-diff [tp-render]
（最小差异、先插入后删除；文本相同则完全不动缓冲区）
批量模式（tp-with-batch-updates）/ 更新中的嵌套写入：
批量模式（tp-with-batch-updates [tp-render]）/ 更新中的嵌套写入：
└── tp--queue-batch-update [tp-reactive]（入队，不递归）
└── tp--flush-batch-updates [tp-reactive]（退出批量时）
└── ╌╌▷ tp--reactive-flush-entry [tp-render]（经钩子）
└── tp--flush-batch-updates [tp-render]（退出批量/最外层更新结束时；
置于 unwind-protect 清理段，重渲染抛错也会排空队列）
└── tp--reactive-flush-entry [tp-render]（0.3.0 起同模块直接调用，不再经钩子）
├── tp--update-layer-regions
└── tp--update-reactive-text
```
@ -487,9 +612,9 @@ tp-push-layer [tp-stack]
## 设计原则
1. **严格分层**：模块只允许 `require` 并调用排在它前面的模块，字节编译器强制检查依赖顺序
2. **钩子反转**：唯一许可的"向上调用"是四个钩子变量（`tp--tp-text-handler-function`、`tp--reactive-update-function`、`tp--reactive-flush-function`、`tp--layer-refresh-function`），由 tp-render.el 统一安装实现
3. **单一职责**：每个模块（和函数）只负责一件事
4. **复用优先**：共享引擎（`tp--map-intervals`、`tp--stack-map-region`、`tp--pattern-apply`、`tp--replace-match-text`）承载重复逻辑，高层函数复用而非复制
5. **统一接口**：所有核心属性函数支持相同的调用约定（整串/区域形式、层名、`$var`）
6. **响应式解耦**：tp-reactive/tp-layer/tp-ops 不依赖渲染引擎；不加载 tp-render 时钩子为 nil，各模块优雅降级
1. **严格分层**：模块只允许 `require` 并调用排在它前面的模块，字节编译器强制检查依赖顺序；且只声明真实存在的依赖（0.3.0 移除了 tp-stack→tp-ops 的幻影依赖，tp-palette 不依赖任何 tp- 模块）
2. **钩子反转**：唯一许可的"向上调用"是两个钩子变量（`tp--reactive-update-function`、`tp--layer-refresh-function`），由 tp-render.el 统一安装实现；能改写为下行调用的反转（tp-text 链、批量刷新）已在 0.3.0 改写掉
3. **单一职责**：每个模块（和函数）只负责一件事；一个子系统的完整生命周期住在一个模块里（匿名层的铸造/驻留/注销/GC 全在 tp-layer，层栈存储格式知识全在 tp-layer 的编解码器）
4. **复用优先**：共享引擎（`tp--map-intervals`、`tp--stack-map-region`、`tp--pattern-apply`、`tp--replace-match-text`、`tp-reactive--buffer-layer-names`）承载重复逻辑，高层函数复用而非复制
5. **统一接口**：所有核心属性函数支持相同的调用约定（整串/区域形式、层名、`$var`、多参数层）
6. **响应式解耦**：tp-reactive/tp-layer/tp-ops 不依赖渲染引擎；不加载 tp-render 时钩子为 nil，各模块优雅降级（`tp-text` 替换自 0.3.0 起随 tp-ops 即可用）；重渲染只访问层→缓冲区注册表登记的缓冲区，未知层才回退全扫描

63
tp-builtins-tests.el
View File

@ -234,5 +234,68 @@ tp-builtins restores the shipped layer definitions."
(should-not (tp-parse-color nil))
(should-error (tp-parse-color 42)))
;;; API-CONC-01: the two palette primaries
(ert-deftest tp-builtins-test-palette-color-generic-accessor ()
"tp-palette-color is the theme-resolving generic accessor."
(tp-builtins-test--with-background-mode 'light
(should (equal (tp-palette-color 'info :fg) "#0969da"))
(should (equal (tp-palette-color 'info :fg)
(tp-palette-fg-color 'info)))
(should (equal (tp-palette-color 'info :bg)
(tp-palette-bg-color 'info)))
(should (equal (tp-palette-color 'info :border)
(tp-palette-border-color 'info)))
(should-not (tp-palette-color 'no-such-palette :fg))
;; heatmap-g0 defines only :fg.
(should-not (tp-palette-color 'heatmap-g0 :bg)))
(tp-builtins-test--with-background-mode 'dark
(should (equal (tp-palette-color 'info :fg) "#58a6ff"))))
(ert-deftest tp-builtins-test-palette-has-p ()
"tp-palette-has-p tests palette registration and per-key presence."
(should (tp-palette-has-p 'info))
(should (tp-palette-has-p 'info :fg))
(should (tp-palette-has-p 'info :bg))
(should (tp-palette-has-p 'info :border))
(should (tp-palette-has-p 'heatmap-g0 :fg))
(should-not (tp-palette-has-p 'heatmap-g0 :bg))
(should-not (tp-palette-has-p 'heatmap-g0 :border))
(should-not (tp-palette-has-p 'no-such-palette))
(should-not (tp-palette-has-p 'no-such-palette :fg))
;; Unlike the suffix predicates, has-p takes the palette name
;; itself, not a NAME-fg variant symbol.
(should-not (tp-palette-has-p 'info-fg))
(should (tp-palette-fg-p 'info-fg)))
;;; DOC-STR-02: tp-suffix-symbol privatized behind an obsolete alias
(ert-deftest tp-builtins-test-suffix-symbol-obsolete-alias ()
"tp-suffix-symbol keeps working as an obsolete compatibility alias."
(should (eq (tp--suffix-symbol 'info "-fg") 'info-fg))
(should (eq (with-suppressed-warnings ((obsolete tp-suffix-symbol))
(tp-suffix-symbol 'info "-fg"))
'info-fg))
(should (eq (car (get 'tp-suffix-symbol 'byte-obsolete-info))
'tp--suffix-symbol)))
;;; API-NAME-02: prefix-conforming tp-define-palette alias
(ert-deftest tp-builtins-test-define-palette-alias ()
"tp-define-palette is a working macro alias of define-tp-palette."
(unwind-protect
(progn
(tp-define-palette tp-test-alias-palette
:fg ("#111111" . "#eeeeee"))
(should (tp-palette-p 'tp-test-alias-palette))
(tp-builtins-test--with-background-mode 'light
(should (equal (tp-palette-fg-color 'tp-test-alias-palette)
"#111111")))
(tp-builtins-test--with-background-mode 'dark
(should (equal (tp-palette-fg-color 'tp-test-alias-palette)
"#eeeeee"))))
(setq tp-palette-alist
(assq-delete-all 'tp-test-alias-palette tp-palette-alist))))
(provide 'tp-builtins-tests)
;;; tp-builtins-tests.el ends here

24
tp-builtins.el
View File

@ -90,11 +90,25 @@ its window."
`(face (,@(when border-color (list :box (list :color border-color))))))
(_ (error "Invalid palette: %S" palette)))))
(defun tp-suffix-symbol (symbol string)
(defun tp--suffix-symbol (symbol string)
"Intern the symbol named by SYMBOL's name with STRING appended.
For example (tp--suffix-symbol \\='info \"-fg\") returns `info-fg'.
A generic helper with no tp semantics of its own, used by
`tp-palette-show' to build the suffixed palette variant names."
(intern (concat (symbol-name symbol) string)))
(define-obsolete-function-alias 'tp-suffix-symbol
'tp--suffix-symbol "0.3.0")
;;;###autoload
(defun tp-palette-show ()
"Display a gallery of every palette registered in `tp-palette-alist'.
Shows the read-only buffer *tp-palette-gallery* listing, for each
palette NAME, the symbols the `tp-palette' layer accepts: NAME itself
\(foreground, background and border together) plus the NAME-fg,
NAME-bg, NAME-fbg and NAME-border variants, each label rendered in
the colors it selects for the current theme. Press \\`q' to quit
the gallery window."
(interactive)
(let ((alist (seq-reverse tp-palette-alist)))
(tp-switch-to-buffer "*tp-palette-gallery*"
@ -109,19 +123,19 @@ its window."
" "
(tp-set (concat name "-fg")
'tp-palette
(tp-suffix-symbol symbol "-fg"))
(tp--suffix-symbol symbol "-fg"))
" "
(tp-set (concat name "-bg")
'tp-palette
(tp-suffix-symbol symbol "-bg"))
(tp--suffix-symbol symbol "-bg"))
" "
(tp-set (concat name "-fbg")
'tp-palette
(tp-suffix-symbol symbol "-fbg"))
(tp--suffix-symbol symbol "-fbg"))
" "
(tp-set (concat name "-border")
'tp-palette
(tp-suffix-symbol symbol "-border")))))
(tp--suffix-symbol symbol "-border")))))
alist "\n")))))
(define-tp tp-fg (color)

65
tp-core-tests.el
View File

@ -68,5 +68,70 @@
"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

69
tp-core.el
View File

@ -29,9 +29,6 @@
:prefix "tp-"
:group 'development)
(defvar tp--anonymous-layer-counter 0
"Counter for generating unique anonymous layer names.")
(defcustom tp-debug-mode nil
"When non-nil, enable debug logging for reactive updates.
Debug messages are logged to the *tp-debug* buffer and optionally
@ -68,7 +65,8 @@ If nil, debug messages are only logged to the *tp-debug* buffer."
;; Misc
yank-handler auto-composed evaporate face-alias)
"List of built-in Emacs text property names.
These property names are reserved and cannot be used as layer names in `define-tp'.
These property names are reserved and cannot be used as layer names
in `define-tp'.
An error is signaled at macro expansion time (when the `define-tp' form is
evaluated) if a reserved name is used, preventing the layer definition from
being created.")
@ -95,6 +93,7 @@ FORMAT-STRING and ARGS are passed to `format'."
(when tp-debug-echo
(message "[tp] %s" msg)))))
;;;###autoload
(defun tp-debug-clear ()
"Clear the *tp-debug* buffer."
(interactive)
@ -102,16 +101,12 @@ FORMAT-STRING and ARGS are passed to `format'."
(with-current-buffer buf
(erase-buffer))))
;;;###autoload
(defun tp-debug-show ()
"Show the *tp-debug* buffer."
(interactive)
(pop-to-buffer (get-buffer-create "*tp-debug*")))
(defun tp--generate-anonymous-layer-name ()
"Generate a unique symbol for anonymous reactive layers."
(setq tp--anonymous-layer-counter (1+ tp--anonymous-layer-counter))
(intern (format "tp-anon-%d" tp--anonymous-layer-counter)))
(defmacro tp-with-current-buffer (buffer-or-name &rest body)
"Execute BODY in BUFFER-OR-NAME with `inhibit-read-only' bound to t."
(declare (indent defun))
@ -119,19 +114,28 @@ FORMAT-STRING and ARGS are passed to `format'."
(let ((inhibit-read-only t))
,@body)))
(defun tp-intervals (start end &optional object)
(defun tp-intervals (start end &optional object absolute)
"Return list of property intervals from START to END in OBJECT.
Each element is (START END PROPERTIES). OBJECT defaults to current buffer.
For buffers, returns positions relative to START (0-based offsets).
For strings, returns absolute positions.
Each element is (START END PROPERTIES). OBJECT defaults to current
buffer.
For buffers, positions are by default relative to START (0-based
offsets, the legacy convention). When ABSOLUTE is non-nil they are
native 1-based buffer positions instead, directly reusable in other
tp calls (`tp-set', `tp-remove', ...) without offset arithmetic.
For strings, positions are always absolute (0-based); ABSOLUTE
changes nothing.
Intervals that extend beyond the requested range are clipped to it, so
returned positions never fall outside [START, END)."
(let* ((intervals (object-intervals (or object (current-buffer))))
;; For buffers, object-intervals returns 0-based positions
;; but buffer positions are 1-based, so we need to adjust
(offset (if (stringp object) 0 (1- start)))
;; but buffer positions are 1-based, so we need to adjust:
;; subtracting (1- start) makes them START-relative, while
;; subtracting -1 restores native 1-based positions.
(offset (cond ((stringp object) 0)
(absolute -1)
(t (1- start))))
;; Filter bounds in 0-based terms for buffers
(filter-start (if (stringp object) start offset))
(filter-start (if (stringp object) start (1- start)))
(filter-end (if (stringp object) end (1- end))))
(mapcar (lambda (tp)
(let* ((tp-start (- (max (nth 0 tp) filter-start) offset))
@ -455,7 +459,8 @@ Example:
(tp--merge-duplicate-keys \\='(face bold face (:foreground \"red\")))
=> (face ((:foreground \"red\") bold))
(tp--merge-duplicate-keys \\='(face (:background \"blue\") face (:foreground \"red\")))
(tp--merge-duplicate-keys
\\='(face (:background \"blue\") face (:foreground \"red\")))
=> (face (:background \"blue\" :foreground \"red\"))
(tp--merge-duplicate-keys \\='(prop1 a prop2 b prop1 c))
@ -555,7 +560,8 @@ Returns a list of reactive symbols found."
(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 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
@ -757,9 +763,28 @@ order."
(setq pos next)))
(nreverse results))))))
(defun tp-intervals-map (function start end &optional object)
"Apply FUNCTION to all intervals between START and END in OBJECT.
FUNCTION receives (i-start i-end top-props below-props-lst)."
(defun tp-intervals-map (function start end &optional object absolute)
"Apply FUNCTION to each property interval of [START, END) in OBJECT.
FUNCTION is called with (I-START I-END TOP-PROPS BELOW-PROPS-LST) for
every interval `tp-intervals' reports, splitting the layer-stack
bookkeeping out of the raw properties:
- TOP-PROPS is the interval's property plist with the `tp-layers'
entry removed: the directly rendered properties.
- BELOW-PROPS-LST is the value of the interval's `tp-layers'
property: the list of stored layer plists (normally the layers
buried below the rendered top layer; while any layer is hidden it
holds the whole ordered stack - see `tp-layer-stack-at' for the
decoded view). It is nil when the interval carries no layer stack.
I-START/I-END follow `tp-intervals' coordinates: for buffers they
are by default relative to START (0-based offsets, the legacy
convention), or native 1-based buffer positions when ABSOLUTE is
non-nil; for strings they are always absolute 0-based positions.
OBJECT is a string, a buffer, or nil for the current buffer.
Returns the list of FUNCTION's non-nil results, in interval order
\(nil results are dropped)."
(remove
nil
(mapcar
@ -775,7 +800,7 @@ FUNCTION receives (i-start i-end top-props below-props-lst)."
(funcall function
interval-start interval-end
top-props below-props-lst)))
(tp-intervals start end object))))
(tp-intervals start end object absolute))))
(provide 'tp-core)
;;; tp-core.el ends here

383
tp-doctest.el
View File

@ -23,16 +23,17 @@
(require 'tp)
(tp-layer-reset)
(defvar fails 0)
(defvar total 0)
(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 total (1+ total))
(setq tp-doctest--total (1+ tp-doctest--total))
(if (equal got exp)
(princ (format "PASS %s\n" ,label))
(setq fails (1+ fails))
(princ (format "FAIL %s\n expected: %S\n got: %S\n" ,label exp got)))))
(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))))
@ -97,12 +98,15 @@
(tp-layer-props 'full-name-layer)))
;; ---- tp-set my-style ----
(chk-str "S-mystyle" "#(\" \" 0 1 (face (:foreground \"blue\") tp-name my-style))"
(progn
(define-tp my-style ()
:props '(face (:foreground $my-color))
:data '((my-color . "blue")))
(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)
@ -195,6 +199,7 @@
(list (substring-no-properties my-string) (nreverse positions))))
;; ---- Layer definitions ----
(defvar my-color)
(chk "L-format3" '((:foreground "blue") "status: active")
(progn
(tp-layer-reset)
@ -230,21 +235,29 @@
'("first-quarter" . (display "🌓"))
'("full" . (display "🌕")))
(tp-layer-props 'moon-phases-full)))
(chk-str "L-paramgroup"
"#(\"emacs\" 0 5 (face (:foreground \"orange\") tp-name tp-test-l1 tp-layers ((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)
(tp-set "emacs" 'tp-test-group1 "orange")))
;; 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
@ -456,6 +469,8 @@
'("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)
@ -484,6 +499,7 @@
(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")
@ -548,7 +564,318 @@
(list (tp-forward-do #'upcase 'marker nil str 3)
(substring-no-properties str))))
(princ (format "\nTOTAL: %d FAILS: %d\n" total fails))
(when (> fails 0) (kill-emacs 1))
;; ---- 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

368
tp-layer-tests.el
View File

@ -338,5 +338,373 @@
(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

749
tp-layer.el
View File

File diff suppressed because it is too large Load Diff

310
tp-ops.el
View File

@ -14,31 +14,236 @@
;; The public property primitives: `tp-set', `tp-reset', `tp-add',
;; `tp-get', `tp-at', `tp-remove', `tp-clear', built on the shared
;; argument parser. Layer names in property specs are resolved through
;; tp-layer.el. The reactive `tp-text' property is handled through
;; `tp--tp-text-handler-function', installed by tp-render.el.
;; tp-layer.el. The reactive `tp-text' property is handled here by
;; `tp--handle-tp-text-property' and its helper chain; re-rendering on
;; later variable changes lives in tp-render.el, which calls back down
;; into these helpers.
;;; Code:
(require 'cl-lib)
(require 'dash)
(require 'tp-core)
(require 'tp-reactive)
(require 'tp-layer)
(defvar tp--tp-text-handler-function nil
"Function that handles the reactive `tp-text' property, or nil.
Installed by tp-render.el. Called with (START END PROPS OBJECT
PRESERVE-PROPS MERGE-MODE) and must return (PROPS NEW-END NEW-OBJECT).
When nil, `tp-text' is treated as an ordinary text property.")
(defun tp--find-tp-text-reactive-var (layer-name)
"Find the reactive variable symbol used for tp-text in LAYER-NAME.
Returns the variable symbol (e.g., tp-test-counter) if tp-text uses a
reactive variable (e.g., $tp-test-counter), or nil if not found.
Searches through `tp-reactive-deps' to find the original reactive props."
(catch 'found
(dolist (dep tp-reactive-deps)
(let* ((var-sym (car dep))
(layer-entry (assoc layer-name (cdr dep))))
(when layer-entry
(let ((reactive-props (cdr layer-entry)))
;; Check if tp-text in reactive-props uses this variable
(when (plist-member reactive-props 'tp-text)
(let ((tp-text-val (plist-get reactive-props 'tp-text)))
;; Check if tp-text-val is a reactive symbol for this variable
(when (and (tp--reactive-symbol-p tp-text-val)
(eq (tp--reactive-var-symbol tp-text-val) var-sym))
(throw 'found var-sym))))))))
nil))
(defun tp--handle-tp-text (start end props object preserve-props merge-mode)
"Dispatch `tp-text' handling for PROPS between START and END in OBJECT.
PRESERVE-PROPS and MERGE-MODE are forwarded to the installed handler.
Returns (PROPS NEW-END NEW-OBJECT); a pass-through when no handler is
installed (see `tp--tp-text-handler-function')."
(if tp--tp-text-handler-function
(funcall tp--tp-text-handler-function
start end props object preserve-props merge-mode)
(list props end object)))
(defun tp--tp-text-transform (layer-name text)
"Return TEXT transformed by LAYER-NAME's `:transform', or TEXT.
Transform errors are reported and TEXT is returned unchanged; a
non-string transform result is ignored as well."
(let ((transform-fn (when layer-name
(cdr (assoc layer-name tp-layer-transforms)))))
(if (not transform-fn)
text
(condition-case err
(let ((result (funcall transform-fn text)))
(tp-debug-log " Transform %s: %S -> %S" layer-name text result)
(if (stringp result) result text))
(error
(message "tp: transform error for %s: %s" layer-name err)
text)))))
(defun tp--merge-embedded-props (embedded props)
"Merge the EMBEDDED string props plist under PROPS; PROPS win.
Like `tp--merge-string-props-into-plist' but takes the embedded plist
directly instead of sampling position 0 of a string, so callers can
merge per property interval. Face-family values (see
`tp-face-properties') are merged with PROPS taking precedence; other
conflicting keys keep the PROPS value; keys only in EMBEDDED are
added."
(let ((result (copy-sequence props)))
(cl-loop for (key val) on embedded by #'cddr
do (let ((existing (plist-get result key)))
(setq result
(plist-put result key
(if existing
(if (memq key tp-face-properties)
(tp--merge-face-values val existing)
existing)
val)))))
result))
(defun tp--put-text-property-unless-equal (start end key val object)
"Apply KEY -> VAL over [START, END) of OBJECT unless already there.
Like `put-text-property', but when every position of the span already
holds a value `equal' to VAL for KEY the call is skipped, so an
update that changes nothing does not flip the buffer-modified flag.
OBJECT is a string, a buffer, or nil for the current buffer."
(when (< start end)
(unless (and (equal (get-text-property start key object) val)
(>= (or (next-single-property-change start key object end)
end)
end))
(put-text-property start end key val object))))
(defun tp--apply-reactive-text-props (source props offset &optional target)
"Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET.
SOURCE is the (possibly propertized) replacement string; TARGET is a
string, or nil for the current buffer. For every embedded-property
interval of SOURCE the interval's props are merged under PROPS (see
`tp--merge-embedded-props') and the result is applied to the
corresponding span of TARGET shifted by OFFSET. This keeps
per-interval styling of propertized reactive strings intact instead
of smearing position-0 props across the whole region. Spans that
already carry an `equal' value are left untouched, so an update that
changes nothing does not mark the buffer as modified."
(tp--map-intervals
source nil nil
(lambda (istart iend str-props)
(let ((merged (if str-props
(tp--merge-embedded-props str-props props)
props)))
(cl-loop for (key val) on merged by #'cddr
do (tp--put-text-property-unless-equal
(+ offset istart) (+ offset iend) key val target))))))
(defun tp--tp-text-replace (start end final-text result-props object preserve-props)
"Replace [START, END) of OBJECT with FINAL-TEXT, handling props.
Implements the text replacement of `tp--handle-tp-text-property' and
returns its (PROPS NEW-END NEW-OBJECT) result.
For a string OBJECT a NEW string is built as prefix + FINAL-TEXT +
suffix, so text outside the region survives. RESULT-PROPS (merged
per embedded interval of FINAL-TEXT) are applied to the replaced span
here, because callers can only apply props from index 0, which would
smear them over the preserved prefix; the returned NEW-END is 0 so
the caller's own application over [0, NEW-END) is a no-op.
For buffers the region text is replaced in place and the returned
NEW-END is the end of the inserted text; the caller applies
RESULT-PROPS itself.
When PRESERVE-PROPS is non-nil, properties present at START whose
keys RESULT-PROPS does not set are re-applied over the replacement."
(if (stringp object)
(let* ((plain (substring-no-properties final-text))
;; Splice: keep the string outside [start, end) intact.
(new-string (concat (substring object 0 start)
plain
(substring object end)))
(new-end (+ start (length plain)))
(existing-props (when preserve-props
(text-properties-at start object))))
;; Preserve non-conflicting existing props of the replaced region
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member result-props key)
(put-text-property start new-end key val new-string)))
;; Apply the merged props per embedded interval of FINAL-TEXT
(tp--apply-reactive-text-props final-text result-props start new-string)
(list result-props 0 new-string))
;; Buffer object
(with-current-buffer (or object (current-buffer))
(let ((old-text (buffer-substring-no-properties start end)))
(if (equal old-text (substring-no-properties final-text))
;; Same text content, no replacement needed
(list result-props end object)
;; Need to replace text
(let ((existing-props (when preserve-props
(text-properties-at start)))
(inhibit-read-only t))
(save-excursion
(delete-region start end)
(goto-char start)
;; Insert without properties - the caller applies RESULT-PROPS
(insert (substring-no-properties final-text)))
(let ((new-end (+ start (length final-text))))
;; Re-apply existing properties to new text region if preserving
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member result-props key)
(put-text-property start new-end key val object)))
(list result-props new-end object))))))))
(defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode)
"Handle tp-text property in PROPS for region from START to END in OBJECT.
If tp-text is nil, initialize it to the current text in the region;
when the layer has a `:transform', the displayed text is the
transformed value (matching later reactive updates) while the model -
the reactive variable and the `tp-text' property - keeps the raw text.
If tp-text is a string different from current text, replace the text.
When PRESERVE-PROPS is non-nil, existing text properties are preserved
on the replaced text (used by tp-set and tp-add).
MERGE-MODE is retained for backward compatibility but no longer
affects behavior.
All modes now preserve embedded text properties from tp-text, with props taking
precedence over embedded props when there's a conflict.
Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props,
NEW-END is the new end position after any text replacement, and
NEW-OBJECT is the new string object (only different for strings whose
text was replaced; see `tp--tp-text-replace' for the string-object
convention of a 0 NEW-END with pre-applied properties)."
(ignore merge-mode)
(if (not (plist-member props 'tp-text))
;; tp-text not in props - return unchanged
(list props end object)
(let ((tp-text-val (plist-get props 'tp-text))
(layer-name (plist-get props 'tp-name)))
(cond
;; tp-text is nil - initialize it to the current text
((null tp-text-val)
(let ((current-text
(if (stringp object)
(substring-no-properties object start end)
(with-current-buffer (or object (current-buffer))
(buffer-substring-no-properties start end)))))
;; If tp-text uses a reactive variable, update that variable to match
;; This ensures the reactive variable and buffer text stay in sync
(when layer-name
(when-let ((reactive-var (tp--find-tp-text-reactive-var layer-name)))
;; Update the reactive variable with the current text
;; Note: Using global `set` here because the layer definition is global.
;; When the variable is changed, the reactive watcher will update all
;; buffers that have this layer applied.
(set reactive-var current-text)
;; Also update the layer definition so future accesses see the new value
(let ((layer-props (cdr (assoc layer-name tp-layer-alist))))
(when layer-props
(tp--set-layer-props layer-name
(plist-put layer-props 'tp-text current-text))))))
(setq props (plist-put props 'tp-text current-text))
;; Apply the layer's :transform to the DISPLAYED text on this first
;; render too, so the initial rendering matches later reactive
;; updates. The model value stays the raw text.
(let ((display-text (tp--tp-text-transform layer-name current-text)))
(if (equal display-text current-text)
(list props end object)
(tp--tp-text-replace
start end display-text
(tp--merge-string-props-into-plist display-text props)
object preserve-props)))))
;; tp-text has a string value - replace the text in the region
((stringp tp-text-val)
;; Apply transform if layer has one registered
(let* ((final-text (tp--tp-text-transform layer-name tp-text-val))
;; Embedded text properties from tp-text are preserved in all
;; cases. The props passed to this function take precedence
;; over embedded props when there's a conflict (e.g. both have
;; a `face' property).
(result-props
(tp--merge-string-props-into-plist final-text props)))
(tp--tp-text-replace start end final-text result-props
object preserve-props)))
;; Other types - return unchanged
(t (list props end object))))))
(defun tp--parse-args (start-or-string end-or-prop props-or-val rest)
"Parse flexible function arguments and return (OBJECT START END PROPS).
@ -48,7 +253,8 @@ Supports multiple calling conventions:
3. String region: (START END PROPS STRING)
4. Entire string with plist: (STRING PROP VAL ...)
5. Entire string with layer: (STRING LAYER-NAME ARG)
6. Entire string with layer and extra props: (STRING LAYER-NAME ARG PROP VAL ...)"
6. Entire string with layer and extra props:
(STRING LAYER-NAME ARG PROP VAL ...)"
(let (object start finish props)
(cond
;; First arg is a string - apply to entire string
@ -110,6 +316,18 @@ Supports multiple calling conventions:
(setq props (or (tp--resolve-props props) props)))
(list object start finish props)))
(defun tp--ops-register-layer-buffer (props object)
"Record OBJECT in the reactive buffer registry for PROPS's layer.
When PROPS carries a `tp-name' (a resolved layer application) and
OBJECT is a buffer or nil (the current buffer), register that buffer
under the layer's name so reactive updates can walk only registered
buffers instead of scanning `buffer-list'. String OBJECTs are not
registered; see `tp-reactive-layer-buffers' for that gap."
(when-let ((layer-name (plist-get props 'tp-name)))
(when (or (null object) (bufferp object))
(tp-reactive--register-layer-buffer
layer-name (or object (current-buffer))))))
(defun tp--apply-props-to-string (str start end props &optional merge-mode)
"Apply PROPS to string STR from START to END, returning a NEW string.
This function does not modify the original string.
@ -166,10 +384,14 @@ Returns a new propertized string."
(defun tp-set (start-or-string &optional end-or-prop props-or-val &rest rest)
"Set text properties on string or buffer region.
Supports four calling conventions:
1. (tp-set START END PROPS) - current buffer
2. (tp-set START END PROPS BUFFER/STRING) - specific object
3. (tp-set STRING PROP VAL ...) - entire string
Supports five calling conventions:
1. (tp-set START END PROPS) - region of the current buffer
2. (tp-set START END PROPS OBJECT) - region of a buffer or string
3. (tp-set STRING PROP VAL ...) - entire string, flat prop/value pairs
4. (tp-set STRING LAYER-NAME [ARG]) - entire string, a defined
layer/group, optionally with its argument
5. (tp-set STRING LAYER-NAME ARG PROP VAL ...) - entire string, a
parameterized layer/group plus extra flat properties
PROPS can be a plist or a layer/group name symbol.
Preserves existing properties not specified in PROPS.
@ -189,7 +411,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
;; Handle tp-text property specially - :override means props override embedded props
(pcase-let ((`(,new-props ,new-finish ,new-object)
(tp--handle-tp-text start finish props object t :override)))
(tp--handle-tp-text-property start finish props object t :override)))
(setq props new-props finish new-finish object new-object)
(when (and (stringp object) (plist-member props 'tp-text))
(setq start 0)))
@ -214,12 +436,24 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
(set-text-properties start finish props object)
(cl-loop for (key val) on props by #'cddr
do (put-text-property start finish key val object))))
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(defun tp-reset (start-or-string &optional end-or-prop props-or-val &rest rest)
"Completely replace all text properties with PROPS.
Like `tp-set' but replaces ALL existing properties.
For tp-text, embedded text properties are preserved (props override if there's a conflict).
Supports the same five calling conventions as `tp-set':
1. (tp-reset START END PROPS) - region of the current buffer
2. (tp-reset START END PROPS OBJECT) - region of a buffer or string
3. (tp-reset STRING PROP VAL ...) - entire string, flat pairs
4. (tp-reset STRING LAYER-NAME [ARG]) - entire string, defined
layer/group
5. (tp-reset STRING LAYER-NAME ARG PROP VAL ...) - layer plus extra
flat properties
For tp-text, embedded text properties are preserved (props override
if there's a conflict).
**String Modification Behavior:**
- Entire string form (tp-reset STRING ...): Returns a NEW propertized string
@ -235,7 +469,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
;; Handle tp-text property - :reset means only use props, ignore embedded props
(pcase-let ((`(,new-props ,new-finish ,new-object)
(tp--handle-tp-text start finish props object nil :reset)))
(tp--handle-tp-text-property start finish props object nil :reset)))
(setq props new-props finish new-finish object new-object)
(when (and (stringp object) (plist-member props 'tp-text))
(setq start 0)))
@ -250,11 +484,22 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
;; Buffer: modify in place
(t
(set-text-properties start finish props object)
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest)
"Add or update text properties with deep merging.
Unlike `tp-set', deeply merges nested properties.
Supports the same five calling conventions as `tp-set':
1. (tp-add START END PROPS) - region of the current buffer
2. (tp-add START END PROPS OBJECT) - region of a buffer or string
3. (tp-add STRING PROP VAL ...) - entire string, flat pairs
4. (tp-add STRING LAYER-NAME [ARG]) - entire string, defined
layer/group
5. (tp-add STRING LAYER-NAME ARG PROP VAL ...) - layer plus extra
flat properties
For face-family properties (see `tp-face-properties': face,
font-lock-face, mouse-face), symbol faces are prepended to the
existing face list and face plists are deep-merged.
@ -275,7 +520,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
;; Handle tp-text property - :merge means embedded props are merged with props
(let ((has-tp-text (plist-member props 'tp-text)))
(pcase-let ((`(,new-props ,new-finish ,new-object)
(tp--handle-tp-text start finish props object t :merge)))
(tp--handle-tp-text-property start finish props object t :merge)))
(setq props new-props finish new-finish object new-object)
(when (and (stringp object) has-tp-text)
(setq start 0))))
@ -329,6 +574,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
(t val))))
(put-text-property pos next-pos key new-val object)))
(setq pos next-pos))))
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(defun tp-get (start-or-string &optional end-or-property &rest args)
@ -600,11 +846,15 @@ If PROPERTY is a layer name, all properties added by that layer are removed."
(next-pos (or (next-single-property-change pos 'tp-name object end) end)))
(when (eq tp-name-at-pos property)
;; This region has the layer applied - get the layer's property keys
;; For parameterized layers, we pass a dummy arg (t) since we only need key names
;; For parameterized layers, we pass dummy args (t per
;; parameter) since we only need key names
(let* ((layer-props
(cond
((tp-layer-parameterized-p property)
(tp-layer-props-with-arg property t nil)) ; arg=t, include-tp-name=nil
(tp-layer-props-with-args
property
(make-list (length (tp-layer-arglist property)) t)
nil))
((assoc property tp-layer-alist)
(tp-layer-props property nil)) ; include-tp-name=nil
((assoc property tp-layer-groups)
@ -898,7 +1148,8 @@ Returns a new plist (does not modify the original)."
OBJECT is a string or buffer; nil means the current buffer.
If START and END are not provided, they default to the whole of
OBJECT: 0/(length OBJECT) for strings, `point-min'/`point-max' of
OBJECT for buffers (the current buffer when OBJECT is nil)."
OBJECT for buffers (the current buffer when OBJECT is nil).
Returns nil."
(interactive)
(let ((beg (or start
(cond ((stringp object) 0)
@ -910,7 +1161,8 @@ OBJECT for buffers (the current buffer when OBJECT is nil)."
((bufferp object)
(with-current-buffer object (point-max)))
(t (point-max))))))
(set-text-properties beg finish nil object)))
(set-text-properties beg finish nil object)
nil))
(provide 'tp-ops)
;;; tp-ops.el ends here

70
tp-palette.el
View File

@ -42,6 +42,15 @@ definition updates the stored palette in place."
(declare (indent defun))
`(setf (alist-get ',name tp-palette-alist) '(,@plist)))
(defalias 'tp-define-palette 'define-tp-palette
"Register a color palette named NAME; alias of `define-tp-palette'.
This is the package-prefix-conforming name for the palette
definition macro, so it is discoverable via the tp- prefix;
`define-tp-palette' is the historical name and both are permanent -
neither will be removed. See `define-tp-palette' for the full
documentation of NAME and PLIST.")
(function-put 'tp-define-palette 'lisp-indent-function 'defun)
(define-tp-palette button-primary
:fg ("#ffffff" . "#ffffff") :bg ("#007bff" . "#007bff"))
@ -245,9 +254,11 @@ definition updates the stored palette in place."
;;; Utilities
(defun tp-theme-dark-p ()
"Return non-nil when the current frame's background mode is dark."
(eq (frame-parameter nil 'background-mode) 'dark))
(defun tp-theme-light-p ()
"Return non-nil when the current frame's background mode is light."
(eq (frame-parameter nil 'background-mode) 'light))
(defun tp-parse-color (color)
@ -284,11 +295,49 @@ back to the light color."
"Get color value for KEY from the palette named SYMBOL.
SYMBOL is looked up in `tp-palette-alist'. KEY should be one of
: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 point delegating here is `tp-palette-color'."
(let ((plist (alist-get symbol tp-palette-alist)))
(when (tp-palette--plistp plist)
(tp-parse-color (plist-get plist key)))))
(defun tp-palette-color (symbol key)
"Return the KEY color of the palette named SYMBOL, theme-resolved.
SYMBOL is looked up in `tp-palette-alist'; KEY is one of :fg, :bg or
:border. The stored color spec is resolved for the current theme by
`tp-parse-color', so a (LIGHT . DARK) cons yields the side matching
the frame's background mode. Returns nil when SYMBOL names no
registered palette, its definition has no KEY entry, or the entry
resolves to no color for the current theme.
This is the generic palette accessor; `tp-palette-fg-color',
`tp-palette-bg-color' and `tp-palette-border-color' are per-key
conveniences equivalent to calling it with a fixed KEY. See also
`tp-palette-has-p' to test for a palette or key without resolving a
color."
(tp-palette--get-color symbol key))
(defun tp-palette-has-p (symbol &optional kind)
"Return non-nil when SYMBOL names a palette that defines KIND.
With nil KIND, test only that SYMBOL names a palette registered in
`tp-palette-alist' (like `tp-palette-p'). Otherwise KIND is one of
:fg, :bg or :border, and the palette's definition must contain that
key. A defined key may still resolve to no color for the current
theme (for example a (LIGHT . nil) cons in dark mode); use
`tp-palette-color' when the resolved color itself matters.
Note that the suffix predicates `tp-palette-fg-p', `tp-palette-bg-p',
`tp-palette-fbg-p' and `tp-palette-border-p' answer a different
question: whether SYMBOL is a suffixed variant name like `info-fg'
naming a registered palette (the `tp-palette' layer's convention).
This predicate takes the palette name itself."
(let ((entry (assoc symbol tp-palette-alist)))
(cond ((null entry) nil)
((null kind) t)
(t (and (tp-palette--plistp (cdr entry))
(plist-member (cdr entry) kind)
t)))))
(defun tp-palette-fg-color (symbol)
"Get the foreground color from palette SYMBOL.
SYMBOL should be a symbol bound to a palette plist with a :fg key.
@ -308,33 +357,52 @@ Returns nil if SYMBOL is unbound or doesn't contain :border."
(tp-palette--get-color symbol :border))
(defun tp-palette-p (symbol)
"Return non-nil when SYMBOL names a registered palette.
The value is SYMBOL's entry in `tp-palette-alist'. See also the
generalized `tp-palette-has-p'."
(assoc symbol tp-palette-alist))
(defun tp-palette-fg-p (symbol)
"Return non-nil when SYMBOL is a NAME-fg variant of a palette NAME.
Tests the suffixed naming convention of the `tp-palette' layer, not
the palette contents; see `tp-palette-has-p' for the latter."
(save-match-data
(let ((str (symbol-name symbol)))
(and (string-match "\\(.+\\)-fg$" str)
(tp-palette-p (intern (match-string 1 str)))))))
(defun tp-palette-bg-p (symbol)
"Return non-nil when SYMBOL is a NAME-bg variant of a palette NAME.
Tests the suffixed naming convention of the `tp-palette' layer, not
the palette contents; see `tp-palette-has-p' for the latter."
(save-match-data
(let ((str (symbol-name symbol)))
(and (string-match "\\(.+\\)-bg$" str)
(tp-palette-p (intern (match-string 1 str)))))))
(defun tp-palette-fbg-p (symbol)
"Return non-nil when SYMBOL is a NAME-fbg variant of a palette NAME.
Tests the suffixed naming convention of the `tp-palette' layer (fg
plus bg), not the palette contents."
(save-match-data
(let ((str (symbol-name symbol)))
(and (string-match "\\(.+\\)-fbg$" str)
(tp-palette-p (intern (match-string 1 str)))))))
(defun tp-palette-border-p (symbol)
"Return non-nil when SYMBOL is a NAME-border variant of a palette NAME.
Tests the suffixed naming convention of the `tp-palette' layer, not
the palette contents; see `tp-palette-has-p' for the latter."
(save-match-data
(let ((str (symbol-name symbol)))
(and (string-match "\\(.+\\)-border$" str)
(tp-palette-p (intern (match-string 1 str)))))))
(defun tp-palette-pure (symbol)
"Return the palette name behind SYMBOL, stripping variant suffixes.
SYMBOL may be a registered palette name or one of its -fg/-bg/-fbg/
-border variants (see the `tp-palette' layer); signal an error for
anything else."
(pcase symbol
((pred tp-palette-p) symbol)
((pred tp-palette-fg-p)

195
tp-reactive.el
View File

@ -13,9 +13,10 @@
;; Reactive core of tp: storage for variable dependencies, watchers,
;; computed properties and data variables; registration/unregistration;
;; the variable-watcher shell and the batching queue. The actual
;; re-rendering of buffers lives in tp-render.el, which installs
;; itself via `tp--reactive-update-function' / `tp--reactive-flush-function'.
;; the variable-watcher shell and the batching queue state. The
;; actual re-rendering of buffers - including the queue flush and the
;; public `tp-with-batch-updates' macro - lives in tp-render.el, which
;; installs itself via `tp--reactive-update-function'.
;;; Code:
@ -40,6 +41,118 @@ Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).")
Each entry is a list (LAYER-NAME CHANGED-SYMBOLS WHERE TP-TEXT-AFFECTED).
Entries are created and widened by `tp--queue-batch-update'.")
(defvar tp--layer-buffers (make-hash-table :test 'equal)
"Hash table mapping layer names to buffers showing their regions.
Keys are layer names; values are lists of buffers registered via
`tp-reactive--register-layer-buffer'. Reactive updates walk only
these buffers instead of scanning `buffer-list' (see
`tp-reactive-layer-buffers'). A key holding an empty list means
\"known: no buffer shows this layer\", which is distinct from an
absent key (`unknown').")
(defvar tp--layer-buffers-hook-installed nil
"Non-nil once the registry's `kill-buffer-hook' pruner is installed.")
(defun tp-reactive--install-kill-buffer-hook ()
"Install the global `kill-buffer-hook' pruning the buffer registry.
Idempotent; guarded by `tp--layer-buffers-hook-installed'."
(unless tp--layer-buffers-hook-installed
(add-hook 'kill-buffer-hook #'tp-reactive--prune-killed-buffer)
(setq tp--layer-buffers-hook-installed t)))
(defun tp-reactive--prune-killed-buffer ()
"Drop the buffer being killed from `tp--layer-buffers'.
Runs on `kill-buffer-hook' with the dying buffer current. The layer
entries themselves are kept: an entry left with an empty list means
\"known: no buffer shows this layer\", not `unknown'."
(let ((buf (current-buffer)))
(maphash (lambda (layer bufs)
(when (memq buf bufs)
(puthash layer (delq buf bufs) tp--layer-buffers)))
tp--layer-buffers)))
(defun tp-reactive--register-layer-buffer (layer-name buffer)
"Register BUFFER as showing regions of layer LAYER-NAME.
Idempotent: registering the same live BUFFER again keeps a single
entry. Dead buffers and a nil LAYER-NAME are ignored. Installs the
`kill-buffer-hook' pruner on first use. See
`tp-reactive-layer-buffers' for the consumer side of the registry."
(when (and layer-name (buffer-live-p buffer))
(tp-reactive--install-kill-buffer-hook)
(let ((bufs (gethash layer-name tp--layer-buffers)))
(unless (memq buffer bufs)
(puthash layer-name (cons buffer bufs) tp--layer-buffers)))))
(defun tp-reactive-layer-buffers (layer-name)
"Return the live buffers registered as showing layer LAYER-NAME.
Return a list of live buffers - possibly empty, meaning \"known: no
buffer shows this layer\" - or the symbol `unknown' when LAYER-NAME
has no registry entry at all. Killed buffers still recorded in the
registry are dropped lazily by this accessor.
KNOWN GAP: inserting an already-propertized STRING into a buffer
bypasses the buffer operations that register buffers, so such a
buffer is missing here until a reactive update's full-scan fallback
finds it or `tp-reactive-track-buffer' is called on it."
(let ((bufs (gethash layer-name tp--layer-buffers 'unknown)))
(if (eq bufs 'unknown)
'unknown
(let ((live (cl-remove-if-not #'buffer-live-p bufs)))
(unless (= (length live) (length bufs))
(puthash layer-name live tp--layer-buffers))
live))))
(defun tp-reactive--buffer-layer-names (&optional buffer)
"Return the layer names present in BUFFER, in buffer order.
BUFFER defaults to the current buffer; a dead BUFFER yields nil.
Stack-aware: a layer counts as present when its name is the direct
`tp-name' text property of a run (the rendered top layer) or the
`tp-name' of any layer plist inside the run's `tp-layers'
stack-storage property (layers buried below the top, or hidden - see
tp-stack.el). The `tp-layers' value is read as a plain list of
plists, so this helper stays below the stack module. Names are
deduplicated with `equal'. This is the shared scan behind
`tp-reactive-track-buffer' and the anonymous-layer GC's liveness
test `tp--buffer-has-layer-region-p'."
(let ((buf (or buffer (current-buffer)))
(found nil))
(when (buffer-live-p buf)
(tp--map-intervals
buf nil nil
(lambda (_start _end props)
(let ((direct (plist-get props 'tp-name)))
(when (and direct (not (member direct found)))
(push direct found)))
(dolist (layer (plist-get props 'tp-layers))
(let ((name (plist-get layer 'tp-name)))
(when (and name (not (member name found)))
(push name found)))))))
(nreverse found)))
;;;###autoload
(defun tp-reactive-track-buffer (&optional buffer)
"Scan BUFFER for layer regions and register it in the buffer registry.
BUFFER defaults to the current buffer. Walk BUFFER's text-property
runs and register BUFFER for every layer name found - rendered top
layers (direct `tp-name') as well as layers inside `tp-layers' stack
storage (buried below another layer, or hidden) - so reactive updates
visit it without a full `buffer-list' scan.
Call this after inserting an already-propertized string into a
buffer: string application bypasses the buffer operations that
register buffers (see `tp-reactive-layer-buffers'), and this command
closes that gap. Return the list of layer names registered, in
buffer order."
(interactive)
(let* ((buf (or buffer (current-buffer)))
(found (tp-reactive--buffer-layer-names buf)))
(dolist (name found)
(tp-reactive--register-layer-buffer name buf))
(when (called-interactively-p 'interactive)
(message "tp: tracking %d layer(s) in %s"
(length found) (buffer-name buf)))
found))
(defvar tp--batch-update-active nil
"When non-nil, we are inside a `tp-with-batch-updates' form.")
@ -122,7 +235,11 @@ Only the reactive portions of the properties are stored for each variable."
;; Also clean up layer watchers, computed properties, and data
(tp--unregister-layer-watchers layer-name)
(tp--unregister-layer-computed layer-name)
(tp--unregister-layer-data layer-name))
(tp--unregister-layer-data layer-name)
;; Drop the layer's buffer-registry entry: an undefined (or about to
;; be redefined) layer must not linger as stale "known" state; the
;; next update or refresh falls back to a learning full scan.
(remhash layer-name tp--layer-buffers))
(defun tp--layer-has-reactive-deps-p (layer-name)
"Return non-nil if LAYER-NAME has reactive dependencies registered.
@ -138,11 +255,6 @@ SYMBOL NEWVAL WHERE OVERRIDE-ALIST) after the user watch callbacks
have run. When nil, variable changes only invoke watch callbacks and
no re-rendering happens.")
(defvar tp--reactive-flush-function nil
"Function flushing one pending batched update entry.
Installed by tp-render.el. Called with (LAYER-NAME WHERE
TP-TEXT-AFFECTED).")
(defun tp--reactive-variable-watcher (symbol newval operation where)
"Watcher function called when a reactive variable changes.
SYMBOL is the variable that changed.
@ -153,10 +265,10 @@ WHERE indicates where the variable was set:
- a buffer for `setq-local'
Updates all layers that depend on this variable.
Only 'set' operations trigger updates because:
- 'let'/'unlet': Temporary bindings that will be restored, no need to update UI
- 'makunbound': Variable is being undefined, not a value change
- 'defvaralias': Aliasing, the actual value change will trigger a separate 'set'
Only `set' operations trigger updates because:
- `let'/`unlet': Temporary bindings that will be restored, no need to update UI
- `makunbound': Variable is being undefined, not a value change
- `defvaralias': Aliasing, the actual value change will trigger a separate `set'
When `tp--batch-update-active' is non-nil, buffer updates are deferred until
the batch completes. Layer definitions are still updated immediately.
@ -205,48 +317,6 @@ NEWVAL is the new value, OLDVAL is the old value."
(error (message "tp: watcher error for %s watching %s: %s"
layer-name watch-sym err))))))))
(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"))
(when tp--reactive-flush-function
(funcall tp--reactive-flush-function
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))))
(defun tp--register-layer-watchers (layer-name watchers)
"Register WATCHERS for LAYER-NAME.
WATCHERS is a list of (VAR-SYMBOL CALLBACK) pairs."
@ -335,9 +405,10 @@ Also adds variable watchers so changes to data vars trigger computed updates."
(defun tp--ensure-reactive-variables (var-symbols)
"Ensure all VAR-SYMBOLS are defined as global variables.
VAR-SYMBOLS can be a list of symbols or cons cells (SYMBOL . INITIAL-VALUE).
If a variable is not bound, define it with the initial value (nil if not specified).
If a variable has an explicit initial value (cons cell), always update it to allow
re-definition to change initial values."
If a variable is not bound, define it with the initial value (nil if
not specified).
If a variable has an explicit initial value (cons cell), always update
it to allow re-definition to change initial values."
(dolist (sym var-symbols)
(let* ((is-cons (and (consp sym) (not (tp--reactive-symbol-p sym))))
(var-sym (cond
@ -353,6 +424,7 @@ re-definition to change initial values."
(unless (boundp var-sym)
(set var-sym initial-val))))))
;;;###autoload
(defun tp-reactive-reset ()
"Reset all reactive text property watchers and dependencies."
(interactive)
@ -364,7 +436,12 @@ re-definition to change initial values."
(setq tp-reactive-deps nil)
(setq tp-layer-watchers nil)
(setq tp-layer-computed nil)
(setq tp-layer-data nil))
(setq tp-layer-data nil)
;; Drop queued re-renders too: entries stranded by an error escaping
;; an update would otherwise survive the reset and replay against
;; freshly (re)defined layers on the next flush (ARCH-4).
(setq tp--batch-update-pending nil)
(clrhash tp--layer-buffers))
(provide 'tp-reactive)
;;; tp-reactive.el ends here

529
tp-render-tests.el
View File

@ -34,6 +34,17 @@
(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)."
@ -360,5 +371,523 @@
(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

643
tp-render.el
View File

@ -13,9 +13,12 @@
;; 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
;; installs itself into tp-reactive.el (update/flush hooks) and
;; tp-ops.el (`tp-text' handler).
;; 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:
@ -102,6 +105,88 @@ Returns an updated override-alist with the new computed values."
(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
@ -110,9 +195,18 @@ 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 all buffers that have the text property.
- 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
@ -131,91 +225,12 @@ variable values are honored."
(cl-loop for (key val) on props by #'cddr
do (put-text-property start end key val))
nil)
'tp-name layer-name)))))))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(funcall update-buffer))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(funcall update-buffer)))))))
(defun tp--find-tp-text-reactive-var (layer-name)
"Find the reactive variable symbol used for tp-text in LAYER-NAME.
Returns the variable symbol (e.g., tp-test-counter) if tp-text uses a
reactive variable (e.g., $tp-test-counter), or nil if not found.
Searches through `tp-reactive-deps' to find the original reactive props."
(catch 'found
(dolist (dep tp-reactive-deps)
(let* ((var-sym (car dep))
(layer-entry (assoc layer-name (cdr dep))))
(when layer-entry
(let ((reactive-props (cdr layer-entry)))
;; Check if tp-text in reactive-props uses this variable
(when (plist-member reactive-props 'tp-text)
(let ((tp-text-val (plist-get reactive-props 'tp-text)))
;; Check if tp-text-val is a reactive symbol for this variable
(when (and (tp--reactive-symbol-p tp-text-val)
(eq (tp--reactive-var-symbol tp-text-val) var-sym))
(throw 'found var-sym))))))))
nil))
(defun tp--tp-text-transform (layer-name text)
"Return TEXT transformed by LAYER-NAME's `:transform', or TEXT.
Transform errors are reported and TEXT is returned unchanged; a
non-string transform result is ignored as well."
(let ((transform-fn (when layer-name
(cdr (assoc layer-name tp-layer-transforms)))))
(if (not transform-fn)
text
(condition-case err
(let ((result (funcall transform-fn text)))
(tp-debug-log " Transform %s: %S -> %S" layer-name text result)
(if (stringp result) result text))
(error
(message "tp: transform error for %s: %s" layer-name err)
text)))))
(defun tp--merge-embedded-props (embedded props)
"Merge the EMBEDDED string props plist under PROPS; PROPS win.
Like `tp--merge-string-props-into-plist' but takes the embedded plist
directly instead of sampling position 0 of a string, so callers can
merge per property interval. Face-family values (see
`tp-face-properties') are merged with PROPS taking precedence; other
conflicting keys keep the PROPS value; keys only in EMBEDDED are
added."
(let ((result (copy-sequence props)))
(cl-loop for (key val) on embedded by #'cddr
do (let ((existing (plist-get result key)))
(setq result
(plist-put result key
(if existing
(if (memq key tp-face-properties)
(tp--merge-face-values val existing)
existing)
val)))))
result))
(defun tp--apply-reactive-text-props (source props offset &optional target)
"Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET.
SOURCE is the (possibly propertized) replacement string; TARGET is a
string, or nil for the current buffer. For every embedded-property
interval of SOURCE the interval's props are merged under PROPS (see
`tp--merge-embedded-props') and the result is applied to the
corresponding span of TARGET shifted by OFFSET. This keeps
per-interval styling of propertized reactive strings intact instead
of smearing position-0 props across the whole region."
(tp--map-intervals
source nil nil
(lambda (istart iend str-props)
(let ((merged (if str-props
(tp--merge-embedded-props str-props props)
props)))
(cl-loop for (key val) on merged by #'cddr
do (put-text-property (+ offset istart) (+ offset iend)
key val target))))))
'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.
@ -223,7 +238,10 @@ 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 all buffers that have the text property (setq 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
@ -241,179 +259,172 @@ it will be applied to the text before updating."
(tp--tp-text-transform layer-name raw-text)
raw-text)))
(when (and new-text (stringp new-text))
(save-excursion
(tp--replace-reactive-text-in-buffer
layer-name new-text props)))))))))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(funcall update-buffer))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(funcall update-buffer)))))))
;; 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."
(goto-char (point-min))
(let ((match (text-property-search-forward 'tp-name layer-name t))
(plain-text (substring-no-properties new-text)))
(while match
(let* ((m-start (prop-match-beginning match))
(m-end (prop-match-end match))
(old-text (buffer-substring-no-properties m-start m-end)))
(unless (equal old-text plain-text)
;; Text content differs: replace it, carrying over the existing
;; properties whose keys this layer does not set.
(let ((existing-props (text-properties-at m-start)))
(delete-region m-start m-end)
(goto-char m-start)
(insert plain-text)
(let ((new-end (+ m-start (length plain-text))))
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member props key)
(put-text-property m-start new-end key val))))))
;; 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))
;; Search for next match
(setq match (text-property-search-forward 'tp-name layer-name t)))))
(defun tp--tp-text-replace (start end final-text result-props object preserve-props)
"Replace [START, END) of OBJECT with FINAL-TEXT, handling props.
Implements the text replacement of `tp--handle-tp-text-property' and
returns its (PROPS NEW-END NEW-OBJECT) result.
For a string OBJECT a NEW string is built as prefix + FINAL-TEXT +
suffix, so text outside the region survives. RESULT-PROPS (merged
per embedded interval of FINAL-TEXT) are applied to the replaced span
here, because callers can only apply props from index 0, which would
smear them over the preserved prefix; the returned NEW-END is 0 so
the caller's own application over [0, NEW-END) is a no-op.
For buffers the region text is replaced in place and the returned
NEW-END is the end of the inserted text; the caller applies
RESULT-PROPS itself.
When PRESERVE-PROPS is non-nil, properties present at START whose
keys RESULT-PROPS does not set are re-applied over the replacement."
(if (stringp object)
(let* ((plain (substring-no-properties final-text))
;; Splice: keep the string outside [start, end) intact.
(new-string (concat (substring object 0 start)
plain
(substring object end)))
(new-end (+ start (length plain)))
(existing-props (when preserve-props
(text-properties-at start object))))
;; Preserve non-conflicting existing props of the replaced region
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member result-props key)
(put-text-property start new-end key val new-string)))
;; Apply the merged props per embedded interval of FINAL-TEXT
(tp--apply-reactive-text-props final-text result-props start new-string)
(list result-props 0 new-string))
;; Buffer object
(with-current-buffer (or object (current-buffer))
(let ((old-text (buffer-substring-no-properties start end)))
(if (equal old-text (substring-no-properties final-text))
;; Same text content, no replacement needed
(list result-props end object)
;; Need to replace text
(let ((existing-props (when preserve-props
(text-properties-at start)))
(inhibit-read-only t))
(save-excursion
(delete-region start end)
(goto-char start)
;; Insert without properties - the caller applies RESULT-PROPS
(insert (substring-no-properties final-text)))
(let ((new-end (+ start (length final-text))))
;; Re-apply existing properties to new text region if preserving
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member result-props key)
(put-text-property start new-end key val object)))
(list result-props new-end object))))))))
(defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode)
"Handle tp-text property in PROPS for region from START to END in OBJECT.
If tp-text is nil, initialize it to the current text in the region;
when the layer has a `:transform', the displayed text is the
transformed value (matching later reactive updates) while the model -
the reactive variable and the `tp-text' property - keeps the raw text.
If tp-text is a string different from current text, replace the text.
When PRESERVE-PROPS is non-nil, existing text properties are preserved
on the replaced text (used by tp-set and tp-add).
MERGE-MODE is retained for backward compatibility but no longer affects behavior.
All modes now preserve embedded text properties from tp-text, with props taking
precedence over embedded props when there's a conflict.
Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props,
NEW-END is the new end position after any text replacement, and
NEW-OBJECT is the new string object (only different for strings whose
text was replaced; see `tp--tp-text-replace' for the string-object
convention of a 0 NEW-END with pre-applied properties)."
(ignore merge-mode)
(if (not (plist-member props 'tp-text))
;; tp-text not in props - return unchanged
(list props end object)
(let ((tp-text-val (plist-get props 'tp-text))
(layer-name (plist-get props 'tp-name)))
(cond
;; tp-text is nil - initialize it to the current text
((null tp-text-val)
(let ((current-text
(if (stringp object)
(substring-no-properties object start end)
(with-current-buffer (or object (current-buffer))
(buffer-substring-no-properties start end)))))
;; If tp-text uses a reactive variable, update that variable to match
;; This ensures the reactive variable and buffer text stay in sync
(when layer-name
(when-let ((reactive-var (tp--find-tp-text-reactive-var layer-name)))
;; Update the reactive variable with the current text
;; Note: Using global `set` here because the layer definition is global.
;; When the variable is changed, the reactive watcher will update all
;; buffers that have this layer applied.
(set reactive-var current-text)
;; Also update the layer definition so future accesses see the new value
(let ((layer-props (cdr (assoc layer-name tp-layer-alist))))
(when layer-props
(tp--set-layer-props layer-name
(plist-put layer-props 'tp-text current-text))))))
(setq props (plist-put props 'tp-text current-text))
;; Apply the layer's :transform to the DISPLAYED text on this first
;; render too, so the initial rendering matches later reactive
;; updates. The model value stays the raw text.
(let ((display-text (tp--tp-text-transform layer-name current-text)))
(if (equal display-text current-text)
(list props end object)
(tp--tp-text-replace
start end display-text
(tp--merge-string-props-into-plist display-text props)
object preserve-props)))))
;; tp-text has a string value - replace the text in the region
((stringp tp-text-val)
;; Apply transform if layer has one registered
(let* ((final-text (tp--tp-text-transform layer-name tp-text-val))
;; Embedded text properties from tp-text are preserved in all
;; cases. The props passed to this function take precedence
;; over embedded props when there's a conflict (e.g. both have
;; a `face' property).
(result-props
(tp--merge-string-props-into-plist final-text props)))
(tp--tp-text-replace start end final-text result-props
object preserve-props)))
;; Other types - return unchanged
(t (list props end object))))))
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)
@ -442,59 +453,103 @@ installed as `tp--reactive-update-function'."
(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)
(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.
(unless tp--batch-update-active
(when tp--batch-update-pending
(tp--flush-batch-updates))))))
(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. Installed as
`tp--reactive-flush-function'."
\(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--reactive-flush-function #'tp--reactive-flush-entry)
(setq tp--tp-text-handler-function #'tp--handle-tp-text-property)
(setq tp--layer-refresh-function #'tp--update-layer-regions)
(provide 'tp-render)

63
tp-run-shuffled.el Normal file
View File

@ -0,0 +1,63 @@
;;; tp-run-shuffled.el --- run the ERT suite in a shuffled order -*- 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:
;; Development script (not part of the installed package): runs every
;; loaded ERT test individually in a shuffled order to catch
;; inter-test state leaks that the fixed definition order hides.
;;
;; ERT's `member' selector does NOT control execution order (tests
;; always run in definition order), so this script loops over the
;; shuffled names and runs each test on its own.
;;
;; Usage (after loading tp and all *-tests.el files):
;; emacs -Q --batch -L . -l tp.el -l tp-tests.el ... -l tp-run-shuffled.el
;; or: make test-shuffled
;;
;; The shuffle seed is printed; reproduce a failing order with
;; SHUFFLE_SEED=<seed> make test-shuffled
;;; Code:
(require 'ert)
(require 'cl-lib)
(defun tp-run-shuffled--permute (list state)
"Return LIST deterministically permuted from integer seed STATE."
(let* ((v (vconcat list))
(n (length v)))
(dotimes (i (1- n))
;; Simple LCG so a printed seed reproduces the exact order.
(setq state (mod (+ (* state 1103515245) 12345) 2147483648))
(let* ((j (+ i (mod state (- n i))))
(tmp (aref v i)))
(aset v i (aref v j))
(aset v j tmp)))
(append v nil)))
(let* ((names (mapcar #'ert-test-name (ert-select-tests t t)))
(seed (let ((env (getenv "SHUFFLE_SEED")))
(if (and env (not (string-empty-p env)))
(string-to-number env)
(progn (random t) (abs (random 1000000))))))
(shuffled (tp-run-shuffled--permute names seed))
(unexpected 0))
(message "tp: running %d tests in shuffled order (SHUFFLE_SEED=%d)"
(length shuffled) seed)
(dolist (name shuffled)
(let ((stats (ert-run-tests-batch name)))
(cl-incf unexpected (ert-stats-completed-unexpected stats))))
(message "tp: shuffled run complete: %d tests, %d unexpected (seed %d)"
(length shuffled) unexpected seed)
(kill-emacs (if (zerop unexpected) 0 1)))
;;; tp-run-shuffled.el ends here

413
tp-search-tests.el
View File

@ -372,5 +372,418 @@ with predicate t, where VALUE nil matches property-absent runs."
(should (equal (substring-no-properties str) "hello world"))
(should (eq (get-text-property 0 'face str) 'bold)))))
;;; 0.3.0 A1: capture-group targeting via SUBEXP in tp-regexp-*
(ert-deftest tp-search-test-regexp-subexp-string ()
"SUBEXP applies properties to the capture group only (string path)."
(let ((s (tp-regexp-set "\\(foo\\)-bar" '(face bold)
"foo-bar foo-bar" nil nil 1)))
(should (eq (get-text-property 0 'face s) 'bold))
(should (eq (get-text-property 2 'face s) 'bold))
(should-not (get-text-property 3 'face s))
(should-not (get-text-property 6 'face s))
(should (eq (get-text-property 8 'face s) 'bold))
(should-not (get-text-property 11 'face s))))
(ert-deftest tp-search-test-regexp-subexp-buffer ()
"SUBEXP applies properties and reports regions for the group (buffer path)."
(with-temp-buffer
(insert "foo-bar")
(let ((regions (tp-regexp-set "\\(foo\\)-\\(bar\\)" '(face bold)
(current-buffer) nil nil 2)))
(should (equal regions '((5 . 8))))
(should (eq (get-text-property 5 'face) 'bold))
(should-not (get-text-property 1 'face))
(should-not (get-text-property 4 'face)))))
(ert-deftest tp-search-test-regexp-subexp-group-not-participating ()
"A match where the SUBEXP group does not participate contributes nothing."
(with-temp-buffer
(insert "b a b")
(let ((regions (tp-regexp-set "\\(a\\)\\|b" '(face bold)
(current-buffer) nil nil 1)))
;; Only the "a" match has group 1; the "b" matches contribute
;; neither properties nor regions.
(should (equal regions '((3 . 4))))
(should (eq (get-text-property 3 'face) 'bold))
(should-not (get-text-property 1 'face))
(should-not (get-text-property 5 'face))))
;; String path mirror.
(let ((s (tp-regexp-set "\\(a\\)\\|b" '(face bold) "b a b" nil nil 1)))
(should (eq (get-text-property 2 'face s) 'bold))
(should-not (get-text-property 0 'face s))
(should-not (get-text-property 4 'face s))))
(ert-deftest tp-search-test-regexp-subexp-zero-width-guard ()
"The zero-width guard still terminates when SUBEXP is given."
;; "\\(x\\)*" matches the empty string everywhere in "ab" with
;; group 1 never participating; both paths must terminate cleanly.
(let ((s (tp-regexp-set "\\(x\\)*" '(face bold) "ab" nil nil 1)))
(should (equal (substring-no-properties s) "ab"))
(should-not (text-properties-at 0 s))
(should-not (text-properties-at 1 s)))
(with-temp-buffer
(insert "ab")
(should-not (tp-regexp-set "\\(x\\)*" '(face bold)
(current-buffer) nil nil 1))
(should-not (get-text-property 1 'face))))
;;; 0.3.0 A2: START/END bounds in tp-match-* / tp-regexp-*
(ert-deftest tp-search-test-match-bounds-string ()
"START/END restrict tp-match-set to [START, END) in a string (0-based)."
(let ((s (tp-match-set "foo" '(face bold) "foo foo foo" 4 11)))
(should-not (get-text-property 0 'face s))
(should (eq (get-text-property 4 'face s) 'bold))
(should (eq (get-text-property 8 'face s) 'bold))))
(ert-deftest tp-search-test-match-bounds-buffer ()
"START/END restrict tp-match-set to [START, END) in a buffer (1-based)."
(with-temp-buffer
(insert "foo foo foo")
(let ((regions (tp-match-set "foo" '(face bold) (current-buffer) 5 12)))
(should (equal regions '((5 . 8) (9 . 12))))
(should-not (get-text-property 1 'face))
(should (eq (get-text-property 5 'face) 'bold))
(should (eq (get-text-property 9 'face) 'bold)))))
(ert-deftest tp-search-test-regexp-bounds-do-not-cross-boundary ()
"Bounded regexp matching behaves as if only [START, END) existed."
;; A greedy "a+" would match the whole object; with bounds it must
;; match exactly the bounded portion instead of being discarded.
(let ((s (tp-regexp-set "a+" '(face bold) "aaaa" 1 3)))
(should-not (get-text-property 0 'face s))
(should (eq (get-text-property 1 'face s) 'bold))
(should (eq (get-text-property 2 'face s) 'bold))
(should-not (get-text-property 3 'face s)))
(with-temp-buffer
(insert "aaaa")
(should (equal (tp-regexp-set "a+" '(face bold) (current-buffer) 2 4)
'((2 . 4))))
(should-not (get-text-property 1 'face))
(should (eq (get-text-property 2 'face) 'bold))
(should-not (get-text-property 4 'face))))
(ert-deftest tp-search-test-match-reset-and-add-accept-bounds ()
"tp-match-reset/add accept the same START/END bounds."
(let* ((base (tp-set "foo foo" 'face 'italic))
(s (tp-match-reset "foo" '(face bold) base 4 7)))
(should (eq (get-text-property 0 'face s) 'italic))
(should (eq (get-text-property 4 'face s) 'bold)))
(let ((s (tp-match-add "foo" '(face bold) "foo foo" 4 7)))
(should-not (get-text-property 0 'face s))
(should (eq (get-text-property 4 'face s) 'bold))))
;;; 0.3.0 A3: PREDICATE / NOT-CURRENT exposure in tp-forward/tp-backward
(defmacro tp-search-tests--with-lvl-buffer (&rest body)
"Run BODY in a temp buffer with `lvl' runs 1/2/3 over \"aaabbbccc\"."
(declare (indent 0))
`(with-temp-buffer
(insert "aaabbbccc")
(put-text-property 1 4 'lvl 1)
(put-text-property 4 7 'lvl 2)
(put-text-property 7 10 'lvl 3)
,@body))
(ert-deftest tp-search-test-forward-predicate-buffer ()
"A function PREDICATE selects buffer matches by property value."
(tp-search-tests--with-lvl-buffer
(goto-char (point-min))
(let ((m (tp-forward 'lvl nil nil 1
(lambda (_ v) (and (numberp v) (> v 1))))))
(should m)
(should (equal (list (prop-match-beginning m)
(prop-match-end m)
(prop-match-value m))
'(4 7 2))))))
(ert-deftest tp-search-test-forward-predicate-string ()
"A function PREDICATE selects string matches by property value."
(let ((s (copy-sequence "aaabbbccc")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s)
(tp-set 6 9 '(lvl 3) s)
(should (equal (tp-forward 'lvl nil s 2
(lambda (_ v) (and (numberp v) (> v 1))))
'((3 6 2) (6 9 3))))))
(ert-deftest tp-search-test-backward-predicate-buffer ()
"tp-backward accepts the same function PREDICATE as tp-forward."
(tp-search-tests--with-lvl-buffer
(goto-char (point-max))
(let ((m (tp-backward 'lvl nil nil 1
(lambda (_ v) (and (numberp v) (< v 3))))))
(should m)
(should (equal (list (prop-match-beginning m)
(prop-match-end m)
(prop-match-value m))
'(4 7 2))))))
(ert-deftest tp-search-test-backward-predicate-string ()
"tp-backward with a PREDICATE returns string matches innermost first."
(let ((s (copy-sequence "aaabbbccc")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s)
(tp-set 6 9 '(lvl 3) s)
(should (equal (tp-backward 'lvl nil s 2
(lambda (_ v) (and (numberp v) (> v 1))))
'((6 9 3) (3 6 2))))))
(ert-deftest tp-search-test-forward-not-current-skips-point-region ()
"NOT-CURRENT makes tp-forward skip the matching region around point."
(with-temp-buffer
(insert "aabbaa")
(put-text-property 1 3 'k 'x)
(put-text-property 3 5 'k 'y)
(put-text-property 5 7 'k 'x)
(goto-char (point-min))
(let ((m (tp-forward 'k 'x)))
(should (= (prop-match-beginning m) 1)))
(goto-char (point-min))
(let ((m (tp-forward 'k 'x nil 1 nil t)))
(should (= (prop-match-beginning m) 5))
(should (= (prop-match-end m) 7)))))
(ert-deftest tp-search-test-backward-not-current-skips-point-region ()
"NOT-CURRENT makes tp-backward skip the matching region at point."
(with-temp-buffer
(insert "aa bb")
(put-text-property 1 3 'k 'x)
(put-text-property 4 6 'k 'x)
(goto-char (point-max))
;; Default keeps the 0.2.0 behavior: the run ending at point wins.
(let ((m (save-excursion (tp-backward 'k 'x))))
(should (equal (list (prop-match-beginning m) (prop-match-end m))
'(4 6))))
;; NOT-CURRENT skips it and finds the previous matching run.
(let ((m (save-excursion (tp-backward 'k 'x nil 1 nil t))))
(should (equal (list (prop-match-beginning m) (prop-match-end m))
'(1 3))))))
(ert-deftest tp-search-test-predicate-t-equals-default ()
"An explicit PREDICATE of t keeps the default `equal' matching."
(tp-search-tests--with-lvl-buffer
(goto-char (point-min))
(let ((default-m (save-excursion (tp-forward 'lvl 2)))
(t-m (save-excursion (tp-forward 'lvl 2 nil 1 t))))
(should (= (prop-match-beginning default-m) (prop-match-beginning t-m)))
(should (= (prop-match-end default-m) (prop-match-end t-m))))))
(ert-deftest tp-search-test-predicate-adjacent-runs-stay-separate ()
"Adjacent matching runs with different values are separate matches.
Mirrors `text-property-search-forward', which ends a match where the
value changes when a non-nil predicate is given."
(let ((s (copy-sequence "abcdef")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s)
(should (equal (tp-forward 'lvl nil s 5 (lambda (_ v) (numberp v)))
'((0 3 1) (3 6 2))))))
(ert-deftest tp-search-test-forward-do-predicate ()
"tp-forward-do passes PREDICATE through to select the target match."
(let ((s (copy-sequence "abc def")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 4 7 '(lvl 2) s)
(should (= (tp-forward-do #'upcase 'lvl nil s 1 nil nil
(lambda (_ v) (eq v 2)))
1))
(should (equal (substring-no-properties s) "abc DEF"))))
(ert-deftest tp-search-test-backward-do-predicate ()
"tp-backward-do passes PREDICATE through to select the target match."
(with-temp-buffer
(insert "abc def")
(put-text-property 1 4 'lvl 1)
(put-text-property 5 8 'lvl 2)
(should (= (tp-backward-do #'upcase 'lvl nil (current-buffer) 1 nil nil
(lambda (_ v) (eq v 1)))
1))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"ABC def"))))
(ert-deftest tp-search-test-forward-do-defaults-unchanged ()
"tp-forward-do without PREDICATE keeps the 0.2.0 `equal' matching."
(let ((s (copy-sequence "abc def")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 4 7 '(lvl 2) s)
(should (= (tp-forward-do #'upcase 'lvl 2 s) 1))
(should (equal (substring-no-properties s) "abc DEF"))))
;;; REG-1: pattern-apply paths must register buffers in the reactive registry
(defvar tp-search-reg1-color nil)
(defvar tp-search-reg1b-color nil)
(ert-deftest tp-search-test-regexp-add-registers-reactive-buffer ()
"tp-regexp-add in a second buffer keeps reactive updates flowing there.
The deep-merge apply path stamps `tp-name' but never registered the
buffer, so once the layer was known from a `tp-set' elsewhere the
regexp-applied buffer went permanently stale (REG-1)."
(setq tp-search-reg1-color "red")
(unwind-protect
(progn
(tp-layer-reset)
(define-tp tp-search-reg1-layer ()
:props '(face (:foreground $tp-search-reg1-color)))
(let ((a (generate-new-buffer " *tp-sreg1-a*"))
(b (generate-new-buffer " *tp-sreg1-b*")))
(unwind-protect
(progn
(with-current-buffer a (insert "foo bar"))
(with-current-buffer b (insert "foo bar"))
(tp-set 1 4 'tp-search-reg1-layer a) ; registers A
(tp-regexp-add "foo" 'tp-search-reg1-layer b)
(let ((bufs (tp-reactive-layer-buffers
'tp-search-reg1-layer)))
(should (memq a bufs))
(should (memq b bufs)))
(setq tp-search-reg1-color "blue")
(should (equal (with-current-buffer a
(get-text-property 1 'face))
'(:foreground "blue")))
(should (equal (with-current-buffer b
(get-text-property 1 'face))
'(:foreground "blue"))))
(kill-buffer a)
(kill-buffer b))))
(tp-layer-reset)
(setq tp-search-reg1-color nil)))
(ert-deftest tp-search-test-match-reset-registers-reactive-buffer ()
"tp-match-reset in a second buffer keeps reactive updates flowing there.
The reset-apply path stamps `tp-name' via `set-text-properties' but
never registered the buffer (REG-1)."
(setq tp-search-reg1b-color "red")
(unwind-protect
(progn
(tp-layer-reset)
(define-tp tp-search-reg1b-layer ()
:props '(face (:foreground $tp-search-reg1b-color)))
(let ((a (generate-new-buffer " *tp-sreg1b-a*"))
(b (generate-new-buffer " *tp-sreg1b-b*")))
(unwind-protect
(progn
(with-current-buffer a (insert "foo bar"))
(with-current-buffer b (insert "foo bar"))
(tp-set 1 4 'tp-search-reg1b-layer a)
(tp-match-reset "foo" 'tp-search-reg1b-layer b)
(let ((bufs (tp-reactive-layer-buffers
'tp-search-reg1b-layer)))
(should (memq a bufs))
(should (memq b bufs)))
(setq tp-search-reg1b-color "blue")
(should (equal (with-current-buffer a
(get-text-property 1 'face))
'(:foreground "blue")))
(should (equal (with-current-buffer b
(get-text-property 1 'face))
'(:foreground "blue"))))
(kill-buffer a)
(kill-buffer b))))
(tp-layer-reset)
(setq tp-search-reg1b-color nil)))
;;; SRC-1: reversed START/END bounds are swapped on both object paths
(ert-deftest tp-search-test-reversed-bounds-string-swaps ()
"String-path START > END is swapped instead of signaling out-of-range."
(let ((res (tp-match-set "o" '(face bold) "foo" 2 1)))
(should (eq (get-text-property 1 'face res) 'bold))
(should-not (get-text-property 2 'face res)))
;; Swapped bounds behave exactly like the same bounds in order.
(should (equal-including-properties
(tp-regexp-set "o+" '(face bold) "foo" 3 1)
(tp-regexp-set "o+" '(face bold) "foo" 1 3))))
(ert-deftest tp-search-test-reversed-bounds-buffer-swaps ()
"Buffer-path START > END keeps its historical swap behavior."
(with-temp-buffer
(insert "foo")
(should (equal (tp-match-set "o" '(face bold) nil 3 2)
'((2 . 3))))
(should (eq (get-text-property 2 'face) 'bold))
(should-not (get-text-property 3 'face))))
;;; SRC-2: SUBEXP beyond the pattern's group count signals clearly
(ert-deftest tp-search-test-subexp-beyond-group-count-errors ()
"A SUBEXP larger than the pattern's group count errors on both paths."
(should-error (tp-regexp-set "abc" '(face bold)
(copy-sequence "abc") nil nil 5))
(with-temp-buffer
(insert "abc")
(should-error (tp-regexp-add "a\\(b\\)c" '(face bold) nil nil nil 2))
;; Nothing was applied before the error.
(should-not (get-text-property 1 'face))))
(ert-deftest tp-search-test-subexp-non-participating-group-quiet ()
"A legal group that never participates still returns nil quietly."
(with-temp-buffer
(insert "xbc")
(should (null (tp-regexp-set "\\(a\\)bc\\|xbc" '(face bold)
nil nil nil 1)))
(should-not (get-text-property 1 'face))))
;;; API-NAME-01: raw wrappers deprecated, behavior bit-identical
(ert-deftest tp-search-test-raw-wrappers-marked-obsolete ()
"The raw wrappers carry obsolescence info pointing at tp-forward/backward."
(should (eq (car (get 'tp-search-forward 'byte-obsolete-info))
'tp-forward))
(should (eq (car (get 'tp-search-backward 'byte-obsolete-info))
'tp-backward)))
(ert-deftest tp-search-test-raw-wrapper-forward-primitive-semantics ()
"tp-search-forward still behaves exactly like the Emacs primitive.
The third argument stays PREDICATE (not tp-forward's OBJECT slot) and
the nil-PREDICATE default keeps the primitive's not-`equal' matching."
(with-temp-buffer
(insert "aaabbb")
(put-text-property 4 7 'k 'v)
(dolist (args '((k) (k v t) (k v t t) (k other) (k missing t)))
(goto-char (point-min))
(let ((prim (apply #'text-property-search-forward args))
(prim-pt (point)))
(goto-char (point-min))
(let ((wrap (with-suppressed-warnings ((obsolete tp-search-forward))
(apply #'tp-search-forward args))))
(should (equal wrap prim))
(should (= (point) prim-pt)))))
;; One concrete anchor: nil PREDICATE with nil VALUE finds the
;; non-nil run and moves point to its end.
(goto-char (point-min))
(let ((m (with-suppressed-warnings ((obsolete tp-search-forward))
(tp-search-forward 'k))))
(should m)
(should (= (prop-match-beginning m) 4))
(should (= (prop-match-end m) 7))
(should (= (point) 7)))))
(ert-deftest tp-search-test-raw-wrapper-backward-primitive-semantics ()
"tp-search-backward still behaves exactly like the Emacs primitive."
(with-temp-buffer
(insert "aaabbb")
(put-text-property 1 4 'k 'v)
(dolist (args '((k) (k v t) (k v t t) (k other) (k missing t)))
(goto-char (point-max))
(let ((prim (apply #'text-property-search-backward args))
(prim-pt (point)))
(goto-char (point-max))
(let ((wrap (with-suppressed-warnings ((obsolete tp-search-backward))
(apply #'tp-search-backward args))))
(should (equal wrap prim))
(should (= (point) prim-pt)))))))
(ert-deftest tp-search-test-forward-string-path-first-n-contract ()
"tp-forward's string path returns the FIRST N matches from position 0."
(let ((s (copy-sequence "aabbaabb")))
(put-text-property 0 2 'k 'v s)
(put-text-property 4 6 'k 'v s)
(should (equal (tp-forward 'k 'v s) '((0 2 v))))
(should (equal (tp-forward 'k 'v s 2) '((0 2 v) (4 6 v))))
;; Fewer matches than N: return what exists, not nil.
(should (equal (tp-forward 'k 'v s 5) '((0 2 v) (4 6 v))))))
(provide 'tp-search-tests)
;;; tp-search-tests.el ends here

474
tp-search.el
View File

@ -20,14 +20,48 @@
(require 'cl-lib)
(require 'text-property-search)
(require 'tp-core)
(require 'tp-reactive)
(require 'tp-layer)
(require 'tp-ops)
(defun tp--pattern-apply-single (pattern properties apply-fn object literal)
(defun tp--search-register-layer-buffer (props object)
"Record OBJECT in the reactive buffer registry for PROPS's layers.
When OBJECT is a buffer or nil (the current buffer) and the applied
PROPS carry a `tp-name' - directly, or inside a `tp-layers' entry
from a group application - register that buffer under each layer name
via `tp-reactive--register-layer-buffer', so reactive updates keep
visiting buffers written through the pattern-apply paths. String
OBJECTs are not registered; see `tp-reactive-layer-buffers' for that
gap."
(when (or (null object) (bufferp object))
(let ((buf (or object (current-buffer))))
(when-let ((name (plist-get props 'tp-name)))
(tp-reactive--register-layer-buffer name buf))
(dolist (layer (plist-get props 'tp-layers))
(when-let ((name (plist-get layer 'tp-name)))
(tp-reactive--register-layer-buffer name buf))))))
(defun tp--pattern-apply-single (pattern properties apply-fn object literal
&optional start end subexp)
"Apply APPLY-FN to matches of single PATTERN in OBJECT.
When LITERAL is non-nil, PATTERN is matched literally; otherwise it
is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for
each match.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
are swapped (matching the buffer path's historical narrow-to-region
behavior, now uniform across object types). Matching behaves as if
OBJECT consisted only of that portion (the buffer path narrows, the
string path matches against the substring), so no match crosses the
boundaries.
When SUBEXP is non-nil, it names a capture group of PATTERN: the
properties and returned regions cover (match-beginning SUBEXP) to
\(match-end SUBEXP) of each match, and a match in which that group
does not participate contributes nothing. The scan still advances
past the whole match. A SUBEXP larger than PATTERN's group count
\(per `regexp-opt-depth') signals an error instead of silently
matching nothing.
For strings, returns a NEW string with properties applied
\(non-destructive).
For buffers, modifies in-place and returns list of regions.
@ -36,17 +70,37 @@ Zero-width matches (an empty literal pattern, or a regexp that can
match the empty string) are recorded and the scan advances one
position past them, so the search always terminates."
(let ((regexp (if literal (regexp-quote pattern) pattern)))
;; Reversed bounds are swapped, not signaled: the buffer path's
;; narrow-to-region always did this, so the string path follows.
(when (and start end (> start end))
(cl-rotatef start end))
;; A group number beyond the pattern's group count could never
;; match; make the typo loud instead of a silent no-op.
(when (and subexp (> subexp (regexp-opt-depth regexp)))
(error "Regexp %S has no group %d" pattern subexp))
(cond
;; String object
((stringp object)
;; First, collect all match positions from the original string
(let ((matches nil)
(pos 0)
(limit (length object)))
(while (and (<= pos limit) (string-match regexp object pos))
;; First, collect all match positions from the original string.
;; Bounded searches run against the substring so matches cannot
;; cross the [START, END) boundaries; positions are shifted back
;; into whole-string coordinates afterwards.
(let* ((from (max (or start 0) 0))
(to (min (or end (length object)) (length object)))
(searchable (if (and (= from 0) (= to (length object)))
object
(substring object from to)))
(matches nil)
(pos 0)
(limit (- to from)))
(while (and (<= pos limit) (string-match regexp searchable pos))
(let ((beg (match-beginning 0))
(end (match-end 0)))
(push (cons beg end) matches)
(end (match-end 0))
(sub-beg (match-beginning (or subexp 0)))
(sub-end (match-end (or subexp 0))))
;; A group that does not participate contributes nothing.
(when sub-beg
(push (cons (+ from sub-beg) (+ from sub-end)) matches))
(setq pos (if (= beg end) (1+ beg) end))))
;; Apply function to each match in order (reverse to get correct order)
;; Make a copy to ensure original string is not modified
@ -62,26 +116,38 @@ position past them, so the search always terminates."
(let ((buf (or object (current-buffer))))
(tp-with-current-buffer buf
(save-excursion
(goto-char (point-min))
(let (regions (keep-going t))
(while (and keep-going (re-search-forward regexp nil t))
(let ((beg (match-beginning 0))
(end (match-end 0)))
(when properties
(funcall apply-fn beg end properties buf))
(push (cons beg end) regions)
;; Guard against zero-width matches looping forever
(when (= beg end)
(if (eobp)
(setq keep-going nil)
(forward-char 1)))))
(nreverse regions)))))))))
(save-restriction
(when (or start end)
(narrow-to-region (max (or start (point-min)) (point-min))
(min (or end (point-max)) (point-max))))
(goto-char (point-min))
(let (regions (keep-going t))
(while (and keep-going (re-search-forward regexp nil t))
(let ((beg (match-beginning 0))
(end (match-end 0))
(sub-beg (match-beginning (or subexp 0)))
(sub-end (match-end (or subexp 0))))
;; A group that does not participate contributes nothing.
(when sub-beg
(when properties
(funcall apply-fn sub-beg sub-end properties buf))
(push (cons sub-beg sub-end) regions))
;; Guard against zero-width matches looping forever
(when (= beg end)
(if (eobp)
(setq keep-going nil)
(forward-char 1)))))
(nreverse regions))))))))))
(defun tp--pattern-apply (pattern properties apply-fn object literal)
(defun tp--pattern-apply (pattern properties apply-fn object literal
&optional start end subexp)
"Apply APPLY-FN to matches of PATTERN (one pattern or a list).
When LITERAL is non-nil, patterns are matched literally; otherwise
they are regexps. APPLY-FN is called with (START END PROPS OBJECT)
for each match.
START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target (see
`tp--pattern-apply-single').
For strings, returns a NEW string with properties applied
\(non-destructive).
For buffers, returns list of regions."
@ -92,47 +158,59 @@ For buffers, returns list of regions."
(let ((result object))
(dolist (p patterns)
(setq result (tp--pattern-apply-single p properties apply-fn
result literal)))
result literal
start end subexp)))
result))
;; Buffer or nil (current buffer)
(t
(let ((all-regions nil))
(dolist (p patterns)
(let ((regions (tp--pattern-apply-single p properties apply-fn
object literal)))
object literal
start end subexp)))
(setq all-regions (append all-regions regions))))
all-regions)))))
(defun tp--match-apply-single (pattern properties apply-fn object)
(defun tp--match-apply-single (pattern properties apply-fn object
&optional start end)
"Apply APPLY-FN to literal matches of single PATTERN in OBJECT.
START and END restrict matching to [START, END) in native coordinates.
For strings, returns a new string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(tp--pattern-apply-single pattern properties apply-fn object t))
(tp--pattern-apply-single pattern properties apply-fn object t start end))
(defun tp--match-apply (pattern properties apply-fn &optional object)
(defun tp--match-apply (pattern properties apply-fn &optional object start end)
"Internal function to apply APPLY-FN to matches of PATTERN.
PATTERN can be a string or a list of strings (multiple patterns).
When PATTERN is a list, each element is a pattern to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native coordinates.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(tp--pattern-apply pattern properties apply-fn object t))
(tp--pattern-apply pattern properties apply-fn object t start end))
(defun tp--regexp-apply-single (pattern properties apply-fn object)
(defun tp--regexp-apply-single (pattern properties apply-fn object
&optional start end subexp)
"Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(tp--pattern-apply-single pattern properties apply-fn object nil))
(tp--pattern-apply-single pattern properties apply-fn object nil
start end subexp))
(defun tp--regexp-apply (pattern properties apply-fn &optional object)
(defun tp--regexp-apply (pattern properties apply-fn
&optional object start end subexp)
"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).
When PATTERN is a list, each element is a regexp to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(tp--pattern-apply pattern properties apply-fn object nil))
(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.
@ -142,7 +220,10 @@ 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
;; 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))
@ -165,10 +246,10 @@ For buffers, modifies in-place."
(setq pos next-pos))))
obj))
(defun tp-match-set (pattern plist &optional object)
(defun tp-match-set (pattern plist &optional object start end)
"Set properties on all occurrences of PATTERN.
(tp-match-set PATTERN PLIST &optional OBJECT)
(tp-match-set PATTERN PLIST &optional OBJECT START END)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
Each pattern will be matched and have properties applied.
@ -176,30 +257,42 @@ PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
are swapped. Matching behaves as if OBJECT consisted only of that
portion, so no match crosses the boundaries.
Returns:
- For strings: the modified string
- For strings: a NEW string with properties applied (the original
string is not modified)
- For buffers: list of (START . END) pairs for all matches."
(tp--match-apply pattern (tp--ensure-props plist) #'tp-set object))
(tp--match-apply pattern (tp--ensure-props plist) #'tp-set object
start end))
(defun tp-match-reset (pattern plist &optional object)
(defun tp-match-reset (pattern plist &optional object start end)
"Reset (completely replace) properties on all occurrences of PATTERN.
(tp-match-reset PATTERN PLIST &optional OBJECT)
(tp-match-reset PATTERN PLIST &optional OBJECT START END)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
are swapped.
Unlike `tp-match-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of regions."
For buffers, modifies in-place and returns list of (START . END)
regions."
(tp--match-apply pattern (tp--ensure-props plist)
#'tp--reset-apply
object))
object start end))
(defun tp--reset-apply (start end props obj)
"Apply PROPS to OBJ from START to END, completely replacing existing properties.
@ -208,26 +301,38 @@ 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)
(defun tp-match-add (pattern plist &optional object start end)
"Add/update properties on all occurrences of PATTERN.
(tp-match-add PATTERN PLIST &optional OBJECT)
(tp-match-add PATTERN PLIST &optional OBJECT START END)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
are swapped.
Unlike `tp-match-set', this deeply merges nested properties."
(tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object))
Unlike `tp-match-set', this deeply merges nested properties.
(defun tp-regexp-set (pattern plist &optional object)
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
(tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
object start end))
(defun tp-regexp-set (pattern plist &optional object start end subexp)
"Set properties on all matches of PATTERN (regexp).
(tp-regexp-set PATTERN PLIST &optional OBJECT)
(tp-regexp-set PATTERN PLIST &optional OBJECT START END SUBEXP)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
Each pattern will be matched and have properties applied.
@ -235,66 +340,158 @@ PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
are swapped. Matching behaves as if OBJECT consisted only of that
portion, so no match crosses the boundaries.
When SUBEXP is non-nil, it names a capture group of PATTERN (1 for
the first group, like font-lock highlights): properties apply to that
group of each match instead of the whole match, and a match in which
the group does not participate contributes nothing. A SUBEXP larger
than PATTERN's group count signals an error.
Returns:
- For strings: the modified string
- For strings: a NEW string with properties applied (the original
string is not modified)
- For buffers: list of (START . END) pairs for all matches."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object))
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object
start end subexp))
(defun tp-regexp-reset (pattern plist &optional object)
(defun tp-regexp-reset (pattern plist &optional object start end subexp)
"Reset (completely replace) properties on all regexp matches of PATTERN.
(tp-regexp-reset PATTERN PLIST &optional OBJECT)
(tp-regexp-reset PATTERN PLIST &optional OBJECT START END SUBEXP)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
are swapped.
When SUBEXP is non-nil, properties apply to that capture group of
each match instead of the whole match; a match in which the group
does not participate contributes nothing. A SUBEXP larger than
PATTERN's group count signals an error.
Unlike `tp-regexp-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of regions."
For buffers, modifies in-place and returns list of (START . END)
regions."
(tp--regexp-apply pattern (tp--ensure-props plist)
#'tp--reset-apply
object))
object start end subexp))
(defun tp-regexp-add (pattern plist &optional object)
(defun tp-regexp-add (pattern plist &optional object start end subexp)
"Add/update properties on all regexp matches of PATTERN.
(tp-regexp-add PATTERN PLIST &optional OBJECT)
(tp-regexp-add PATTERN PLIST &optional OBJECT START END SUBEXP)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
are swapped.
When SUBEXP is non-nil, properties apply to that capture group of
each match instead of the whole match; a match in which the group
does not participate contributes nothing. A SUBEXP larger than
PATTERN's group count signals an error.
Unlike `tp-regexp-set', this deeply merges nested properties."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object))
Unlike `tp-regexp-set', this deeply merges nested properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
object start end subexp))
(defun tp-search-forward (property &optional value predicate not-current)
"Search forward for text with PROPERTY.
Wraps `text-property-search-forward'."
"Search forward from point for text whose PROPERTY matches VALUE.
This is a raw wrapper: PROPERTY, VALUE, PREDICATE and NOT-CURRENT are
passed unchanged to `text-property-search-forward', whose semantics
apply in full - including the primitive's nil-PREDICATE default of
matching values that are non-nil and NOT `equal' to VALUE. On
success point moves to the end of the matched region and a prop-match
object is returned; otherwise nil.
Obsolete since tp 0.3.0: call `tp-forward' for tp's `equal'-matching
search (which also supports string OBJECTs and repeat counts), or
call the Emacs primitive `text-property-search-forward' directly for
raw use - this wrapper adds nothing to it."
(text-property-search-forward property value predicate not-current))
(make-obsolete 'tp-search-forward 'tp-forward "0.3.0")
(defun tp-search-backward (property &optional value predicate not-current)
"Search backward for text with PROPERTY.
Wraps `text-property-search-backward'."
(text-property-search-backward property value predicate not-current))
"Search backward from point for text whose PROPERTY matches VALUE.
This is a raw wrapper: PROPERTY, VALUE, PREDICATE and NOT-CURRENT are
passed unchanged to `text-property-search-backward', whose semantics
apply in full - including the primitive's nil-PREDICATE default of
matching values that are non-nil and NOT `equal' to VALUE. On
success point moves to the beginning of the matched region and a
prop-match object is returned; otherwise nil.
(defun tp--property-search-backward (property value)
"Search backward for the previous region where PROPERTY `equal's VALUE.
Obsolete since tp 0.3.0: call `tp-backward' for tp's `equal'-matching
search (which also supports string OBJECTs and repeat counts), or
call the Emacs primitive `text-property-search-backward' directly for
raw use - this wrapper adds nothing to it."
(text-property-search-backward property value predicate not-current))
(make-obsolete 'tp-search-backward 'tp-backward "0.3.0")
(defun tp--property-match-p (value prop-value predicate)
"Return non-nil when PROP-VALUE matches VALUE under PREDICATE.
PREDICATE follows the convention tp uses for
`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
called with VALUE and PROP-VALUE and matches when it returns
non-nil."
(if (functionp predicate)
(funcall predicate value prop-value)
(equal value prop-value)))
(defun tp--string-property-matches (string property value predicate)
"Collect PROPERTY runs of STRING matching VALUE under PREDICATE.
Returns a list of (START END VALUE) lists with 0-based positions. A
run is a maximal stretch with one `eq' PROPERTY value, and it matches
when `tp--property-match-p' accepts that value. Adjacent matching
runs with different values stay separate entries, mirroring how
`text-property-search-forward' ends a match where the property value
changes when a non-nil predicate is given."
(let ((results nil))
(tp--map-intervals
string 0 (length string)
(lambda (beg end val)
(when (tp--property-match-p value val predicate)
(push (list beg end val) results))
nil)
property)
(nreverse results)))
(defun tp--property-search-backward (property value
&optional predicate not-current)
"Search backward for the previous region where PROPERTY matches VALUE.
This is the backward mirror of (text-property-search-forward PROPERTY
VALUE t): a region matches when its PROPERTY value is `equal' to
VALUE. It deliberately does not call
VALUE t): by default a region matches when its PROPERTY value is
`equal' to VALUE. It deliberately does not call
`text-property-search-backward' with predicate t, because that
primitive's non-default-predicate branch skips every other property
run when non-matching runs intervene (observed through Emacs 30.2),
silently missing valid matches.
PREDICATE follows `tp--property-match-p': nil and t both mean `equal'
matching (the 0.2.0 contract); a function is called with VALUE and
the region's PROPERTY value. When NOT-CURRENT is non-nil, the
matching region containing point (or ending exactly at point) is
skipped, mirroring the primitive's NOT-CURRENT argument.
If a matching region is found, move point to its beginning and
return a `prop-match' object whose end is clipped to the starting
point (matching the primitive's behavior when point starts inside a
@ -308,7 +505,10 @@ matching region). Otherwise return nil and leave point alone."
(tp--map-intervals
(current-buffer) (point-min) origin
(lambda (ibeg iend val)
(when (equal value 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)
@ -318,14 +518,40 @@ matching region). Otherwise return nil and leave point alone."
:end (cadr found)
:value (caddr found))))))
(defun tp-forward (property &optional value object n)
(defun tp-forward (property &optional value object n predicate not-current)
"Search forward N times for text with PROPERTY.
Returns prop-match for buffers or list of (START END VALUE) for strings."
VALUE is the optional value to match; N is the number of searches,
defaulting to 1.
OBJECT can be a buffer or string; nil defaults to current buffer.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`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
moves point to the end of its matched region; the return value is
the prop-match object of the N-th search, or nil when that search
found nothing.
For strings, point is not involved at all: the return value is the
list of the FIRST N matching regions counted from position 0 of the
string, each a (START END VALUE) list with 0-based positions - not
the N-th match alone. Fewer than N matches return however many
exist."
(let ((count (or n 1)))
(cond
;; String object - use tp-search
;; String object - use tp-search (or the predicate-aware matcher)
((stringp object)
(let ((matches (tp-search object property value)))
(let ((matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value))))
(seq-take matches count)))
;; Buffer or nil
(t
@ -333,26 +559,41 @@ Returns prop-match for buffers or list of (START END VALUE) for strings."
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
(setq result (tp-search-forward property value t))))
(setq result (text-property-search-forward
property value
(if (functionp predicate) predicate t)
not-current))))
result)))))
(defun tp-backward (property &optional value object n)
(defun tp-backward (property &optional value object n predicate not-current)
"Search backward N times for text with PROPERTY.
N is the number of searches, defaulting to 1.
VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil.
NOT-CURRENT, when non-nil, skips a matching region containing point
\(or ending exactly at point), mirroring
`text-property-search-backward'. It only applies to the buffer
path; strings have no point, so it is ignored there.
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
in reverse order (from end to start).
Uses `tp-search-backward' for buffers and `tp-search' for strings."
Uses `tp--property-search-backward' for buffers and `tp-search' (or
the predicate-aware matcher) for strings."
(let ((count (or n 1)))
(cond
;; String object - use tp-search and reverse
((stringp object)
(let ((matches (nreverse (tp-search object property value))))
(let ((matches (nreverse (if (functionp predicate)
(tp--string-property-matches
object property value predicate)
(tp-search object property value)))))
(seq-take matches count)))
;; Buffer or nil
(t
@ -360,14 +601,17 @@ Uses `tp-search-backward' for buffers and `tp-search' for strings."
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
;; `equal' matching, 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 property value))))
;; `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
property value predicate not-current))))
result)))))
(defun tp--forward-do (function property &optional value object times start end)
(defun tp--forward-do (function property &optional value object times
start end predicate not-current)
"Internal: search forward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
@ -376,6 +620,8 @@ TIMES is the number of searches, defaulting to 1.
VALUE is the optional value to match.
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.
PREDICATE and NOT-CURRENT are passed to each underlying search (see
`tp-forward'); nil PREDICATE keeps the 0.2.0 `equal' matching.
FUNCTION is called only when the TIMES-th match exists; if fewer
matches are available, nothing is applied.
@ -386,7 +632,10 @@ Returns the number of matches found (at most TIMES)."
((stringp object)
(let* ((start-pos (or start 0))
(end-pos (or end (length object)))
(all-matches (tp-search object property value))
(all-matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value)))
(filtered-matches (seq-filter (lambda (m)
(and (>= (car m) start-pos)
(<= (cadr m) end-pos)))
@ -408,7 +657,10 @@ Returns the number of matches found (at most TIMES)."
(save-excursion
(goto-char search-start)
(dotimes (i count)
(when-let ((match (tp-search-forward property value t)))
(when-let ((match (text-property-search-forward
property value
(if (functionp predicate) predicate t)
not-current)))
(when (<= (prop-match-end match) search-end)
(when (= i (1- count))
(funcall function match buf))
@ -483,8 +735,14 @@ length-changing replacements" new-text (length new-text) len))
(goto-char m-start)
(insert new-text)))))))
(defun tp-forward-do (function property &optional value object times start end)
"Search forward for text with PROPERTY and apply FUNCTION to the last match.
(defun tp-forward-do (function property &optional value object times
start end predicate not-current)
"Search forward TIMES times for PROPERTY; apply FUNCTION at the Nth match.
Despite the -do suffix this is NOT a for-each: the search advances
through TIMES matches and FUNCTION is applied only to the final
\(TIMES-th) one. Use `tp-search-map' to apply a function to EVERY
match.
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
@ -497,6 +755,13 @@ 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 times but only applies FUNCTION to the last (Nth) match found.
START and END define the search range; defaults are object start and end.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil.
NOT-CURRENT is passed to each underlying
`text-property-search-forward' call; it only applies to the buffer
path (strings have no point).
Returns the number of successful matches.
@ -523,9 +788,10 @@ Example:
(tp--forward-do
(lambda (match obj)
(tp--replace-match-text function arity match obj))
property value object times start end)))
property value object times start end predicate not-current)))
(defun tp--backward-do (function property &optional value object times start end)
(defun tp--backward-do (function property &optional value object times
start end predicate not-current)
"Internal: search backward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
@ -534,6 +800,8 @@ TIMES is the number of searches, defaulting to 1.
VALUE is the optional value to match.
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.
PREDICATE and NOT-CURRENT are passed to each underlying search (see
`tp-backward'); nil PREDICATE keeps the 0.2.0 `equal' matching.
FUNCTION is called only when the TIMES-th match exists; if fewer
matches are available, nothing is applied.
@ -544,7 +812,10 @@ Returns the number of matches found (at most TIMES)."
((stringp object)
(let* ((start-pos (or start 0))
(end-pos (or end (length object)))
(all-matches (tp-search object property value))
(all-matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value)))
(filtered-matches
(seq-filter (lambda (m)
(and (>= (car m) start-pos)
@ -565,16 +836,24 @@ Returns the number of matches found (at most TIMES)."
(save-excursion
(goto-char search-end)
(dotimes (i count)
;; `equal' matching, same as tp--forward-do's predicate t.
(when-let ((match (tp--property-search-backward property value)))
;; `equal' matching by default, same as tp--forward-do's
;; predicate t.
(when-let ((match (tp--property-search-backward
property value predicate not-current)))
(when (>= (prop-match-beginning match) search-start)
(when (= i (1- count))
(funcall function match buf))
(cl-incf matches)))))))
matches)))))
(defun tp-backward-do (function property &optional value object times start end)
"Search backward for text with PROPERTY and apply FUNCTION to the last match.
(defun tp-backward-do (function property &optional value object times
start end predicate not-current)
"Search backward TIMES times for PROPERTY; apply FUNCTION at the Nth match.
Despite the -do suffix this is NOT a for-each: the search walks back
through TIMES matches and FUNCTION is applied only to the final
\(TIMES-th) one. Use `tp-search-map' to apply a function to EVERY
match.
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
@ -587,6 +866,13 @@ 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 times but only applies FUNCTION to the last (Nth) match found.
START and END define the search range; defaults are object start and end.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil.
NOT-CURRENT, when non-nil, skips a matching region containing point
on each underlying search; it only applies to the buffer path
\(strings have no point).
Returns the number of successful matches.
@ -613,7 +899,7 @@ Example:
(tp--backward-do
(lambda (match obj)
(tp--replace-match-text function arity match obj))
property value object times start end)))
property value object times start end predicate not-current)))
(defun tp-search (start-or-string
&optional end-or-property property-or-value value object)

881
tp-stack-tests.el
View File

@ -379,5 +379,886 @@ definitions cannot leak between tests."
(should-error (tp-push-layer nil 'layer1))
(should-error (tp-delete-layer 'not-a-position 5 'layer1))))
;;; 0.3.0 S1: layer visibility (tp-hide-layer / tp-show-layer)
(ert-deftest tp-stack-test-hide-top-reveals-next-visible ()
"Hiding the top layer renders the next visible layer's properties."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(should (= (tp-hide-layer 1 6 'upper) 1))
;; The text now renders the lower layer.
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 1 'tp-name) 'lower))
;; The hidden layer is still in the stack for the queries.
(should (= (tp-layer-count 1 6) 2))
(should (equal (tp-layer-list 1 6) '(upper lower)))
(should (tp-layer-exists-p 1 6 'upper))))
(ert-deftest tp-stack-test-show-restores-hidden-top ()
"Showing a hidden top layer restores its properties onto the text."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(tp-hide-layer 1 6 'upper)
(should (= (tp-show-layer 1 6 'upper) 1))
(should (eq (get-text-property 1 'face) 'italic))
(should (eq (get-text-property 1 'tp-name) 'upper))
;; No bookkeeping flag leaks into the rendered properties.
(should-not (tp-stack-tests--has-prop-p 1 'tp-hidden))))
(ert-deftest tp-stack-test-hide-all-layers-contract ()
"With every layer hidden only the tp-layers bookkeeping remains."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(should (= (tp-hide-layer 1 6 'upper) 1))
(should (= (tp-hide-layer 1 6 'lower) 1))
;; No layer props render, not even tp-name.
(should (null (get-text-property 1 'face)))
(should (null (get-text-property 1 'tp-name)))
(should (tp-stack-tests--has-prop-p 1 'tp-layers))
;; The whole stack stays queryable.
(should (= (tp-layer-count 1 6) 2))
(should (equal (tp-layer-list 1 6) '(upper lower)))
;; Showing one layer again renders it.
(should (= (tp-show-layer 1 6 'lower) 1))
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 1 'tp-name) 'lower))))
(ert-deftest tp-stack-test-hide-missing-name-is-silent-noop ()
"Hiding or showing a non-existent layer returns 0 without signaling."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 1 6 'layer1)
(let ((before (text-properties-at 1)))
(should (= (tp-hide-layer 1 6 'nope) 0))
(should (= (tp-show-layer 1 6 'nope) 0))
(should (equal (text-properties-at 1) before)))))
(ert-deftest tp-stack-test-hide-already-hidden-returns-zero ()
"Hiding an already-hidden layer (or showing a visible one) counts 0."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(should (= (tp-show-layer 1 6 'upper) 0)) ; visible already
(should (= (tp-hide-layer 1 6 'upper) 1))
(should (= (tp-hide-layer 1 6 'upper) 0)) ; hidden already
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-hide-string-forms ()
"Whole-string and region-on-string forms of hide/show work 0-based."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer str 'lower)
(tp-push-layer str 'upper)
(should (= (tp-hide-layer str 'upper) 1))
(should (eq (get-text-property 0 'tp-name str) 'lower))
(should (= (tp-show-layer 0 6 'upper str) 1))
(should (eq (get-text-property 0 'tp-name str) 'upper))
;; Region form only touches [2, 5).
(should (= (tp-hide-layer 2 5 'upper str) 1))
(should (eq (get-text-property 0 'tp-name str) 'upper))
(should (eq (get-text-property 2 'tp-name str) 'lower))
(should (eq (get-text-property 5 'tp-name str) 'upper)))))
(ert-deftest tp-stack-test-show-layer-above-visible-top ()
"Showing a hidden layer above the visible top makes it render again."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(tp-hide-layer 1 6 'lc)
(tp-hide-layer 1 6 'lb)
(should (eq (get-text-property 1 'tp-name) 'la))
;; lc sits above the visible top (la); showing it wins again.
(should (= (tp-show-layer 1 6 'lc) 1))
(should (eq (get-text-property 1 'tp-name) 'lc))
(should (eq (get-text-property 1 'face) 'underline))))
(ert-deftest tp-stack-test-hidden-layer-can-be-raised ()
"A hidden layer can be moved in the stack and shown later."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-hide-layer 1 6 'la) ; hide the bottom layer
(should (= (tp-raise-layer 1 6 'la 1) 1))
;; la is now on top but hidden, so lb still renders.
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lb)))
(should (eq (get-text-property 1 'tp-name) 'lb))
(should (= (tp-show-layer 1 6 'la) 1))
(should (eq (get-text-property 1 'tp-name) 'la))
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-hide-show-roundtrip-restores-storage ()
"A hide/show roundtrip restores the exact original properties."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 1 6 'layer1)
(let ((before (text-properties-at 1)))
(tp-hide-layer 1 6 'layer1)
;; All layers hidden: only bookkeeping remains.
(should (null (get-text-property 1 'tp-name)))
(tp-show-layer 1 6 'layer1)
(should (equal (text-properties-at 1) before))
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers)))))
(ert-deftest tp-stack-test-flatten-drops-tp-hidden-flag ()
"Flattening a stack with a hidden layer never leaks the tp-hidden flag.
HID-2: the hidden layer's props are discarded entirely, so the
flattened result renders the visible layer's face, not the hidden
one's."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(tp-hide-layer 1 6 'upper)
(should (= (tp-flatten-layers 1 6 'flat) 1))
(should (eq (get-text-property 1 'tp-name) 'flat))
(should-not (tp-stack-tests--has-prop-p 1 'tp-hidden))
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers))
;; The visible layer's face renders; the hidden italic is gone.
(should (eq (get-text-property 1 'face) 'bold))))
;;; HID-2: flatten/merge must not render hidden layers' properties
(ert-deftest tp-stack-test-flatten-discards-hidden-layer-props ()
"Flatten discards a hidden layer's props instead of rendering them.
Probe scenario A: red (hidden, with help-echo) over green over blue
\(with mouse-face); the flattened result must show green and keep
blue's mouse-face, with no trace of the hidden red layer."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp tp-st-h2-red () '(face (:foreground "red") help-echo "red"))
(define-tp tp-st-h2-green () '(face (:foreground "green")))
(define-tp tp-st-h2-blue () '(face (:foreground "blue")
mouse-face highlight))
(tp-push-layer 1 6 'tp-st-h2-blue)
(tp-push-layer 1 6 'tp-st-h2-green)
(tp-push-layer 1 6 'tp-st-h2-red) ; top->bottom: red green blue
(tp-hide-layer 1 6 'tp-st-h2-red)
(should (equal (get-text-property 1 'face) '(:foreground "green")))
(should (= (tp-flatten-layers 1 6 'flat) 1))
(should (equal (get-text-property 1 'face) '(:foreground "green")))
(should-not (tp-stack-tests--has-prop-p 1 'help-echo))
(should (eq (get-text-property 1 'mouse-face) 'highlight))))
(ert-deftest tp-stack-test-flatten-all-hidden-yields-bare-text ()
"Flattening a run whose every layer is hidden clears all properties.
Consistent with the all-hidden rendering of `tp-hide-layer'; the run
still counts as modified in the returned count."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp tp-st-h2a-one () '(face bold))
(define-tp tp-st-h2a-two () '(face italic))
(tp-push-layer 1 6 'tp-st-h2a-one)
(tp-push-layer 1 6 'tp-st-h2a-two)
(tp-hide-layer 1 6 'tp-st-h2a-one)
(tp-hide-layer 1 6 'tp-st-h2a-two)
(should (= (tp-flatten-layers 1 6 'flat) 1))
(should (null (text-properties-at 1)))))
(ert-deftest tp-stack-test-merge-excludes-hidden-layer-props ()
"Merging a hidden layer with a visible one excludes the hidden props.
Probe scenario B: merging hidden red with visible green removes both
from the stack but the merged layer renders green - a merge must
never un-hide what `tp-hide-layer' hid."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp tp-st-h2b-red () '(face (:foreground "red")))
(define-tp tp-st-h2b-green () '(face (:foreground "green")))
(define-tp tp-st-h2b-blue () '(face (:foreground "blue")))
(tp-push-layer 1 6 'tp-st-h2b-blue)
(tp-push-layer 1 6 'tp-st-h2b-green)
(tp-push-layer 1 6 'tp-st-h2b-red)
(tp-hide-layer 1 6 'tp-st-h2b-red)
(should (= (tp-merge-layers 1 6 'merged '(tp-st-h2b-red tp-st-h2b-green))
1))
(should (equal (get-text-property 1 'face) '(:foreground "green")))
(should (eq (get-text-property 1 'tp-name) 'merged))
(should (equal (mapcar #'car (tp-layer-stack-at 1))
'(merged tp-st-h2b-blue)))))
(ert-deftest tp-stack-test-merge-all-hidden-stays-hidden ()
"Merging only hidden layers produces a hidden merged layer.
The merged layer keeps the hidden layers' merged props (data is
preserved) but carries tp-hidden itself, so nothing starts rendering;
`tp-show-layer' can reveal it later."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp tp-st-h2c-red () '(face (:foreground "red")))
(define-tp tp-st-h2c-green () '(face (:foreground "green")))
(define-tp tp-st-h2c-blue () '(face (:foreground "blue")))
(tp-push-layer 1 6 'tp-st-h2c-blue)
(tp-push-layer 1 6 'tp-st-h2c-green)
(tp-push-layer 1 6 'tp-st-h2c-red)
(tp-hide-layer 1 6 'tp-st-h2c-red)
(tp-hide-layer 1 6 'tp-st-h2c-green)
(should (= (tp-merge-layers 1 6 'merged
'(tp-st-h2c-red tp-st-h2c-green))
1))
;; The merged layer does not render: blue stays visible.
(should (equal (get-text-property 1 'face) '(:foreground "blue")))
;; It is present, hidden, and carries the merged (red-wins) props.
(let ((entry (assq 'merged (tp-layer-stack-at 1))))
(should entry)
(should (eq (plist-get (cdr entry) 'tp-hidden) t))
(should (equal (plist-get (cdr entry) 'face) '(:foreground "red"))))
;; Showing the merged layer renders it.
(tp-show-layer 1 6 'merged)
(should (equal (get-text-property 1 'face) '(:foreground "red")))))
;;; HID2-RET: merge/flatten return modified-run counts
(ert-deftest tp-stack-test-merge-and-flatten-return-counts ()
"tp-merge-layers / tp-flatten-layers return modified-run counts.
Counting matches `tp-delete-layer': one per rewritten run, 0 when
nothing matched."
(tp-stack-tests--with-env
(insert "abcdefghij")
(define-tp tp-st-ret-a () '(face bold))
(define-tp tp-st-ret-b () '(face italic))
;; Two separate runs with different stacks.
(tp-push-layer 1 4 'tp-st-ret-a)
(tp-push-layer 1 4 'tp-st-ret-b)
(tp-push-layer 5 8 'tp-st-ret-a)
;; Merge matches both layers in run 1, only one in run 2: both
;; runs are rewritten.
(should (= (tp-merge-layers 1 8 'm '(tp-st-ret-a tp-st-ret-b)) 2))
;; Nothing matches on bare text.
(should (= (tp-merge-layers 8 11 'm2 '(tp-st-ret-a)) 0))
;; Flatten counts every run that had layers ([1,4) and [5,8) are
;; separated by bare text); bare text does not count.
(should (= (tp-flatten-layers 1 8 'flat) 2))
(should (= (tp-flatten-layers 8 11 'flat2) 0))))
;;; 0.3.0 S2: tp-lower-layer and extended tp-rotate-layer
(ert-deftest tp-stack-test-lower-layer-moves-down ()
"Lowering by 1 swaps the layer with the one below it."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc) ; top->bottom: lc lb la
(should (= (tp-lower-layer 1 6 'lc 1) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb lc la)))
(should (eq (get-text-property 1 'tp-name) 'lb))))
(ert-deftest tp-stack-test-lower-layer-mirrors-raise ()
"Lowering then raising by the same N restores the stack order."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(let ((before (mapcar #'car (tp-layer-stack-at 1))))
(tp-lower-layer 1 6 'lc 2)
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc)))
(tp-raise-layer 1 6 'lc 2)
(should (equal (mapcar #'car (tp-layer-stack-at 1)) before)))))
(ert-deftest tp-stack-test-lower-layer-clamps-and-negates ()
"Lowering clamps at the bottom; a negative N raises instead."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(should (= (tp-lower-layer 1 6 'lc 99) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc)))
(should (= (tp-lower-layer 1 6 'lc -2) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))))
(ert-deftest tp-stack-test-lower-layer-defaults-and-index ()
"N defaults to 1 and integer indexes address the stack (0 = top)."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer str 'la)
(tp-push-layer str 'lb) ; top->bottom: lb la
(should (= (tp-lower-layer str 0) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb)))
(should (eq (get-text-property 0 'tp-name str) 'la)))))
(ert-deftest tp-stack-test-lower-layer-missing-returns-zero ()
"Lowering a non-existent layer is a silent no-op returning 0."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(tp-push-layer 1 6 'la)
(let ((before (text-properties-at 1)))
(should (= (tp-lower-layer 1 6 'nope 1) 0))
(should (equal (text-properties-at 1) before)))))
(ert-deftest tp-stack-test-rotate-layer-default-unchanged ()
"With no new arguments rotate still moves the top layer to bottom."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc) ; top->bottom: lc lb la
(should (= (tp-rotate-layer 1 6) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc)))
(should (eq (get-text-property 1 'tp-name) 'lb))))
(ert-deftest tp-stack-test-rotate-layer-up-inverts-down ()
"Rotating up moves the bottom layer to the top; up undoes down."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(should (= (tp-rotate-layer 1 6 nil 'up) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb)))
(should (= (tp-rotate-layer 1 6 nil 'down) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))))
(ert-deftest tp-stack-test-rotate-layer-count-and-wraparound ()
"COUNT rotates several steps; a full cycle restores the order."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(should (= (tp-rotate-layer 1 6 nil 'down 2) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb)))
(should (= (tp-rotate-layer 1 6 nil 'up 2) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))
(should (= (tp-rotate-layer 1 6 nil 'down 3) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))))
(ert-deftest tp-stack-test-rotate-layer-string-form-direction ()
"String form accepts DIRECTION and COUNT right after the string."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer str 'la)
(tp-push-layer str 'lb) ; top->bottom: lb la
(should (= (tp-rotate-layer str 'up) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb)))
(should (= (tp-rotate-layer str 'down 1) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(lb la))))))
(ert-deftest tp-stack-test-rotate-layer-edge-arguments ()
"Invalid DIRECTION signals; COUNT below 1 and bare text return 0."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(tp-push-layer 1 4 'la)
(should-error (tp-rotate-layer 1 4 nil 'sideways))
(should (= (tp-rotate-layer 1 4 nil 'down 0) 0))
(should (= (tp-rotate-layer 4 6) 0))
(should (eq (get-text-property 1 'tp-name) 'la))))
;;; API-ARG-01: canonical (START END DIRECTION COUNT OBJECT) rotate order
(ert-deftest tp-stack-test-rotate-layer-canonical-order ()
"The canonical order needs no nil OBJECT placeholder."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc) ; top->bottom: lc lb la
(should (= (tp-rotate-layer 1 6 'up) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb)))
(should (= (tp-rotate-layer 1 6 'down) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))
;; COUNT rides fourth in the canonical order.
(should (= (tp-rotate-layer 1 6 'down 2) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb)))
(should (= (tp-rotate-layer 1 6 'up 2) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))))
(ert-deftest tp-stack-test-rotate-layer-canonical-order-object-last ()
"OBJECT rides last in the canonical order (buffer and string)."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb) ; top->bottom: lb la
(let ((buf (current-buffer)))
(with-temp-buffer ; a different current buffer
(should (= (tp-rotate-layer 1 6 'up 1 buf) 1))))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lb)))
;; nil COUNT in the canonical order still defaults to 1.
(let ((buf (current-buffer)))
(with-temp-buffer
(should (= (tp-rotate-layer 1 6 'down nil buf) 1))))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la)))
;; A string OBJECT in the canonical order's last slot.
(let ((str (copy-sequence "xyz")))
(tp-push-layer str 'la)
(tp-push-layer str 'lb)
(should (= (tp-rotate-layer 0 3 'up 1 str) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb))))))
(ert-deftest tp-stack-test-rotate-layer-legacy-order-still-works ()
"The legacy (START END OBJECT DIRECTION COUNT) order keeps working.
A non-up/down third argument - nil, a buffer or a string - still
selects the legacy order."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer str 'la)
(tp-push-layer str 'lb) ; top->bottom: lb la
(should (= (tp-rotate-layer 0 6 str 'up 1) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb))))
(insert "abcdef")
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(should (= (tp-rotate-layer 1 6 nil 'up 1) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lb)))
;; Canonical-order direction errors still signal.
(should-error (tp-rotate-layer 1 6 'sideways))))
;;; 0.3.0 S3: tp-layer-stack-at
(ert-deftest tp-stack-test-layer-stack-at-shape ()
"The stack at a position is (NAME . PROPS) conses, top first."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(should (equal (tp-layer-stack-at 1)
'((lb . (face italic))
(la . (face bold)))))))
(ert-deftest tp-stack-test-layer-stack-at-hidden-marker ()
"Hidden layers carry a tp-hidden t entry in their PROPS."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-hide-layer 1 6 'lb)
(let ((stack (tp-layer-stack-at 1)))
(should (equal (mapcar #'car stack) '(lb la)))
(should (eq (plist-get (cdr (nth 0 stack)) 'tp-hidden) t))
(should-not (plist-member (cdr (nth 1 stack)) 'tp-hidden)))))
(ert-deftest tp-stack-test-layer-stack-at-string-positions ()
"String positions are 0-based; outside the layer the stack is nil."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(tp-put-layer 2 5 'la 0 str)
(should (null (tp-layer-stack-at 0 str)))
(should (equal (tp-layer-stack-at 2 str) '((la . (face bold)))))
(should (null (tp-layer-stack-at 5 str))))))
(ert-deftest tp-stack-test-layer-stack-at-unnamed-and-bare ()
"Unnamed layers report a nil NAME; bare text reports nil."
(tp-stack-tests--with-env
(insert "abcdef")
(tp-push-layer 1 4 '(face bold))
(should (equal (tp-layer-stack-at 1) '((nil . (face bold)))))
(should (null (tp-layer-stack-at 5)))))
;;; 0.3.0 S4: modified-interval counts and NOERROR
(ert-deftest tp-stack-test-delete-layer-returns-run-count ()
"Delete returns how many property runs matched; 0 when none did."
(tp-stack-tests--with-env
(insert "abcdefghij")
(define-tp la () '(face bold))
(tp-push-layer 1 4 'la)
(tp-push-layer 6 9 'la)
(should (= (tp-delete-layer 1 9 'nope) 0))
(should (= (tp-delete-layer 1 9 'la) 2))
(should-not (tp-layer-exists-p 1 9 'la))))
(ert-deftest tp-stack-test-pop-layer-returns-run-count ()
"Pop returns the number of runs that had a layer to pop."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(tp-put-layer 0 3 'la 0 str)
(should (= (tp-pop-layer 0 6 str) 1))
(should (= (tp-pop-layer 0 6 str) 0)))))
(ert-deftest tp-stack-test-movement-ops-return-run-counts ()
"Move, raise, pin and switch return matched-run counts."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(should (= (tp-raise-layer 1 6 'nope 1) 0))
(should (= (tp-raise-layer 1 6 'la 1) 1))
(should (= (tp-pin-layer 1 6 'lb) 1))
(should (= (tp-move-layer 1 6 'la 0) 1))
(should (= (tp-move-layer 1 6 'nope 0) 0))
(should (= (tp-switch-layer 1 6 'la 'lb) 1))
(should (= (tp-switch-layer 1 6 'la 'nope) 0))))
(ert-deftest tp-stack-test-put-layer-noerror ()
"With NOERROR an unresolvable LAYER returns nil and writes nothing."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(should-error (tp-put-layer 1 6 'undefined-x 0))
(should (null (tp-put-layer 1 6 'undefined-x 0 nil t)))
(should (null (text-properties-at 1)))
;; A resolvable layer with NOERROR still applies normally.
(should (tp-put-layer 1 6 'la 0 nil t))
(should (eq (get-text-property 1 'tp-name) 'la))))
(ert-deftest tp-stack-test-push-layer-noerror-both-forms ()
"NOERROR works for push in region and string forms."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(should-error (tp-push-layer str 'undefined-x))
(should (null (tp-push-layer str 'undefined-x t)))
(should (null (tp-put-layer str 'undefined-x 0 t)))
(should (null (text-properties-at 0 str)))
;; The string form still returns the string on success.
(should (eq (tp-push-layer str 'la t) str))
(should (eq (get-text-property 0 'tp-name str) 'la)))
(insert "abcdef")
(should (null (tp-push-layer 1 6 'undefined-x nil t)))
(should (null (text-properties-at 1)))))
;;; Multi-argument parameterized specs through tp-put-layer
(ert-deftest tp-stack-test-put-layer-multiarg-layer-flat ()
"tp-put-layer accepts flat (LAYER ARG1 ARG2) for a 2-arity layer."
(tp-layer-reset)
(define-tp tp-st-colors (fg bg)
`(face (:foreground ,fg :background ,bg)))
(with-temp-buffer
(insert "Hello")
(tp-put-layer 1 5 '(tp-st-colors "red" "blue") 0)
(should (equal (tp-at 1 'face)
'(:foreground "red" :background "blue")))))
(ert-deftest tp-stack-test-put-layer-multiarg-layer-wrapped ()
"tp-put-layer accepts wrapped (LAYER (ARG1 ARG2)) for a 2-arity layer."
(tp-layer-reset)
(define-tp tp-st-colors2 (fg bg)
`(face (:foreground ,fg :background ,bg)))
(with-temp-buffer
(insert "Hello")
(tp-put-layer 1 5 '(tp-st-colors2 ("green" "black")) 0)
(should (equal (tp-at 1 'face)
'(:foreground "green" :background "black")))))
(ert-deftest tp-stack-test-put-layer-multiarg-layer-symbol-args ()
"Multi-arg specs are not misread as a list of layer names.
Arguments that are themselves defined layer names used to be
intercepted by the list-of-specs branch."
(tp-layer-reset)
(define-tp tp-st-a () '(help-echo "a"))
(define-tp tp-st-b () '(help-echo "b"))
(define-tp tp-st-pair (x y)
`(display (,x . ,y)))
(with-temp-buffer
(insert "Hello")
(tp-put-layer 1 5 '(tp-st-pair tp-st-a tp-st-b) 0)
(should (equal (tp-at 1 'display) '(tp-st-a . tp-st-b)))
(should (null (tp-at 1 'help-echo)))))
(ert-deftest tp-stack-test-put-layer-multiarg-group ()
"tp-put-layer accepts (GROUP ARG1 ARG2) for a 2-arity group."
(tp-layer-reset)
(define-tps tp-st-duo (fg bg)
`(face (:foreground ,fg))
`(face (:background ,bg)))
(with-temp-buffer
(insert "Hello")
(tp-put-layer 1 5 '(tp-st-duo "red" "blue") 0)
(should (equal (tp-at 1 'face) '(:foreground "red")))
(should (= (tp-layer-count 1 5) 2))))
(ert-deftest tp-stack-test-remove-multiarg-layer-by-name ()
"tp-remove removes a multi-arg parameterized layer's props by name.
Applied via `tp-put-layer' so the region carries the layer's
`tp-name' (the `tp-set' plist forms do not stamp `tp-name' for
parameterized layers, so name-based removal cannot see those).
The key-extraction path must bind all parameters (dummy args),
not just the first."
(tp-layer-reset)
(define-tp tp-st-colors3 (fg bg)
`(face (:foreground ,fg :background ,bg)))
(with-temp-buffer
(insert "Hello")
(tp-put-layer 1 5 '(tp-st-colors3 "red" "blue") 0)
(put-text-property 1 5 'help-echo "tip")
(should (tp-at 1 'face))
(should (eq (tp-at 1 'tp-name) 'tp-st-colors3))
(tp-remove 1 5 'tp-st-colors3)
(should (null (tp-at 1 'face)))
(should (equal (tp-at 1 'help-echo) "tip"))))
;;; HID-1/XM-01: reactive updates must write through to tp-layers storage
(defvar tp-st-xm01-a-color nil)
(defvar tp-st-xm01-b-color nil)
(defvar tp-st-xm01-c-color nil)
(defvar tp-st-xm01-rt-color nil)
(defvar tp-st-xm01-t-text nil)
(defvar tp-st-xm01-x-color nil)
(ert-deftest tp-stack-test-reactive-update-reaches-hidden-layer ()
"XM-01 A3: an update received while a layer is hidden renders after show.
The hidden layer has no direct `tp-name', so the update must find and
refresh its entry inside `tp-layers' stack storage."
(tp-stack-tests--with-env
(setq tp-st-xm01-a-color "red")
(define-tp tp-st-xm01-lay-a ()
:props '(face (:foreground $tp-st-xm01-a-color)))
(insert "AAAAAA")
(tp-push-layer 1 7 'tp-st-xm01-lay-a)
(tp-hide-layer 1 7 'tp-st-xm01-lay-a)
(setq tp-st-xm01-a-color "blue")
(tp-show-layer 1 7 'tp-st-xm01-lay-a)
(should (equal (get-text-property 1 'face) '(:foreground "blue")))))
(ert-deftest tp-stack-test-stack-op-never-reverts-reactive-update ()
"XM-01 B1-B4: stack ops rebuild from CURRENT values, never stale ones.
With another layer hidden the storage switches to full-stack mode
where `tp-layers' is authoritative; a reactive update must refresh
the stored snapshot so a no-op stack operation cannot revert the
rendered value, and re-setting the SAME value (a watcher no-op) never
needs to repair anything."
(tp-stack-tests--with-env
(setq tp-st-xm01-b-color "red")
(define-tp tp-st-xm01-lay-b ()
:props '(face (:foreground $tp-st-xm01-b-color)))
(define-tp tp-st-xm01-lay-bg () '(face (:background "gray")))
(insert "BBBBBB")
(tp-push-layer 1 7 'tp-st-xm01-lay-bg)
(tp-push-layer 1 7 'tp-st-xm01-lay-b)
(tp-hide-layer 1 7 'tp-st-xm01-lay-bg) ; -> full-stack storage mode
(setq tp-st-xm01-b-color "blue")
;; B1: the visible reactive top renders the new value...
(should (equal (get-text-property 1 'face) '(:foreground "blue")))
;; ...and the stored stack snapshot agrees (write-through).
(let ((entry (assq 'tp-st-xm01-lay-b (tp-layer-stack-at 1))))
(should (equal (plist-get (cdr entry) 'face) '(:foreground "blue"))))
;; B2: a no-op stack operation must not revert the update.
(tp-move-layer 1 7 'tp-st-xm01-lay-b 0)
(should (equal (get-text-property 1 'face) '(:foreground "blue")))
;; B3: re-setting the same value is a watcher no-op; the buffer is
;; already correct (before the fix it stayed stuck on the old value).
(setq tp-st-xm01-b-color "blue")
(should (equal (get-text-property 1 'face) '(:foreground "blue")))
;; B4: a third value still updates normally.
(setq tp-st-xm01-b-color "green")
(should (equal (get-text-property 1 'face) '(:foreground "green")))))
(ert-deftest tp-stack-test-hidden-top-round-trip-keeps-reactive-value ()
"XM-01/HID-1: show+hide of an UNRELATED layer keeps the reactive value.
Static top hidden, reactive layer rendered below: after a variable
change, a show/hide round trip of the top rebuilds from storage and
must not revert the reactive layer to a stale snapshot."
(tp-stack-tests--with-env
(setq tp-st-xm01-rt-color "red")
(define-tp tp-st-xm01-lay-rt ()
:props '(face (:foreground $tp-st-xm01-rt-color)))
(define-tp tp-st-xm01-lay-cover () '(face (:background "yellow")))
(insert "Hello")
(tp-push-layer 1 6 'tp-st-xm01-lay-rt)
(tp-push-layer 1 6 'tp-st-xm01-lay-cover)
(tp-hide-layer 1 6 'tp-st-xm01-lay-cover)
(setq tp-st-xm01-rt-color "blue")
(should (equal (get-text-property 1 'face) '(:foreground "blue")))
(tp-show-layer 1 6 'tp-st-xm01-lay-cover)
(tp-hide-layer 1 6 'tp-st-xm01-lay-cover)
(should (equal (get-text-property 1 'face) '(:foreground "blue")))))
(ert-deftest tp-stack-test-pop-reveals-current-reactive-value ()
"XM-01 C2: a below-top reactive layer revealed by tp-pop-layer is current.
The buried layer's entry lives inside `tp-layers'; the update must
refresh it there so the reveal renders current values."
(tp-stack-tests--with-env
(setq tp-st-xm01-c-color "red")
(define-tp tp-st-xm01-lay-c ()
:props '(face (:foreground $tp-st-xm01-c-color)))
(define-tp tp-st-xm01-lay-top () '(face (:foreground "black")))
(insert "DDDDDD")
(tp-push-layer 1 7 'tp-st-xm01-lay-c)
(tp-push-layer 1 7 'tp-st-xm01-lay-top)
(setq tp-st-xm01-c-color "blue")
(tp-pop-layer 1 7)
(should (equal (get-text-property 1 'face) '(:foreground "blue")))))
(ert-deftest tp-stack-test-reactive-tp-text-reaches-hidden-layer ()
"XM-01 T1: a reactive tp-text update reaches a hidden layer's text.
Text content is physical - hide/show toggles properties, never text -
so the model value replaces the text while the layer is hidden, and
`tp-show-layer' then renders current props over current text."
(tp-stack-tests--with-env
(setq tp-st-xm01-t-text "AAA")
(define-tp tp-st-xm01-lay-t ()
:props '(tp-text $tp-st-xm01-t-text face (:foreground "purple")))
(insert "AAA")
(tp-push-layer 1 4 'tp-st-xm01-lay-t)
(tp-hide-layer 1 4 'tp-st-xm01-lay-t)
(setq tp-st-xm01-t-text "ZZZ")
(tp-show-layer 1 4 'tp-st-xm01-lay-t)
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"ZZZ"))
(should (equal (get-text-property 1 'tp-text) "ZZZ"))
(should (equal (get-text-property 1 'face) '(:foreground "purple")))))
(ert-deftest tp-stack-test-mixed-visible-hidden-regions-stay-in-sync ()
"XM-01 X1: visible and hidden regions of one layer both end up current.
Before the fix one buffer could render two different values of the
same variable at once (split-brain)."
(tp-stack-tests--with-env
(setq tp-st-xm01-x-color "red")
(define-tp tp-st-xm01-lay-x ()
:props '(face (:foreground $tp-st-xm01-x-color)))
(insert "XXXXXXXXXX")
(tp-push-layer 1 5 'tp-st-xm01-lay-x)
(tp-push-layer 6 11 'tp-st-xm01-lay-x)
(tp-hide-layer 6 11 'tp-st-xm01-lay-x)
(setq tp-st-xm01-x-color "blue")
(tp-show-layer 6 11 'tp-st-xm01-lay-x)
(should (equal (get-text-property 1 'face) '(:foreground "blue")))
(should (equal (get-text-property 6 'face) '(:foreground "blue")))))
;;; REG-1: every stack write must register its buffer in the reactive registry
(defvar tp-st-reg1-color nil)
(ert-deftest tp-stack-test-push-layer-registers-reactive-buffer ()
"tp-push-layer in a second buffer keeps reactive updates flowing there.
Once the registry knows a layer from a `tp-set' in one buffer, a
stack-path application in another buffer must register too; before
the REG-1 fix the second buffer was silently and permanently skipped
by every later update."
(setq tp-st-reg1-color "red")
(unwind-protect
(progn
(tp-layer-reset)
(define-tp tp-st-reg1-layer ()
:props '(face (:foreground $tp-st-reg1-color)))
(let ((a (generate-new-buffer " *tp-reg1-a*"))
(b (generate-new-buffer " *tp-reg1-b*")))
(unwind-protect
(progn
(with-current-buffer a (insert "hello"))
(with-current-buffer b (insert "hello"))
(tp-set 1 6 'tp-st-reg1-layer a) ; registers A
(with-current-buffer b
(tp-push-layer 1 6 'tp-st-reg1-layer))
;; The registry must know BOTH buffers.
(let ((bufs (tp-reactive-layer-buffers 'tp-st-reg1-layer)))
(should (memq a bufs))
(should (memq b bufs)))
(setq tp-st-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")))
;; And the registration is permanent, not a one-shot fluke.
(setq tp-st-reg1-color "green")
(should (equal (with-current-buffer b
(get-text-property 1 'face))
'(:foreground "green"))))
(kill-buffer a)
(kill-buffer b))))
(tp-layer-reset)
(setq tp-st-reg1-color nil)))
(ert-deftest tp-stack-test-stack-write-registers-buried-and-hidden-layers ()
"Stack writes register every named layer of the new stack, not just the top.
A buried layer (under a fresh push) and a hidden layer arrive in the
buffer via string insertion - a path that never registers - and the
next stack write on the region must register them (REG-1; GC-1's
liveness depends on this)."
(unwind-protect
(progn
(tp-layer-reset)
(define-tp tp-st-reg1-buried () '(face bold))
(define-tp tp-st-reg1-top () '(face italic))
(define-tp tp-st-reg1-hidden () '(face underline))
(let ((buf (generate-new-buffer " *tp-reg1-c*")))
(unwind-protect
(with-current-buffer buf
;; Propertized string insertion bypasses registration.
(insert (let ((s (copy-sequence "hello")))
(tp-push-layer s 'tp-st-reg1-buried)
s))
(insert (let ((s (copy-sequence " world")))
(tp-push-layer s 'tp-st-reg1-hidden)
s))
(should (eq (tp-reactive-layer-buffers 'tp-st-reg1-buried)
'unknown))
;; Pushing a new top rewrites the stack: the buried
;; layer below it must be registered as well.
(tp-push-layer 1 6 'tp-st-reg1-top)
(should (memq buf (tp-reactive-layer-buffers
'tp-st-reg1-buried)))
(should (memq buf (tp-reactive-layer-buffers
'tp-st-reg1-top)))
;; Hiding rewrites the stack: the now-hidden layer must
;; stay registered even though it loses its direct
;; tp-name.
(tp-hide-layer 7 12 'tp-st-reg1-hidden)
(should (memq buf (tp-reactive-layer-buffers
'tp-st-reg1-hidden))))
(kill-buffer buf))))
(tp-layer-reset)))
(provide 'tp-stack-tests)
;;; tp-stack-tests.el ends here

702
tp-stack.el
View File

@ -12,16 +12,16 @@
;;; Commentary:
;; Photoshop-style layer stack operations on text regions: put/push/
;; delete/pop/move/raise/rotate/pin/switch/merge/flatten, stack queries,
;; and bulk layer property manipulation.
;; delete/pop/move/raise/lower/rotate/pin/switch/hide/show/merge/
;; flatten, stack queries, and bulk layer property manipulation.
;;; Code:
(require 'cl-lib)
(require 'dash)
(require 'tp-core)
(require 'tp-reactive)
(require 'tp-layer)
(require 'tp-ops)
;;; Shared argument parsing and region iteration
@ -50,6 +50,12 @@ buffers)."
(seq-take (cdr rest) n)))
(t (error "Invalid layer arguments: %S" (cons start-or-string rest)))))
(defun tp--plist-remove (plist key)
"Return a copy of PLIST without KEY and its value.
Comparison uses `eq'. PLIST itself is not modified."
(cl-loop for (k v) on plist by #'cddr
unless (eq k key) append (list k v)))
(defun tp--stack-map-region (start end object function)
"Call FUNCTION over each property run of [START, END) in OBJECT.
@ -57,7 +63,8 @@ OBJECT is a string, a buffer, or nil for the current buffer.
FUNCTION receives (ABS-START ABS-END STACK): the run's bounds, clipped
to [START, END) and expressed in OBJECT's native coordinates (0-based
for strings, 1-based for buffers), and the run's layer stack as a list
of layer plists, top layer first (empty for bare text).
of layer plists, top layer first (empty for bare text). Hidden layers
\(see `tp-hide-layer') are included at their stack position.
Returns the list of FUNCTION's non-nil results, in order.
@ -69,26 +76,25 @@ previously property-less text."
(tp--map-intervals
object start end
(lambda (i-start i-end props)
(let* ((idx (-elem-index 'tp-layers props))
(top (if idx
(-remove-at-indices (list idx (1+ idx)) props)
props))
(belows (plist-get props 'tp-layers)))
(funcall function i-start i-end
(tp--layer-stack-to-list top belows)))))))
(funcall function i-start i-end
(tp--stack-props-to-list props))))))
(defun tp--stack-build-props (layer-list)
"Build text properties from LAYER-LIST (top layer first).
Like `tp--build-layer-props', but the `tp-layers' entry is only added
when there are below-layers, so single-layer stacks do not carry a
garbage (tp-layers nil) property. Consumers must therefore tolerate
an absent `tp-layers' property (both `plist-get' and
`tp--stack-map-region' do)."
(cond
((null layer-list) nil)
((null (cdr layer-list)) (copy-sequence (car layer-list)))
(t (append (car layer-list)
(list 'tp-layers (cdr layer-list))))))
(defun tp--stack-register-layers (stack object)
"Register OBJECT in the reactive buffer registry for every layer in STACK.
STACK is a list of layer plists as stored by the stack operations.
When OBJECT is a buffer or nil (the current buffer), every plist
carrying a `tp-name' - buried and hidden layers included - registers
that buffer via `tp-reactive--register-layer-buffer', so reactive
updates and the anonymous-layer GC keep seeing buffers whose layers
were written by stack mutators rather than by `tp-set'. String
OBJECTs are not registered; see `tp-reactive-layer-buffers' for that
gap. Registration is idempotent, so calling this once per rewritten
run is cheap."
(when (or (null object) (bufferp object))
(let ((buf (or object (current-buffer))))
(dolist (layer stack)
(when-let ((name (plist-get layer 'tp-name)))
(tp-reactive--register-layer-buffer name buf))))))
;;; Queries
@ -140,12 +146,36 @@ Scans the region's property runs in order and returns the `tp-name'
of the first top layer that has one, so bare or unnamed runs (for
example before a layer that starts mid-region) do not hide layers
later in the region. Returns nil when no run in the region has a
named top layer. OBJECT defaults to current buffer."
named top layer. OBJECT defaults to current buffer.
The topmost layer is reported in stack order even when it is hidden
\(see `tp-hide-layer'); use `tp-layer-stack-at' to distinguish hidden
layers from visible ones."
(car (tp--stack-map-region
start end object
(lambda (_abs-start _abs-end stack)
(plist-get (car stack) 'tp-name)))))
(defun tp-layer-stack-at (pos &optional object)
"Return the full ordered layer stack at POS in OBJECT.
The result is a list with one element per layer, topmost layer first
and bottommost last, where each element is a cons (NAME . PROPS):
- NAME is the layer's `tp-name' symbol, or nil for an unnamed layer.
- PROPS is the layer's property plist without its `tp-name' entry.
A hidden layer (see `tp-hide-layer') is distinguishable by the
entry `tp-hidden' with value t in PROPS; visible layers never
carry a `tp-hidden' entry.
Hidden layers are included at their stack position. Returns nil for
bare text. POS is in OBJECT's native coordinates (0-based for
strings, 1-based for buffers). OBJECT is a string, a buffer, or nil
for the current buffer."
(mapcar (lambda (layer)
(cons (plist-get layer 'tp-name)
(tp--plist-remove layer 'tp-name)))
(tp--stack-props-to-list (text-properties-at pos object))))
;;; Layer spec normalization for tp-put-layer
(defun tp--put-layer-specs (layer-spec)
@ -173,6 +203,40 @@ defined layer or group name); a named inline layer has odd length
;; Any other symbol: a single layer name.
((symbolp layer-spec)
(list (tp--normalize-layer-spec layer-spec)))
;; (GROUP-NAME ARG1 ... ARGN) or (GROUP-NAME (ARG1 ... ARGN)):
;; multi-argument parameterized group (arity >= 2). Checked before
;; the single-arg forms so the wrapped variant is not mistaken for
;; one list-valued argument.
((and (consp layer-spec)
(symbolp (car layer-spec))
(proper-list-p layer-spec)
(let ((arity (length (tp--group-arglist (car layer-spec)))))
(and (>= arity 2)
(or (= (length (cdr layer-spec)) arity)
(and (= (length (cdr layer-spec)) 1)
(proper-list-p (cadr layer-spec))
(= (length (cadr layer-spec)) arity))))))
(let* ((arity (length (tp--group-arglist (car layer-spec))))
(args (if (= (length (cdr layer-spec)) arity)
(cdr layer-spec)
(cadr layer-spec))))
(tp--group-props-with-args (car layer-spec) args t)))
;; (LAYER-NAME ARG1 ... ARGN) or (LAYER-NAME (ARG1 ... ARGN)):
;; multi-argument parameterized layer (arity >= 2).
((and (consp layer-spec)
(symbolp (car layer-spec))
(proper-list-p layer-spec)
(let ((arity (length (tp-layer-arglist (car layer-spec)))))
(and (>= arity 2)
(or (= (length (cdr layer-spec)) arity)
(and (= (length (cdr layer-spec)) 1)
(proper-list-p (cadr layer-spec))
(= (length (cadr layer-spec)) arity))))))
(let* ((arity (length (tp-layer-arglist (car layer-spec))))
(args (if (= (length (cdr layer-spec)) arity)
(cdr layer-spec)
(cadr layer-spec))))
(list (tp--normalize-layer-spec (cons (car layer-spec) args)))))
;; (GROUP-NAME ARG): parameterized group.
((and (consp layer-spec)
(symbolp (car layer-spec))
@ -212,15 +276,15 @@ defined layer or group name); a named inline layer has odd length
;;; Mutators
(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object)
(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object noerror)
"Set layer(s) at a specific index position.
Calling conventions:
1. Buffer/string region:
(tp-put-layer START END LAYER IDX OBJECT)
(tp-put-layer START END LAYER IDX OBJECT NOERROR)
2. Entire string:
(tp-put-layer STRING LAYER IDX)
(tp-put-layer STRING LAYER IDX NOERROR)
LAYER can be:
- A symbol (layer name from `tp-layer-alist' or `tp-layer-groups')
@ -236,43 +300,76 @@ IDX specifies where to insert:
- Other values insert at that position
OBJECT defaults to current buffer for region form. Only text inside
\[START, END) is modified."
\[START, END) is modified.
A LAYER naming an undefined layer or group normally signals an
error. If NOERROR is non-nil, return nil instead of signaling when
LAYER cannot be resolved; nothing is modified in that case.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own. The returned string is
that same mutated object.
Returns OBJECT when one was given (in particular the string in
string forms), otherwise the cons (START . END)."
(pcase-let ((`(,start ,end ,obj ,layer-spec ,idx)
(tp--parse-layer-args
start-or-string
(list end-or-layer layer-or-idx idx-or-object object) 2)))
(setq idx (or idx 0))
(let ((layers-to-add (tp--put-layer-specs layer-spec)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((actual-idx (if (< idx 0)
(max 0 (+ (length stack) 1 idx))
(min idx (length stack))))
(new-stack (append (seq-take stack actual-idx)
layers-to-add
(seq-drop stack actual-idx))))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)))))
(or obj (cons start end))))
(let* ((noerr (if (stringp start-or-string) idx-or-object noerror))
(layers-to-add
(if noerr
(condition-case nil
(tp--put-layer-specs layer-spec)
(error 'tp--unresolved))
(tp--put-layer-specs layer-spec))))
(unless (eq layers-to-add 'tp--unresolved)
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((actual-idx (if (< idx 0)
(max 0 (+ (length stack) 1 idx))
(min idx (length stack))))
(new-stack (append (seq-take stack actual-idx)
layers-to-add
(seq-drop stack actual-idx))))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj))))
(or obj (cons start end))))))
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object)
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object noerror)
"Push layer(s) to the top of the layer stack.
This is equivalent to (tp-put-layer ... LAYER 0 ...).
Calling conventions:
1. Buffer/string region:
(tp-push-layer START END LAYER OBJECT)
(tp-push-layer START END LAYER OBJECT NOERROR)
2. Entire string:
(tp-push-layer STRING LAYER)"
(tp-push-layer STRING LAYER NOERROR)
A LAYER naming an undefined layer or group normally signals an
error. If NOERROR is non-nil, return nil instead of signaling when
LAYER cannot be resolved; nothing is modified in that case.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own. The returned string is
that same mutated object.
Returns what `tp-put-layer' returns: OBJECT when one was given (in
particular the string in string forms), otherwise (START . END)."
(pcase-let ((`(,start ,end ,obj ,layer)
(tp--parse-layer-args
start-or-string
(list end-or-layer layer-or-object object) 1)))
(tp-put-layer start end layer 0 obj)))
(let ((noerr (if (stringp start-or-string) layer-or-object noerror)))
(tp-put-layer start end layer 0 obj noerr))))
(defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object)
"Delete layer by name or index.
@ -288,20 +385,31 @@ LAYER-NAME/IDX can be:
- A symbol (layer name)
- An integer (layer index, 0=top, -1=bottom)
Only text inside [START, END) is modified."
Only text inside [START, END) is modified.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified. A LAYER-NAME/IDX
matching no layer never signals: unmatched runs are silently left
alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,layer-id)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-object object) 1)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack layer-id)))
(set-text-properties
abs-start abs-end
(tp--stack-build-props (-remove-at (car found) stack))
obj))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack layer-id)))
(let ((new-stack (-remove-at (car found) stack)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj))
(setq count (1+ count)))))
count)))
(defun tp-pop-layer (start-or-string &optional end-or-object object)
"Pop the top layer from the layer stack.
@ -313,7 +421,14 @@ Calling conventions:
(tp-pop-layer START END OBJECT)
2. Entire string:
(tp-pop-layer STRING)"
(tp-pop-layer STRING)
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified; 0 means no run in the
region had a layer to pop."
(pcase-let ((`(,start ,end ,obj)
(tp--parse-layer-args
start-or-string (list end-or-object object) 0)))
@ -398,19 +513,30 @@ TO-IDX is the target position (integer index):
Both indices refer to positions before the move.
The layer at FROM-ID is removed and inserted at TO-IDX position.
OBJECT defaults to current buffer for region form."
OBJECT defaults to current buffer for region form.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified. A FROM-ID matching no
layer never signals: unmatched runs are silently left alone and a
return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,from-id ,to-idx)
(tp--parse-layer-args
start-or-string
(list end-or-from from-or-to to-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj)
(setq count (1+ count)))))
count)))
(defun tp-raise-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object)
"Raise a layer by N positions in the stack.
@ -424,41 +550,162 @@ Calling conventions:
Positive N moves the layer up (toward top/visible).
Negative N moves the layer down (toward bottom).
N defaults to 1. The resulting position is clamped to the stack.
Uses `tp--raise-layer-in-stack' internally, which is built on
`tp--move-layer-in-stack'."
`tp--move-layer-in-stack'.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified. An IDX/LAYER-NAME
matching no layer never signals: unmatched runs are silently left
alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,layer-id ,n)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-n n-or-object object) 2)))
(setq n (or n 1))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj)
(setq count (1+ count)))))
count)))
(defun tp-rotate-layer (start-or-string &optional end-or-object object)
"Rotate layers, moving top layer to bottom.
(defun tp-lower-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object)
"Lower a layer by N positions in the stack.
This is the mirror image of `tp-raise-layer': lowering by N is
raising by -N.
Calling conventions:
1. Buffer/string region:
(tp-rotate-layer START END OBJECT)
(tp-lower-layer START END IDX/LAYER-NAME N OBJECT)
2. Entire string:
(tp-rotate-layer STRING)
(tp-lower-layer STRING IDX/LAYER-NAME N)
Uses `tp-move-layer' internally to move layer at index 0 to index -1."
(pcase-let ((`(,start ,end ,obj)
IDX/LAYER-NAME identifies the layer: a layer name symbol or an
integer index (0 = top, negative indices count from the bottom, so
-1 = bottom).
Positive N moves the layer down (toward bottom).
Negative N moves the layer up (toward top/visible).
N defaults to 1. The resulting position is clamped to the stack.
OBJECT defaults to current buffer for region form.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified. An IDX/LAYER-NAME
matching no layer never signals: unmatched runs are silently left
alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,layer-id ,n)
(tp--parse-layer-args
start-or-string (list end-or-object object) 0)))
(tp-move-layer start end 0 -1 obj)))
start-or-string
(list end-or-idx idx-or-n n-or-object object) 2)))
(setq n (or n 1))
(tp-raise-layer start end layer-id (- n) obj)))
(defun tp-rotate-layer (start-or-string &optional end-or-direction
direction-object-or-count
count-or-direction object-or-count)
"Rotate layers, by default moving the top layer to the bottom.
Calling conventions:
1. Buffer/string region (canonical order, OBJECT last like the rest
of the stack family):
(tp-rotate-layer START END DIRECTION &optional COUNT OBJECT)
2. Entire string:
(tp-rotate-layer STRING DIRECTION COUNT)
3. Buffer/string region (legacy 0.3.0 order, kept working forever):
(tp-rotate-layer START END OBJECT DIRECTION COUNT)
The two region orders are told apart by the third argument: the
symbols `up' and `down' are never valid OBJECTs, so a third argument
of `up'/`down' unambiguously selects the canonical order, e.g.
\(tp-rotate-layer 1 5 \\='up) - no nil OBJECT placeholder needed.
Any other third argument (a buffer, a string, or nil for the current
buffer) selects the legacy order.
DIRECTION is `down' or nil to move the top layer to the bottom (the
historical behavior), or `up' to move the bottom layer to the top;
any other value signals an error. COUNT is the number of rotation
steps and defaults to 1; a COUNT below 1 rotates nothing. Layers
keep their relative order; hidden layers rotate with the rest of the
stack.
OBJECT defaults to current buffer for region forms.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified; 0 means no run in the
region had layers to rotate (or COUNT was below 1)."
(let (start end obj dir cnt)
(cond
;; Entire string form: (STRING DIRECTION COUNT).
((stringp start-or-string)
(setq start 0
end (length start-or-string)
obj start-or-string
dir end-or-direction
cnt direction-object-or-count))
((numberp start-or-string)
(setq start start-or-string
end end-or-direction)
(if (memq direction-object-or-count '(up down))
;; Canonical region order: (START END DIRECTION COUNT OBJECT).
(setq dir direction-object-or-count
cnt count-or-direction
obj object-or-count)
;; Legacy region order: (START END OBJECT DIRECTION COUNT).
(setq obj direction-object-or-count
dir count-or-direction
cnt object-or-count)))
(t (error "Invalid layer arguments: %S"
(cons start-or-string
(list end-or-direction direction-object-or-count)))))
(let ((applied 0))
(setq dir (or dir 'down)
cnt (or cnt 1))
(unless (memq dir '(up down))
(error "Invalid rotate direction: %S" dir))
(when (>= cnt 1)
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when stack
(let* ((len (length stack))
(k (mod (if (eq dir 'up) (- cnt) cnt) len))
(new-stack (append (seq-drop stack k)
(seq-take stack k))))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj)
(setq applied (1+ applied)))))))
applied)))
(defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object)
"Pin a layer to the top (make it visible).
"Move layer IDX/LAYER-NAME to the top of the stack (one-shot).
Despite the name, nothing stays pinned: this is a single move to
index 0, exactly (tp-move-layer ... IDX/LAYER-NAME 0 ...), and
nothing prevents a later `tp-push-layer' or `tp-put-layer' from
covering the moved layer again.
Calling conventions:
1. Buffer/string region:
@ -467,7 +714,13 @@ Calling conventions:
2. Entire string:
(tp-pin-layer STRING IDX/LAYER-NAME)
Uses `tp-move-layer' internally to move the specified layer to index 0 (top)."
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified. An IDX/LAYER-NAME
matching no layer never signals: unmatched runs are silently left
alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,layer-id)
(tp--parse-layer-args
start-or-string
@ -484,19 +737,134 @@ Calling conventions:
2. Entire string:
(tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)
Uses `tp--switch-layers-in-stack' internally."
Uses `tp--switch-layers-in-stack' internally.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified. When either layer is
missing from a run's stack nothing signals: such runs are silently
left alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,id1 ,id2)
(tp--parse-layer-args
start-or-string
(list end-or-id1 id1-or-id2 id2-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj)
(setq count (1+ count)))))
count)))
(defun tp-hide-layer (start-or-string &optional end-or-name name-or-object object)
"Hide layer NAME in region from START to END without removing it.
Calling conventions:
1. Buffer/string region:
(tp-hide-layer START END NAME OBJECT)
2. Entire string:
(tp-hide-layer STRING NAME)
NAME identifies the layer: a layer name symbol or an integer index
into the full stack, hidden layers included (0 = top, -1 = bottom).
A hidden layer stays in the stack -- it still counts for
`tp-layer-count', appears in `tp-layer-list' and `tp-layer-stack-at'
and can be moved, raised or lowered -- but it no longer renders: the
text shows the properties of the topmost non-hidden layer instead.
Hiding the currently visible top layer therefore reveals the next
visible layer below it. When every layer of a run is hidden the text
keeps only the `tp-layers' bookkeeping property (so not even
`tp-name' renders) while all layers stay queryable. Use
`tp-show-layer' to make a hidden layer render again.
Hiddenness is stored as a `tp-hidden' flag entry inside the layer's
plist in the `tp-layers' stack storage, so `tp-hidden' is a reserved
property name inside layers, like `tp-name'.
OBJECT defaults to current buffer for region form.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified. A NAME matching no
layer never signals; runs whose match is already hidden are left
alone as well, so a return value of 0 means nothing changed."
(pcase-let ((`(,start ,end ,obj ,name)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-object object) 1)))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack name)))
(unless (tp--stack-hidden-p (cdr found))
(let ((new-stack (-replace-at (car found)
(append (list 'tp-hidden t)
(cdr found))
stack)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj)
(setq count (1+ count)))))))
count)))
(defun tp-show-layer (start-or-string &optional end-or-name name-or-object object)
"Show layer NAME in region from START to END, undoing `tp-hide-layer'.
Calling conventions:
1. Buffer/string region:
(tp-show-layer START END NAME OBJECT)
2. Entire string:
(tp-show-layer STRING NAME)
NAME identifies the layer: a layer name symbol or an integer index
into the full stack, hidden layers included (0 = top, -1 = bottom).
The layer's `tp-hidden' flag is removed. When the shown layer sits
above the currently visible top layer it becomes the rendered layer
again, restoring its properties onto the text.
OBJECT defaults to current buffer for region form.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified. A NAME matching no
layer never signals; runs whose match is not hidden are left alone
as well, so a return value of 0 means nothing changed."
(pcase-let ((`(,start ,end ,obj ,name)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-object object) 1)))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack name)))
(when (tp--stack-hidden-p (cdr found))
(let ((new-stack (-replace-at (car found)
(tp--plist-remove (cdr found)
'tp-hidden)
stack)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj)
(setq count (1+ count)))))))
count)))
(defun tp--merge-layer-props (layers initial)
"Merge the plists of LAYERS into the INITIAL plist and return it.
@ -505,10 +873,11 @@ LAYERS is a list of (INDEX . PROPS) conses as returned by
already present in the accumulator is never overwritten, and presence
is tested with `plist-member' so an explicit nil value in a higher
layer shadows lower layers' values. `tp-name' keys of the merged
layers are dropped (INITIAL may seed its own)."
layers are dropped (INITIAL may seed its own), as are `tp-hidden'
bookkeeping flags (see `tp-hide-layer')."
(cl-reduce (lambda (acc layer)
(cl-loop for (key val) on (cdr layer) by #'cddr
unless (eq key 'tp-name)
unless (memq key '(tp-name tp-hidden))
do (unless (plist-member acc key)
(setq acc (plist-put acc key val))))
acc)
@ -527,35 +896,65 @@ Calling conventions:
(tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...))
Earlier layers in the list take precedence; a property explicitly set
to nil in a higher-precedence layer stays nil in the merged layer."
to nil in a higher-precedence layer stays nil in the merged layer.
Hidden matched layers (see `tp-hide-layer') are merged away with the
rest but contribute NO properties to the merged layer, so a merge can
never render what was hidden. When EVERY matched layer of a run is
hidden, the merged layer keeps their merged properties but carries
the `tp-hidden' flag itself: the data is preserved without un-hiding
anything, and `tp-show-layer' on the merged layer renders it.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified, counting like
`tp-delete-layer': a run counts when at least one listed layer
matched and the merge rewrote it, and 0 means nothing matched at
all."
(pcase-let ((`(,start ,end ,obj ,new-name ,layer-ids)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-ids ids-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((layers-to-merge
(cl-loop for id in layer-ids
for found = (tp--get-layer-by-idx-or-name stack id)
when found collect found))
;; Sort by index (descending) to remove from end first
(sorted-layers (sort (copy-sequence layers-to-merge)
(lambda (a b) (> (car a) (car b))))))
(when layers-to-merge
;; Merge properties (earlier in list takes precedence)
(let ((merged-props (tp--merge-layer-props
layers-to-merge (list 'tp-name new-name)))
(new-stack stack))
;; Remove old layers from stack
(dolist (idx (mapcar #'car sorted-layers))
(setq new-stack (-remove-at idx new-stack)))
;; Add merged layer at top
(setq new-stack (cons merged-props new-stack))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((layers-to-merge
(cl-loop for id in layer-ids
for found = (tp--get-layer-by-idx-or-name stack id)
when found collect found))
;; Sort by index (descending) to remove from end first
(sorted-layers (sort (copy-sequence layers-to-merge)
(lambda (a b) (> (car a) (car b))))))
(when layers-to-merge
;; Merge properties (earlier in list takes precedence).
;; Hidden layers contribute no props unless ALL matched
;; layers are hidden, in which case the merged layer
;; keeps their props but stays hidden itself.
(let* ((visible (seq-remove (lambda (found)
(tp--stack-hidden-p (cdr found)))
layers-to-merge))
(merged-props
(if visible
(tp--merge-layer-props
visible (list 'tp-name new-name))
(tp--merge-layer-props
layers-to-merge
(list 'tp-name new-name 'tp-hidden t))))
(new-stack stack))
;; Remove old layers from stack
(dolist (idx (mapcar #'car sorted-layers))
(setq new-stack (-remove-at idx new-stack)))
;; Add merged layer at top
(setq new-stack (cons merged-props new-stack))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(tp--stack-register-layers new-stack obj)
(setq count (1+ count)))))))
count)))
(defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object)
"Flatten all layers into a single layer.
@ -569,22 +968,46 @@ Calling conventions:
NAME can be nil for an unnamed layer. Higher layers take precedence;
a property explicitly set to nil in a higher layer stays nil in the
flattened result."
flattened result.
Hidden layers (see `tp-hide-layer') are DISCARDED, mirroring
image-editor flatten semantics: only the visible layers' properties
merge into the flattened result, so flattening can never render what
was hidden. When EVERY layer of a run is hidden, the run's
properties are cleared entirely (bare text), consistent with the
all-hidden rendering of `tp-hide-layer'.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own.
Returns the number of property runs modified, counting like
`tp-delete-layer': every run that had layers to flatten counts, and
0 means no run in the region had any layers."
(pcase-let ((`(,start ,end ,obj ,name)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-object object) 1)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when stack
(let ((merged-props (tp--merge-layer-props
(cl-loop for layer in stack
for i from 0
collect (cons i layer))
(when name (list 'tp-name name)))))
(set-text-properties abs-start abs-end merged-props obj)))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when stack
;; Hidden layers are discarded; an all-hidden run flattens
;; to bare text.
(let* ((visible (seq-remove #'tp--stack-hidden-p stack))
(merged-props
(when visible
(tp--merge-layer-props
(cl-loop for layer in visible
for i from 0
collect (cons i layer))
(when name (list 'tp-name name))))))
(set-text-properties abs-start abs-end merged-props obj)
(when merged-props
(tp--stack-register-layers (list merged-props) obj))
(setq count (1+ count))))))
count)))
(defun tp-add-to-layers (idx-or-layer-name-list start-or-string &optional end-or-plist plist-or-object &rest rest)
"Add/merge properties to specified layers.
@ -599,6 +1022,11 @@ Properties are deeply merged (nested plists are merged, not replaced).
OBJECT defaults to current buffer for region form.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own. The returned string is
that same mutated object.
Returns the modified object (string) or nil for buffer operations."
(let (start end plist obj layer-ids)
(setq layer-ids idx-or-layer-name-list)
@ -648,7 +1076,8 @@ Returns the modified object (string) or nil for buffer operations."
(when stack
(set-text-properties abs-start abs-end
(tp--stack-build-props modified-stack)
obj)))))
obj)
(tp--stack-register-layers modified-stack obj)))))
(if (stringp obj) obj nil)))
(defun tp-add-to-all-layers (start-or-string &optional end-or-plist plist-or-object &rest rest)
@ -671,6 +1100,11 @@ OBJECT defaults to current buffer for region form.
This function uses `tp-add-to-layers' internally, collecting all
layer indices and passing them to add the plist to every layer.
Unlike `tp-set', the string form modifies STRING destructively (in
place) rather than returning a propertized copy: never pass a string
literal or a shared string you do not own. The returned string is
that same mutated object.
Returns the modified object (string) or nil for buffer operations."
(let (start end plist obj)
(cond

34
tp-tests.el
View File

@ -34,6 +34,32 @@ leak between tests regardless of how BODY exits."
,@body)
(tp-layer-reset)))
;; Reactive test variables set with `setq' inside tests. They must be
;; dynamically bound (variable watchers depend on it), so plain
;; `defvar' declarations are used.
(defvar tp-test-first-name nil "Test variable for computed properties.")
(defvar tp-test-last-name nil "Test variable for computed properties.")
(defvar tp-test-full-name nil "Test variable for computed properties.")
(defvar tp-test-dc-color nil "Test variable for data+compute layer.")
(defvar tp-test-dc-first nil "Test variable for data+compute layer.")
(defvar tp-test-dc-last nil "Test variable for data+compute layer.")
(defvar tp-test-dc-full-name nil "Test variable for data+compute layer.")
(defvar tp-test-init-color nil "Test variable for initial values.")
(defvar tp-test-init-name nil "Test variable for initial values.")
(defvar tp-test-init-other nil "Test variable for initial values.")
(defvar tp-test-global-color nil "Test variable for global updates.")
(defvar tp-test-redef-color nil "Test variable for layer re-definition.")
(defvar tp-test-watch-var nil "Test variable for watch callbacks.")
(defvar tp-test-compute-src nil "Test variable for compute source.")
(defvar tp-test-compute-out nil "Test variable for compute output.")
(defvar tp-test-group-color nil "Test variable for layer groups.")
(defvar tp-test-name-part1 nil "Test variable for tp-text updates.")
(defvar tp-test-name-part2 nil "Test variable for tp-text updates.")
(defvar tp-test-batch-color nil "Test variable for batch updates.")
(defvar tp-test-fg nil "Test variable for batch foreground.")
(defvar tp-test-bg nil "Test variable for batch background.")
(defvar tp-test-amount nil "Test variable for transform updates.")
;;; ============================================================
;;; Basic Text Property Functions Tests
;;; ============================================================
@ -863,7 +889,7 @@ nothing and returns the available count."
(tp-set 12 17 '(marker t) str)
(let ((result nil))
(tp--search-do
(lambda (match obj)
(lambda (match _obj)
(push (car match) result))
'marker nil str)
(should (= (length result) 2))
@ -878,7 +904,7 @@ nothing and returns the available count."
(tp-set 13 18 '(marker t))
(let ((result nil))
(tp--search-do
(lambda (match obj)
(lambda (match _obj)
(push (car match) result))
'marker nil nil 1 18)
(should (= (length result) 2))
@ -955,7 +981,7 @@ nothing and returns the available count."
(tp-set 5 8 '(marker t))
(tp-set 9 12 '(marker t))
(let ((positions nil))
(tp-search-map (lambda (txt start end idx)
(tp-search-map (lambda (_txt start end idx)
(push (list start end idx) positions)
(format "[%d]" idx))
'marker nil nil 1 12)
@ -3212,7 +3238,7 @@ text content but different properties, the properties should be updated."
;; Should contain both the plist and symbol
(should (member 'bold (if (listp face-val) face-val (list face-val))))
;; Should have foreground red
(should (or (eq face-val '(:foreground "red"))
(should (or (equal face-val '(:foreground "red"))
(and (listp face-val)
(cl-some (lambda (f)
(and (listp f)

2
tp.el
View File

@ -2,7 +2,7 @@
;; Copyright (C) 2024-2026 Geekinney
;; Version: 0.2.0
;; Version: 0.3.0
;; Keywords: convenience text-properties
;; Author: Geekinney (kinneyzhang666@gmail.com)
;; Package-Requires: ((emacs "28.1") (dash "2.19.1"))