diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index e590ce1..eed8a1f 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -20,32 +20,30 @@ jobs:
with:
version: ${{ matrix.emacs_version }}
- - name: Install dash from GNU ELPA
+ - name: Install package-lint from MELPA
run: |
emacs -Q --batch --eval "(progn \
(require 'package) \
(setq package-user-dir (expand-file-name \".elpa\")) \
- (add-to-list 'package-archives '(\"gnu\" . \"https://elpa.gnu.org/packages/\")) \
+ (add-to-list 'package-archives '(\"melpa\" . \"https://melpa.org/packages/\")) \
(package-initialize) \
(package-refresh-contents) \
- (package-install 'dash))"
- # Trailing slash: match only the package directory, not the
- # adjacent dash-N.N.N.signed marker GNU ELPA leaves behind.
- echo "LOAD_EXTRA=-L $(ls -d "$PWD"/.elpa/dash-*/ | head -1)" >> "$GITHUB_ENV"
+ (package-install 'package-lint))"
+ echo "PACKAGE_LINT_LOAD=-L $(ls -d "$PWD"/.elpa/package-lint-*/ | head -1)" >> "$GITHUB_ENV"
- name: Byte-compile (warnings are errors)
- run: make compile-all WERROR=t LOAD_EXTRA="$LOAD_EXTRA"
+ run: make compile-all WERROR=t
- name: ERT suite
- run: make test LOAD_EXTRA="$LOAD_EXTRA"
+ run: make test
- name: ERT suite (shuffled order)
- run: make test-shuffled LOAD_EXTRA="$LOAD_EXTRA"
+ run: make test-shuffled SHUFFLE_SEED=20260806
- name: README doctests
run: |
set -o pipefail
- make doctest LOAD_EXTRA="$LOAD_EXTRA" 2>&1 | tee doctest.log || {
+ make doctest 2>&1 | tee doctest.log || {
# Surface failing assertions as annotations (job logs are
# not readable anonymously; annotations are).
grep -E '^(FAIL| expected:| got:)' doctest.log | head -30 \
@@ -54,3 +52,12 @@ jobs:
| while IFS= read -r l; do echo "::error::${l}"; done
exit 1
}
+
+ - name: Check documentation
+ run: make checkdoc
+
+ - name: Check package metadata
+ run: make package-lint LOAD_EXTRA="$PACKAGE_LINT_LOAD"
+
+ - name: Check diff whitespace
+ run: make diff-check
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 88acee9..f55dd8a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,88 +2,34 @@
All notable changes to the tp library are documented here.
-## Unreleased
+## 1.0.0 (Unreleased)
### Added
-- Retained content surfaces now support explicitly retained logical objects and `tp-object-attach-fragment`, so one stable object can own several disjoint marker-backed output fragments without putting runtime handles or positions into the pure plan. `tp-object-mounts` exposes defensive numeric range/tag snapshots through an object-keyed side index.
-- `tp-transaction-participate` lets a client promote rollback-capable opaque side state after all affected surfaces publish but before source values commit. Participant keys are unique per outer transaction, failure rolls participants back in reverse publication order, and observers still run only after the transaction exits.
-- `tp-propertize`, `tp-apply`, and `tp-watch` now provide simple one-shot string, one-shot buffer-range, and reactive existing-text entry points over the same schema/cascade/projector and retained properties-surface core.
-- TP 1.0 retained surfaces now provide defensive pure plans, prepare-scoped object identity, keyed/positional reconciliation, `content` and `properties` capabilities, marker-backed range anchors, same-surface overlapping property contributions, compare-before-write conflicts and explicit rebase, common-prefix/suffix text edits, property-run diffs, side indexes, opaque client state, generic reports, lifecycle cleanup, and atomic multi-buffer publication with exact rollback. Pure materialization uses the same plan semantics without leaving live handles or subscriptions.
-- TP 1.0 signals and bindings now form an exact source→binding and binding→binding dependency graph with conditional rewiring, memoized equality cutoffs, transaction-local candidate signal values, deduplicated topological flushing, nested-write stabilization, rollback, cycle paths, owner disposal, buffer-scoped sources, variable adapters, and public scheduler counters. The legacy layer scanner remains isolated only until the retained-surface cutover.
-- The first TP 1.0 runtime slice: `tp-style.el` provides atomic namespaced property schemas, structured subject selectors and combinators, deterministic origin/importance/layer/specificity/scope/source-order cascade, property-specific inheritance, tagged CSS-wide values, custom-property fallback/cycle handling, explicit `tp-computed` value sources, named declarations, provenance, and final Emacs-property projection. Ordinary function values remain literal.
-- Internal Stage 2 canonical façade records and dataflow:
- `tp--native-range`, `tp--presence`, `tp--request`, `tp--match`,
- and `tp--result`. Public entry points and historical return shapes
- remain compatible.
-- Stage 3 text-only native façade in `tp-query.el`:
- `tp-lookup-result`, `tp-lookup`, `tp-property-change`,
- `tp-property-any`, `tp-property-not-all`, and
- `tp-with-mutation-policy`.
-- Stage 4 managed lifecycle APIs: `tp-attach-managed-layers`,
- `tp-detach-managed-layers`, `tp-managed-layer-diagnostics`,
- `tp-managed-buffer-diagnostics`, `tp-managed-diagnostics`, and
- `tp-layer-transaction`.
-- Stage 5 overlay-aware lookup modes for `tp-lookup`: `:char` and
- `:char-source` report Emacs character-property values and the
- winning overlay identity when an overlay wins.
-- `docs/API-SEMANTICS.md` centralizes the current object/coordinate,
- mutation, presence/nil, search-result, layer-ownership, `tp-text`,
- error, and hidden-stack conflict contracts.
-- `tp-any-value`, a unique public sentinel for property-search wildcard
- matching when later positional arguments also need to be supplied.
-- `tp-unresolved-layer` and `tp-layer-conflict` error types.
-- `tp-reactive-observer-errors`, a newest-first structured record of
- isolated watcher callback failures.
-
-### Fixed
-
-- Initial `tp-text` rendering now preserves every embedded property
- interval for strings and buffers instead of spreading position-zero
- properties across the replacement.
-- `tp-text` application preserves the caller's `tp-set`, `tp-reset`,
- or `tp-add` write semantics even when replacement text is unchanged.
-- Explicit nil properties override embedded `tp-text` values.
-- Non-parameterized layer redefinition refreshes managed regions with
- old/new ownership reconciliation: removed keys disappear, new keys
- replace them, and unrelated or externally changed values survive.
-- Search APIs distinguish omitted VALUE (any directly present value)
- from explicit nil (a present nil value), with one presence-aware run
- scanner shared by strings and buffers.
-- Removing the last nested sub-property removes the empty parent key
- consistently for strings and buffers.
-- Stack NOERROR catches only unresolved layer specifications; errors
- from layer bodies and internal operations propagate.
-- When hidden-layer full-stack storage detects an external direct
- property edit, stack decoding now signals `tp-layer-conflict` before
- any managed write instead of silently discarding the external value.
-- Buffer transaction rollback tracks its live range with markers, so
- insertions and deletions inside the range are removed or restored
- together with the original text-property snapshot.
+- A standalone retained surface runtime with pure defensive plans, prepare-scoped stable objects, keyed/positional reconciliation, content and properties capabilities, marker-backed range anchors, object/mount indexes, scoped updates, opaque client state, generic reports, and lifecycle cleanup.
+- Exact signal-to-binding and binding-to-binding dependency tracking with conditional rewiring, equality cutoffs, batched transactions, nested-write stabilization, owner disposal, buffer-scoped sources, variable adapters, cycle paths, and public structural counters.
+- Atomic single- and multi-surface publication with candidate source values, prepare-all/publish-all ordering, explicit property journals, rollback-capable transaction participants, observer isolation, and authoritative kill-buffer cleanup.
+- Native property policies and contribution composition with explicit nil/absence, normalization, validation, equality, merge, projection, named direct styles, and explicit `tp-computed` value sources.
+- `tp-propertize`, `tp-apply`, and `tp-watch` as the one-shot string, one-shot buffer-range, and reactive existing-text conveniences over the same direct property/surface core.
+- Retained logical objects with `tp-object-retain` and `tp-object-attach-fragment`, allowing one object to own multiple disjoint physical fragments without placing handles or positions in plans.
+- Standalone examples for static properties, reactive status decoration, retained dashboards, and editable diagnostics.
### Changed
-- Transform and compute failures now propagate as business-output
- errors. A transform returning a non-string also signals. Watcher
- failures remain isolated observers, but are recorded structurally
- while the managed update continues.
-- Managed layer entries now store `tp-meta` in authoritative
- `tp-layers` storage, including parameterized args and definition
- versions. Direct rendered properties and public stack queries strip
- `tp-meta`; historical returns remain unchanged.
-- Parameterized mounted layer entries refresh from stored args after
- redefinition.
-- Insert/copy/yank/stickiness/narrowing/indirect-buffer behavior is
- now documented as direct Emacs delegation with no tp wrapper.
-- Overlay creation, movement, deletion, priority management, and
- lifecycle remain native Emacs responsibilities; tp only reports
- overlay-aware lookup results.
-- `tp-with-mutation-policy` accepts only ordinary+respect,
- ordinary+inhibit, and silent+inhibit; silent+respect is rejected.
-- Theme enable/disable events now increment theme generation and expose
- conservative refresh diagnostics. Reproducible benchmark evidence is
- recorded in `docs/BENCHMARKS.md`; timings are advisory baseline data,
- not release thresholds.
+- `define-tp` and `define-tps` now define static or parameterized direct declaration recipes. Applying a recipe produces ordinary properties and never publishes runtime identity metadata.
+- TP is no longer a CSS engine. Selector, stylesheet, specificity, origin/importance, cascade layer, CSS-wide value, custom property, winner, and provenance behavior belongs to the independent ECSS package.
+- Function-valued properties are always literal. Only values wrapped by `tp-computed` execute and participate in dependency collection.
+- Runtime identity and provenance live exclusively in side state. Normal updates follow source to binding to object to marker-backed mount without scanning buffers or displayed text.
+- Package documentation, API semantics, architecture, doctests, and tests now describe the single TP 1.0 runtime rather than the transitional 0.3 managed model.
+
+### Removed
+
+- `tp-render.el`, `tp-stack.el`, the scan-driven renderer, layer-to-buffer registry, and duplicate managed transaction path.
+- Managed stack mutation, attach/detach, diagnostics, and lifecycle APIs that depended on inline stack storage.
+- `tp-text`, `$variable` declaration syntax, automatic layer refresh, and character-level `tp-name`/`tp-layers`/`tp-meta` runtime storage.
+- TP-owned CSS selector/stylesheet/cascade APIs and compatibility aliases.
+- The unused Dash runtime dependency.
+- Unused global theme lifecycle advice and managed-refresh bookkeeping from the deleted renderer.
## 0.3.0 (2026-07-27)
diff --git a/Makefile b/Makefile
index e77193b..cd9631f 100644
--- a/Makefile
+++ b/Makefile
@@ -7,25 +7,28 @@
# make benchmark # run reproducible correctness-first benchmarks
# make compile # byte-compile the library modules
# make compile-all # byte-compile modules + tests + dev scripts
+# make checkdoc # validate source docstrings
+# make package-lint # validate package metadata and public surface
+# make diff-check # validate whitespace in the current diff
# make clean # remove compiled files
#
# WERROR=t turns byte-compile warnings into errors (used in CI).
-# If dash.el is not on the default load-path, point LOAD_EXTRA at it:
-# make test LOAD_EXTRA="-L ~/.emacs.d/elpa/dash-20240510.1327"
+# LOAD_EXTRA can add optional development-tool load paths such as package-lint.
EMACS ?= emacs
LOAD_EXTRA ?=
WERROR ?= nil
TEST_DIR = tests
-LOADPATH = -L . -L $(TEST_DIR) $(LOAD_EXTRA)
+LOADPATH = -L . -L $(TEST_DIR) -L examples $(LOAD_EXTRA)
SRC = tp-core.el tp-style.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.el \
- tp-render.el tp-stack.el tp-query.el tp-palette.el tp-builtins.el tp.el
+ tp-query.el tp-palette.el tp-builtins.el tp.el
TESTS = $(wildcard $(TEST_DIR)/*-tests.el)
TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el
-DEV = $(TEST_SUPPORT) tp-benchmark.el
+EXAMPLES = $(wildcard examples/*.el)
+DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el
-.PHONY: test test-shuffled doctest benchmark compile compile-all clean
+.PHONY: test test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean
test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
@@ -51,5 +54,14 @@ compile-all: clean
--eval "(setq byte-compile-error-on-warn $(WERROR))" \
-f batch-byte-compile $(SRC) $(TESTS) $(DEV)
+checkdoc:
+ $(EMACS) -Q --batch $(LOADPATH) --eval '(progn (require (quote cl-lib)) (require (quote checkdoc)) (let (warnings) (cl-letf (((symbol-function (quote display-warning)) (lambda (type message &optional _level _buffer-name) (push (format "%s: %s" type message) warnings)))) (dolist (directory (list "." "examples")) (dolist (file (directory-files directory t "\\.el$$")) (checkdoc-file file)))) (when warnings (dolist (warning (nreverse warnings)) (princ warning) (terpri)) (kill-emacs 1))))'
+
+package-lint:
+ $(EMACS) -Q --batch $(LOADPATH) --eval '(progn (require (quote package-lint)) (let ((package-lint-main-file (expand-file-name "tp.el")) (command-line-args-left (mapcar (lambda (file) (expand-file-name (symbol-name file))) (quote ($(SRC)))))) (package-lint-batch-and-exit)))'
+
+diff-check:
+ git diff --check
+
clean:
- rm -f *.elc $(TEST_DIR)/*.elc
+ rm -f *.elc $(TEST_DIR)/*.elc examples/*.elc
diff --git a/README.md b/README.md
index 1208d97..dc612b9 100644
--- a/README.md
+++ b/README.md
@@ -1,4429 +1,201 @@
-# tp.el - Text Properties Library for Emacs
+# TP
-
- A powerful text properties manipulation library with an innovative property layer system
-
+TP 1.0 is a standalone retained/reactive text runtime for Emacs. It projects declarative properties, reactive data, and stable text objects onto strings and buffers while owning text-property composition, exact dependency tracking, retained identity, marker-backed mounts, diffing, transactions, rollback, and final buffer publication.
-
- Features •
- Installation •
- Quick Start •
- API Reference •
- Property Layer System •
- Reactive Text Properties •
- 中文文档
-
+TP does not depend on Ebox or ECSS. It does not implement CSS selectors, stylesheets, specificity, cascade winners, Box, Flex, Grid, measurement, or layout. A CSS consumer may compute final declarations with ECSS and publish them through TP, but TP itself only understands Emacs text properties and generic retained text surfaces.
----
-
-## Table of Contents
-
-- [Quick Start](#quick-start)
-- [Overview](#overview)
- - [Core Innovations](#core-innovations)
-- [Features](#features)
- - [Unified API Parameter Conventions](#unified-api-parameter-conventions)
- - [Three Property Operation Semantics](#three-property-operation-semantics)
- - [Fine-grained Sub-property Operations](#fine-grained-sub-property-operations)
- - [Innovative Property Layer System](#innovative-property-layer-system)
- - [Pattern Matching & Batch Operations](#pattern-matching--batch-operations)
- - [Reactive Text Properties](#-reactive-text-properties)
- - [Enhanced Search & Navigation](#enhanced-search--navigation)
-- [Requirements](#requirements)
-- [Installation](#installation)
-- [API Reference](#api-reference)
- - [API Quick Reference](#api-quick-reference)
- - [Core Property Functions](#core-property-functions)
- - [tp-set](#tp-set---set-text-properties)
- - [tp-reset](#tp-reset---replace-all-properties)
- - [tp-add](#tp-add---addmerge-properties)
- - [tp-get](#tp-get---get-property-value)
- - [tp-at](#tp-at---get-property-at-position)
- - [tp-member](#tp-member---property-membership-at-position)
- - [tp-remove](#tp-remove---remove-property)
- - [tp-clear](#tp-clear---clear-all-properties)
- - [Pattern Matching Functions](#pattern-matching-functions)
- - [tp-match-set](#tp-match-set---match-string)
- - [tp-match-reset](#tp-match-reset---match-and-reset)
- - [tp-match-add](#tp-match-add---match-and-add)
- - [tp-regexp-set](#tp-regexp-set---match-regexp)
- - [tp-regexp-reset](#tp-regexp-reset---regexp-and-reset)
- - [tp-regexp-add](#tp-regexp-add---regexp-and-add)
- - [Search & Navigation Functions](#search--navigation-functions)
- - [tp-search-forward / tp-search-backward](#tp-search-forward--tp-search-backward)
- - [tp-forward / tp-backward](#tp-forward--tp-backward)
- - [tp-forward-do / tp-backward-do](#tp-forward-do--tp-backward-do)
- - [tp-search](#tp-search---search-all-matches)
- - [tp-search-map](#tp-search-map---apply-function-to-matched-text)
- - [Native Text Property Compatibility](#native-text-property-compatibility)
- - [tp-lookup-result / tp-lookup](#tp-lookup-result--tp-lookup)
- - [tp-property-change](#tp-property-change)
- - [tp-property-any / tp-property-not-all](#tp-property-any--tp-property-not-all)
- - [tp-with-mutation-policy](#tp-with-mutation-policy)
-- [The Property Layer System](#the-property-layer-system)
- - [Custom Text Properties](#custom-text-properties)
- - [Text Property Layers](#text-property-layers)
- - [Property Layer Concept](#property-layer-concept)
- - [Property Layer Definition](#property-layer-definition)
- - [define-tp / define-tps](#define-tp--define-tps---define-custom-text-properties)
- - [tp-layer-props / tp-group-props](#tp-layer-props--tp-group-props)
- - [tp-layer-props-with-args / tp-group-props-with-args / tp-layer-arglist](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist)
- - [tp-describe-layer](#tp-describe-layer---describe-a-layer)
- - [tp-undefine-layer / tp-undefine-group](#tp-undefine-layer--tp-undefine-group)
- - [tp-layer-reset](#tp-layer-reset)
- - [tp-reactive-reset](#tp-reactive-reset)
- - [Property Layer Placement](#property-layer-placement)
- - [tp-put-layer](#tp-put-layer---set-layer-at-index)
- - [tp-push-layer](#tp-push-layer---push-layer-to-top)
- - [Property Layer Deletion](#property-layer-deletion)
- - [tp-delete-layer](#tp-delete-layer---delete-layer-by-nameindex)
- - [tp-pop-layer](#tp-pop-layer---pop-top-layer)
- - [Property Layer Movement](#property-layer-movement)
- - [tp-move-layer](#tp-move-layer---move-layer-to-position)
- - [tp-raise-layer](#tp-raise-layer---move-layer-updown)
- - [tp-lower-layer](#tp-lower-layer---mirror-of-tp-raise-layer)
- - [tp-rotate-layer](#tp-rotate-layer---cycle-layers)
- - [tp-pin-layer](#tp-pin-layer---pin-layer-to-top)
- - [tp-switch-layer](#tp-switch-layer---switch-two-layers)
- - [Property Layer Visibility](#property-layer-visibility)
- - [tp-hide-layer / tp-show-layer](#tp-hide-layer--tp-show-layer---hide-and-show-layers)
- - [Managed Layer Lifecycle](#managed-layer-lifecycle)
- - [tp-attach-managed-layers / tp-detach-managed-layers](#tp-attach-managed-layers--tp-detach-managed-layers)
- - [tp-managed-layer-diagnostics / tp-managed-buffer-diagnostics / tp-managed-diagnostics](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics)
- - [tp-layer-transaction](#tp-layer-transaction)
- - [Property Layer Merging](#property-layer-merging)
- - [tp-merge-layers](#tp-merge-layers---merge-multiple-layers)
- - [tp-flatten-layers](#tp-flatten-layers---flatten-all-layers)
- - [Property Layer Query Functions](#property-layer-query-functions)
- - [tp-layer-list](#tp-layer-list---list-all-layers)
- - [tp-layer-count](#tp-layer-count)
- - [tp-layer-exists-p](#tp-layer-exists-p)
- - [tp-layer-top](#tp-layer-top)
- - [tp-layer-stack-at](#tp-layer-stack-at---full-stack-at-a-position)
- - [tp-add-to-layers](#tp-add-to-layers---add-properties-to-specific-layers)
- - [tp-add-to-all-layers](#tp-add-to-all-layers---add-properties-to-all-layers)
- - [Utility Functions](#utility-functions)
- - [tp-intervals](#tp-intervals---get-text-property-intervals)
- - [tp-intervals-map](#tp-intervals-map---apply-function-to-intervals)
- - [tp-plist](#tp-plist---get-all-properties-in-region)
- - [tp-empty-p](#tp-empty-p---check-if-object-has-properties)
- - [tp-region-layer-props](#tp-region-layer-props---get-layer-properties-in-region)
- - [tp-with-current-buffer / tp-pop-to-buffer / tp-switch-to-buffer](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer)
- - [Color Palette System](#color-palette-system)
-- [Reactive Text Properties](#reactive-text-properties)
- - [Core Concept](#core-concept)
- - [How It Works](#how-it-works)
- - [Defining Reactive Layers](#defining-reactive-layers)
- - [:data - Additional Reactive State](#data---additional-reactive-state)
- - [:compute - Computed Properties](#compute---computed-properties)
- - [:watch - Side Effect Callbacks](#watch---side-effect-callbacks)
- - [:transform - Value Transformation](#transform---value-transformation)
- - [Anonymous Reactive Layers](#anonymous-reactive-layers)
- - [Layer Name Resolution in APIs](#layer-name-resolution-in-apis)
- - [Reactive Layer Groups](#reactive-layer-groups)
- - [Batched Updates](#batched-updates)
- - [Layer-Buffer Registry & Lifecycle](#layer-buffer-registry--lifecycle)
- - [Debug Mode](#debug-mode)
- - [Resetting Reactive State](#resetting-reactive-state)
- - [Complete Example: Theme-Aware Text](#complete-example-theme-aware-text)
-- [Practical Examples](#practical-examples)
- - [Syntax Highlighting with Multiple Layers](#syntax-highlighting-with-multiple-layers)
- - [Status Indicator](#status-indicator)
- - [Temporary Highlights](#temporary-highlights)
-- [License](#license)
-- [Contributing](#contributing)
-
----
-
-## Quick Start
-
-```elisp
-;; Install: clone the repository, add it to your load-path, and require
-(add-to-list 'load-path "/path/to/tp")
-(require 'tp)
-
-;; Set properties with one unified API (returns a new propertized string)
-(tp-set "hello" 'face 'bold)
-;; => #("hello" 0 5 (face bold))
-
-;; Stack property layers on a buffer region
-(define-tp spotlight () '(face (:background "yellow")))
-(with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 6 'spotlight)
- (tp-layer-top 1 6))
-;; => spotlight
-
-;; Reactive: text properties follow a variable
-(defvar accent-color "red")
-(define-tp accent ()
- :props '(face (:foreground $accent-color)))
-(with-temp-buffer
- (insert "Hello")
- (tp-push-layer 1 6 'accent)
- (setq accent-color "blue") ; text updates automatically!
- (tp-at 1 'face))
-;; => (:foreground "blue")
-```
-
----
-
-## Overview
-
-**tp.el** is a library that comprehensively enhances Emacs text property manipulation. It is not just a simple wrapper around native text property APIs (like `put-text-property`, `get-text-property`), but provides many **functional extensions that native functions do not have**. tp.el innovates in the following areas:
-
-Since 0.2.0 the library is organized as a family of layered modules (`tp-core`, `tp-style`, `tp-reactive`, `tp-layer`, `tp-ops`, `tp-search`, `tp-render`, `tp-stack`, `tp-query`, `tp-palette`, `tp-builtins`) behind the umbrella file `tp.el` — `(require 'tp)` still loads everything, so nothing changes for users. See [Installation](#installation) for the module map.
-
-The TP 1.0 migration has begun with a pure schema-driven cascade kernel. `tp-style.el` adds namespaced property schemas, structured selectors, origin/importance/layer/specificity/scope/source-order precedence, property-specific inheritance, tagged CSS-wide values, inherited custom properties, explicit `tp-computed` sources, projection to Emacs properties, and read-only winner provenance. `tp-stylesheet-create` gives each independent consumer its own rule, layer, and source-order domain instead of forcing unrelated packages through one process-global stylesheet. It deliberately owns no buffers, markers, mounts, or reactive subscriptions; retained surfaces will build on this kernel in later migration phases.
-
-`tp-reactive.el` now also provides the TP 1.0 exact dependency runtime: signals invalidate only their subscribed bindings, binding reads form memoized binding→binding edges, conditional computations replace obsolete dependencies, and the outermost `tp-with-transaction` flushes each dirty binding once. Candidate signal writes and binding values/dependencies commit together; compute, cycle, publication, or transaction-participant failures roll them back. `tp-transaction-participate` lets a client promote opaque side state after surfaces publish while supplying its inverse for the same rollback boundary. Global and buffer-local variable adapters reuse this graph without making text properties or buffer scans the runtime database.
-
-`tp-surface.el` completes the retained publication path from object identity to marker-backed mounts and buffers. A producer receives a short-lived prepare context, ensures candidate objects before computing output, and returns a defensive pure plan plus optional opaque client state. A logical object may be retained without visible output or attached to several disjoint plan fragments; the plan still contains no runtime handle or position, while `tp-object-mounts` resolves its current numeric ranges directly from side state. TP validates the whole candidate before publication, applies common-prefix/suffix text edits and property-run diffs, swaps plans/indexes/client state at one revision, and rolls every affected buffer and signal back together on failure. `tp-surface-update-scoped` authorizes one transaction to publish only the mounted ranges of selected retained objects, including disjoint mounts and properties-only anchors; a candidate that changes output elsewhere fails before publication unless the caller explicitly requests a root fallback. `content` owns a disjoint text span; `properties` decorates attached host ranges, detects external property conflicts, and requires explicit rebase. Overlap is composable inside one surface and rejected across independent surfaces so ownership cannot silently split.
-
-Ordinary callers can use the same core without manually constructing runtime objects: `tp-propertize` returns a styled string copy, `tp-apply` applies declarations once to an existing buffer range, and `tp-watch` keeps an existing range's properties synchronized with signals. These calls accept native Emacs property declarations; callbacks such as `help-echo` remain literal values, while only explicitly wrapped `tp-computed` sources are evaluated by the cascade.
-
-### Core Innovations
-
-1. **Unified API Parameter Conventions**: All functions support multiple flexible calling patterns, working seamlessly with both strings and buffers
-2. **Fine-grained Sub-property Operations**: Support path-style access, modification, and deep merging of nested properties
-3. **Innovative Property Layer System**: Stack and manage multiple sets of properties on the same text region with layered control
-4. **🆕 Reactive Text Properties**: Automatically update text properties when variable values change - a groundbreaking feature inspired by modern reactive UI frameworks
-5. **Pattern Matching Batch Operations**: Batch apply properties via string or regular expression matching
-6. **Enhanced Search & Navigation**: Rich property search and traversal functionality
-
-## Features
-
-### Unified API Parameter Conventions
-
-Native Emacs APIs have different functions and parameter orders for strings and buffers. tp.el unifies all of this:
-
-- ✅ **Three Calling Conventions**: All core functions (`tp-set`, `tp-get`, `tp-remove`, etc.) support three flexible calling patterns:
- ```elisp
- ;; 1. Current buffer
- (tp-set START END '(face bold))
- ;; 2. Specific buffer or string
- (tp-set START END '(face bold) OBJECT)
- ;; 3. Entire string (flat properties or layer name)
- (tp-set STRING 'face 'bold 'help-echo "tip")
- (tp-set STRING 'layer-name)
- ```
-- ✅ **Unified Object Support**: The same function works with both strings and buffers, no need to remember different APIs
-
-**One rule to remember**: when the first argument is a **string**, the call
-operates on that whole string; when it is a **number**, the call operates on
-the `[START, END)` region of OBJECT — and OBJECT always comes last (nil means
-the current buffer). Every core and layer-stack function follows this rule.
-
-The match/search family (`tp-match-*`, `tp-regexp-*`, `tp-search-map`,
-`tp-forward-do`/`tp-backward-do`) follows a deliberate **second convention**:
-PATTERN (or FUNCTION) and PLIST come first, then OBJECT, then the optional
-START/END bounds. Operating on the whole object is these functions' common
-case, so OBJECT sits before the range instead of after it.
-
-**Return value conventions** (as of 0.3.0):
-
-| Family | Return value |
-|---|---|
-| `tp-set` / `tp-reset` / `tp-add` | `(START . END)` for buffer/region forms; a **new** string for whole-string forms |
-| `tp-remove` | nil for buffer forms; a **new** string for whole-string forms |
-| `tp-clear` | nil |
-| `tp-match-*` / `tp-regexp-*` | list of `(START . END)` matches for buffers; a **new** string for strings |
-| Stack mutators (delete/pop/move/raise/lower/rotate/pin/switch/hide/show/merge/flatten) | the number of property runs modified (0 = nothing matched) |
-| `tp-put-layer` / `tp-push-layer` | OBJECT when given (the string itself in string forms), else `(START . END)` |
-| `tp-add-to-layers` / `tp-add-to-all-layers` | the string itself (mutated **in place**) for string forms; nil for buffers |
-
-The precise object, mutation, nil/presence, search, and managed-layer
-contracts are centralized in
-[docs/API-SEMANTICS.md](docs/API-SEMANTICS.md). “Unified” means one
-high-level vocabulary; a few documented string/buffer return differences
-remain for compatibility.
-
-**Namespace map**: `tp-layer-NAME` functions taking a *layer name* argument
-(`tp-layer-props`, `tp-layer-arglist`, ...) query the layer **registry**
-(definitions); the ones taking *position* arguments — START END
-(`tp-layer-list`, `tp-layer-count`, `tp-layer-top`, ...) or a single POS
-(`tp-layer-stack-at`) — query the layer **stack on actual text**.
-
-**Naming conventions**: `tp-define-layer` / `tp-define-group` /
-`tp-define-palette` are the prefix-conforming canonical names going forward
-(discoverable via `C-h f tp-...`); `define-tp` / `define-tps` /
-`define-tp-group` / `define-tp-palette` are permanent aliases that will never
-be removed (this README's examples still use the historical names).
-`tp-search-forward` / `tp-search-backward` are deprecated since 0.3.0 — see
-[Search & Navigation](#tp-search-forward--tp-search-backward).
-
-### Three Property Operation Semantics
-
-Native APIs only have simple set and get. tp.el provides three clear operation semantics:
-
-- ✅ **`tp-reset`**: Complete replacement - clears all existing properties, sets new ones
-- ✅ **`tp-set`**: Partial replacement - only replaces specified properties, preserves others
-- ✅ **`tp-add`**: Deep merge - intelligently merges nested properties instead of simple overwrite
-
-```elisp
-;; Deep merge example
-(tp-set 1 10 '(face (:foreground "red")))
-(tp-add 1 10 '(face (:background "blue")))
-;; Result: face is (:foreground "red" :background "blue")
-;; Native API would completely overwrite, but tp-add merges intelligently
-```
-
-### Fine-grained Sub-property Operations
-
-**This is functionality that native APIs completely lack**. tp.el supports fine-grained reading, modification, and deletion of nested properties:
-
-- ✅ **Path-style Access**: Access deeply nested property values through path syntax
- ```elisp
- ;; Get nested properties (tp-get returns (START END VALUE) intervals)
- (tp-get str 'face :underline :style) ; => ((0 5 wave))
- (tp-at 5 '(face :box :color)) ; => "blue"
-
- ;; Get multiple nested keys
- (tp-get str 'face :underline '(:color :style))
- ;; => ((0 5 (:color "green" :style wave)))
- ```
-- ✅ **Sub-property Deletion**: Precisely remove specific keys from nested properties
- ```elisp
- ;; Only delete :style from :underline, preserve :color
- (tp-remove 1 10 '(face :underline :style))
- ```
-- ✅ **Deep Merge**: `tp-add` recursively merges nested plist structures
-- ✅ **Smart Face Merging**: Symbol faces are automatically prepended to face lists, plist faces are deep merged
-- ✅ **Automatic Duplicate Property Merging in Single Call**: When the same property (e.g., `face`) is specified multiple times in a single `tp-set`/`tp-add`/`tp-reset` call, they are automatically merged
-
-```elisp
-;; Merge multiple faces in a single call
-(tp-set "emacs"
- 'face 'bold
- 'face '(:background "green")
- 'face '(:foreground "red"))
-;; Result: face is ((:foreground "red") (:background "green") bold)
-;; (entries stack into one face list, most recent first)
-
-;; Later values override earlier ones for the same sub-property
-(tp-set "emacs"
- 'face '(:foreground "red")
- 'face '(:foreground "yellow"))
-;; Result: foreground is "yellow"
-
-;; Use with tp-palette layer
-(tp-set "emacs"
- 'tp-palette 'info
- 'face '(:foreground "red"))
-;; Result: tp-palette's face is merged with (:foreground "red")
-```
-
-### Innovative Property Layer System
-
-**This is tp.el's most innovative feature**, completely unsupported by native Emacs. The property layer system allows stacking multiple sets of properties on the same text region:
-
-- ✅ **Property Layer Stack Concept**: Multiple property layers stack like a stack, only the top layer is visible, lower layers are preserved
-- ✅ **Property Layer Definition & Reuse**: Define reusable property layers and layer groups via `define-tp` and `define-tps`
-- ✅ **Rich Property Layer Operations**:
- - Placement: `tp-put-layer` (specific position), `tp-push-layer` (top)
- - Deletion: `tp-delete-layer` (by name/index), `tp-pop-layer` (top layer)
- - Movement: `tp-raise-layer` / `tp-lower-layer` (up/down), `tp-rotate-layer` (rotate), `tp-pin-layer` (one-shot move to top), `tp-switch-layer` (swap)
- - Visibility: `tp-hide-layer` / `tp-show-layer` (hide a layer without removing it)
- - Merging: `tp-merge-layers` (merge specified layers), `tp-flatten-layers` (flatten all layers)
-- ✅ **Property Layer Queries**: `tp-layer-list`, `tp-layer-count`, `tp-layer-exists-p`, `tp-layer-top`, `tp-layer-stack-at`
-
-```elisp
-;; Property layer usage example
-(define-tp highlight () '(face (:background "yellow")))
-(define-tp error () '(face (:foreground "red")))
-
-;; Stack multiple property layers
-(tp-push-layer 1 10 'highlight)
-(tp-push-layer 1 10 'error) ; error is now visible
-
-;; Rotate display
-(tp-rotate-layer 1 10) ; highlight is now visible
-```
-
-### Pattern Matching & Batch Operations
-
-Native APIs require manual searching and looping. tp.el provides convenient pattern matching functionality:
-
-- ✅ **String Matching**: `tp-match-set`, `tp-match-reset`, `tp-match-add`
-- ✅ **Regexp Matching**: `tp-regexp-set`, `tp-regexp-reset`, `tp-regexp-add`
-- ✅ **Three Semantic Variants**: Each match type supports set/reset/add operation semantics
-
-```elisp
-;; Highlight all TODOs
-(tp-match-set "TODO" '(face warning))
-
-;; Regexp match all numbers
-(tp-regexp-set "[0-9]+" '(face font-lock-number-face))
-
-;; Add properties with deep merge
-(tp-match-add "TODO" '(face (:underline t)))
-```
-
-### 🆕 Reactive Text Properties
-
-**This is tp.el's most innovative new feature** - reactive text properties automatically update when variable values change. Inspired by modern reactive UI frameworks like Vue.js, this feature brings reactive programming to Emacs text properties:
-
-- ✅ **Reactive Variables**: Use `$`-prefixed symbols (like `$my-color`) in property definitions - they automatically resolve to variable values
-- ✅ **Automatic Updates**: When a reactive variable changes, all text regions using that variable are automatically updated
-- ✅ **:data for Additional State**: Define additional reactive variables that aren't directly used in properties but can trigger updates
-- ✅ **:compute for Derived Values**: Create computed properties that derive their values from other reactive variables (like Vue's computed properties)
-- ✅ **:watch for Side Effects**: Execute callbacks when reactive variables change (like Vue's watch)
-- ✅ **Targeted Updates (0.3.0)**: a layer→buffer registry means updates visit only the buffers showing the affected layer, `tp-text` re-renders edit only the differing span (point and markers stay put), and `tp-reactive-track-buffer` / `tp-gc-anonymous-layers` manage the layer lifecycle — see [Layer-Buffer Registry & Lifecycle](#layer-buffer-registry--lifecycle)
-
-```elisp
-;; Define a layer with reactive properties
-(defvar my-color "red") ;; Reactive variable
-
-(define-tp my-highlight ()
- :props '(face (:foreground $my-color)))
-
-;; Apply the layer
-(tp-push-layer 1 10 'my-highlight)
-
-;; Later, just change the variable - text updates automatically!
-(setq my-color "blue") ;; All text with my-highlight layer updates to blue!
-
-;; Advanced example with :data, :compute, and :watch
-;; (note: ARGLIST () is mandatory, and the keyword values are quoted)
-(define-tp full-name-layer ()
- :props '(help-echo $full-name face (:foreground $name-color))
- :data '((first-name . "John") (last-name . "Doe") (name-color . "purple"))
- :compute '((full-name (lambda () (concat first-name " " last-name))))
- :watch '((first-name (lambda (new old layer)
- (message "Name changed from %s to %s" old new)))))
-```
-
-### Enhanced Search & Navigation
-
-- ✅ **Range Search**: `tp-search` returns a list of all matching intervals
-- ✅ **N-times Search**: `tp-forward`/`tp-backward` support searching forward/backward N times, with optional PREDICATE matching and NOT-CURRENT
-- ✅ **Search and Execute**: `tp-forward-do`/`tp-backward-do` search N times and apply a function at the Nth match
-- ✅ **Batch Transform**: `tp-search-map` applies transformation function to all matches
-
-```elisp
-;; Search all markers
-(tp-search my-string 'marker) ; => ((0 5 t) (12 17 t))
-
-;; Upcase all marker text
-(tp-search-map #'upcase 'marker tp-any-value my-string)
-```
+Chinese documentation: [README_CN.md](README_CN.md).
## Requirements
-- **Emacs 28.1+** (uses `object-intervals` function)
-- **dash.el 2.19.1+** (list manipulation utilities)
-
-## Installation
-
-The library is the `tp-*.el` module family plus the umbrella file `tp.el`.
-Installing means putting the directory on your `load-path` and requiring the
-umbrella, which loads every module:
+- Emacs 28.1 or newer.
+- No third-party runtime dependency.
```elisp
-;; Add to your load-path
(add-to-list 'load-path "/path/to/tp")
(require 'tp)
```
-Or with `use-package`:
+## Choose the smallest public entry point
+
+| Need | API | Live runtime? |
+| --- | --- | --- |
+| Return a propertized string | `tp-propertize` | No |
+| Apply declarations once to an existing range | `tp-apply` | No |
+| Reactively decorate existing host text | `tp-watch` | Yes, `properties` capability |
+| Own retained text content | `tp-surface-mount` / `tp-surface-update` | Yes, `content` capability |
+| Inspect or remove a retained publication | `tp-surface-report` / `tp-surface-inspect` / `tp-surface-unmount` | Yes |
+
+The one-shot and retained APIs use the same property-policy and projection semantics. One-shot calls deliberately create no object, binding, marker, subscription, or surface state.
+
+## Static properties
```elisp
-(use-package tp
- :load-path "/path/to/tp")
+(let* ((callback (lambda (_window _object _position) "Open"))
+ (text
+ (tp-propertize
+ "Hello"
+ (list 'face '(:foreground "white" :background "navy")
+ 'help-echo callback
+ 'keymap nil))))
+ text)
```
-The modules and their roles:
+Explicit `nil` and an absent property are different. In the example above, `keymap` is present with value `nil`. Function values are literal data, so TP preserves `callback` instead of calling it.
-| Module | Responsibility |
-|---|---|
-| `tp-core.el` | Intervals, plist/face merge engine, debug logging, `$var` utilities |
-| `tp-style.el` | Namespaced property schemas, structured selectors, cascade, custom properties, and explicit computed values |
-| `tp-reactive.el` | Exact signals, memoized bindings, transactions, scoped variable adapters, and temporary legacy watcher state |
-| `tp-surface.el` | Retained plans, prepare/object lifecycle, range anchors, mounts, side indexes, diffs, reports, and atomic publication |
-| `tp-layer.el` | `define-tp` / `define-tps`, layer registry and resolution |
-| `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` |
-| `tp-search.el` | `tp-match-*`, `tp-regexp-*`, `tp-search`, navigation |
-| `tp-render.el` | Reactive re-rendering engine |
-| `tp-stack.el` | Layer stack operations (push/pop/move/merge/flatten/...) |
-| `tp-query.el` | Native text lookup/change wrappers and mutation policy |
-| `tp-palette.el` | Light/dark color palette data |
-| `tp-builtins.el` | Built-in layers, palette gallery, display-buffer helpers |
-
-A `Makefile` is included. Test sources live under `tests/`: `make test` runs
-all ERT suites, `make doctest` executes the README examples against the code
-(`tests/tp-doctest.el`),
-`make compile` byte-compiles the modules, and `make clean` removes
-compiled files.
-
----
-
-## API Reference
-
-### API Quick Reference
-
-A complete overview of all tp.el functions organized by category:
-
-#### Core Property Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-set`](#tp-set---set-text-properties) | Set text properties (replaces specified properties only) |
-| [`tp-reset`](#tp-reset---replace-all-properties) | Replace ALL text properties |
-| [`tp-add`](#tp-add---addmerge-properties) | Add/merge properties with deep merge support |
-| [`tp-get`](#tp-get---get-property-value) | Get property value(s) from range or string |
-| [`tp-at`](#tp-at---get-property-at-position) | Get property value(s) at a single position |
-| [`tp-member`](#tp-member---property-membership-at-position) | Like `tp-at`, but distinguishes present-with-nil from absent |
-| [`tp-remove`](#tp-remove---remove-property) | Remove a property or sub-property |
-| [`tp-clear`](#tp-clear---clear-all-properties) | Clear all text properties from a region |
-
-#### Pattern Matching Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-match-set`](#tp-match-set---match-string) | Set properties on string pattern matches (optional bounds) |
-| [`tp-match-reset`](#tp-match-reset---match-and-reset) | Reset all properties on string matches (optional bounds) |
-| [`tp-match-add`](#tp-match-add---match-and-add) | Add/merge properties on string matches (optional bounds) |
-| [`tp-regexp-set`](#tp-regexp-set---match-regexp) | Set properties on regexp matches (optional bounds and capture group) |
-| [`tp-regexp-reset`](#tp-regexp-reset---regexp-and-reset) | Reset all properties on regexp matches (optional bounds and capture group) |
-| [`tp-regexp-add`](#tp-regexp-add---regexp-and-add) | Add/merge properties on regexp matches (optional bounds and capture group) |
-
-#### Search & Navigation Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-search-forward`](#tp-search-forward--tp-search-backward) | **Deprecated (0.3.0)** — use [`tp-forward`](#tp-forward--tp-backward) or the Emacs primitive |
-| [`tp-search-backward`](#tp-search-forward--tp-search-backward) | **Deprecated (0.3.0)** — use [`tp-backward`](#tp-forward--tp-backward) or the Emacs primitive |
-| [`tp-forward`](#tp-forward--tp-backward) | Search forward N times for text with property (optional predicate matching) |
-| [`tp-backward`](#tp-forward--tp-backward) | Search backward N times for text with property (optional predicate matching) |
-| [`tp-forward-do`](#tp-forward-do--tp-backward-do) | Search forward N times, apply function at the Nth match |
-| [`tp-backward-do`](#tp-forward-do--tp-backward-do) | Search backward N times, apply function at the Nth match |
-| [`tp-search`](#tp-search---search-all-matches) | Search all matching properties in range or string |
-| [`tp-search-map`](#tp-search-map---apply-function-to-matched-text) | Apply function to all matches (with optional start/end range) |
-
-#### Native Text Property Compatibility
-| Function | Description |
-|----------|-------------|
-| [`tp-lookup`](#tp-lookup-result--tp-lookup) | Text-only direct/effective/source-aware property lookup |
-| [`tp-lookup-result`](#tp-lookup-result--tp-lookup) | Result record returned by `tp-lookup` |
-| [`tp-property-change`](#tp-property-change) | Wrapper for next/previous single-property or all-property change positions |
-| [`tp-property-any`](#tp-property-any--tp-property-not-all) | Wrapper for `text-property-any` |
-| [`tp-property-not-all`](#tp-property-any--tp-property-not-all) | Wrapper for `text-property-not-all` |
-| [`tp-with-mutation-policy`](#tp-with-mutation-policy) | Explicit modified/read-only mutation policy wrapper |
-
-#### Schema-Driven Cascade
-
-| Function | Description |
-|----------|-------------|
-| `tp-define-property` / `tp-property-schema` | Register and inspect an atomic namespaced property schema |
-| `tp-text-property-id` / `tp-register-text-property` / `tp-text-declarations` | Map native Emacs properties into the canonical `text/` domain |
-| `tp-subject-create` / `tp-subject-set-children` | Build consumer-independent selector subjects and relations |
-| `tp-selector-match-p` / `tp-selector-specificity` | Match the structured selector AST and compute its specificity |
-| `tp-define-style` / `tp-style-declarations` / `tp-undefine-style` | Register, inspect, and remove defensive named declarations |
-| `tp-stylesheet-create` / `tp-stylesheet-add-rule` | Create an isolated rule/layer domain and add origin/layer/scope-aware structured rules |
-| `tp-wide-value` / `tp-important` / `tp-var` | Construct unambiguous cascade values without reserving ordinary Elisp symbols |
-| `tp-computed` | Mark the only function values TP should execute |
-| `tp-compute-style` / `tp-project-style` | Compute canonical values/provenance and project final Emacs text properties |
-| `tp-style-reset-rules` / `tp-style-reset` | Reset one isolated/default stylesheet, or TP's global schemas, named styles, and default stylesheet |
-
-#### Signals and Bindings
-
-| Function | Description |
-|----------|-------------|
-| `tp-signal-create` / `tp-signal-read` / `tp-signal-set` | Create, dependency-track, and transactionally update a reactive source |
-| `tp-signal-peek` / `tp-signal-live-p` / `tp-signal-subscriber-count` / `tp-signal-dispose` | Inspect or explicitly end signal lifecycle without collecting a dependency |
-| `tp-bind` / `tp-binding-read` | Idempotently install a memoized owner+key computation and read it as a dependency |
-| `tp-binding-live-p` / `tp-binding-dependency-count` / `tp-binding-subscriber-count` | Inspect binding lifecycle and exact graph degree |
-| `tp-binding-dispose-owner` | Remove an owner's bindings and all graph edges |
-| `tp-with-transaction` | Batch candidate writes and publish one deduplicated dirty closure atomically |
-| `tp-transaction-participate` | Promote client side state inside the publication boundary with an explicit rollback action |
-| `tp-variable-signal` | Adapt a global or buffer-local Elisp variable into a scoped signal |
-| `tp-reactive-counters` / `tp-reactive-reset-counters` | Read or reset public scheduler work counters |
-
-#### Retained Surfaces
-
-| Function | Description |
-|----------|-------------|
-| `tp-surface-plan-create` / `tp-surface-result-create` | Build defensive pure plan data and attach optional opaque client state |
-| `tp-object-ensure` / `tp-object-retain` / `tp-object-resolve` | Allocate candidate identity, explicitly retain a logical object, or resolve committed identity by key path |
-| `tp-object-attach-fragment` / `tp-object-mounts` | Give one logical object disjoint output mounts and inspect defensive numeric range/tag snapshots |
-| `tp-range-anchor-create` / `tp-object-attach-range` / `tp-range-rebase` | Attach host-owned text ranges without putting positions in plans |
-| `tp-surface-materialize-string` | Render a plan or ephemeral producer without live identity, markers, or subscriptions |
-| `tp-surface-mount` / `tp-surface-update` / `tp-surface-update-scoped` / `tp-surface-unmount` | Own the only live publication lifecycle, including object-scoped atomic updates |
-| `tp-surface-at-point` / `tp-surface-inspect` / `tp-surface-report` | Query retained side indexes and generic commit diagnostics without scanning text |
-
-#### Convenience APIs
-
-| Function | Description |
-|----------|-------------|
-| `tp-propertize` | Return a styled string copy using the schema/cascade/projector core |
-| `tp-apply` | Apply native declarations once to an existing buffer range |
-| `tp-watch` | Reactively maintain declarations on an existing range through a properties surface |
-
-#### Property Layer Definition Functions
-| Function | Description |
-|----------|-------------|
-| [`define-tp`](#define-tp--define-tps---define-custom-text-properties) | Define custom text property (layer) with optional parameters |
-| [`define-tps`](#define-tp--define-tps---define-custom-text-properties) | Define custom text property group (layer group) with optional parameters |
-| [`tp-define-layer` / `tp-define-group`](#define-tp--define-tps---define-custom-text-properties) | Prefix-conforming aliases of `define-tp` / `define-tps` |
-| [`tp-layer-props`](#tp-layer-props--tp-group-props) | Get properties for a layer |
-| [`tp-group-props`](#tp-layer-props--tp-group-props) | Get properties for all layers in a group |
-| [`tp-layer-props-with-args`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | Expand a parameterized layer with a list of arguments |
-| [`tp-group-props-with-args`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | Expand a parameterized group with a list of arguments |
-| [`tp-layer-arglist`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | Get a parameterized layer's parameter list |
-| [`tp-describe-layer`](#tp-describe-layer---describe-a-layer) | Describe a layer's definition in a help buffer |
-| [`tp-undefine-layer`](#tp-undefine-layer--tp-undefine-group) | Remove layer definition |
-| [`tp-undefine-group`](#tp-undefine-layer--tp-undefine-group) | Remove group definition |
-| [`tp-layer-reset`](#tp-layer-reset) | Clear all layer/group definitions |
-| [`tp-reactive-reset`](#tp-reactive-reset) | Clear all reactive dependencies and watchers |
-
-#### Property Layer Placement Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-put-layer`](#tp-put-layer---set-layer-at-index) | Set layer at specific index position (optional NOERROR) |
-| [`tp-push-layer`](#tp-push-layer---push-layer-to-top) | Push layer to top of stack (optional NOERROR) |
-
-#### Property Layer Deletion Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-delete-layer`](#tp-delete-layer---delete-layer-by-nameindex) | Delete layer by name or index |
-| [`tp-pop-layer`](#tp-pop-layer---pop-top-layer) | Remove top layer |
-
-#### Property Layer Movement Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-move-layer`](#tp-move-layer---move-layer-to-position) | Move a layer from one position to another |
-| [`tp-raise-layer`](#tp-raise-layer---move-layer-updown) | Move layer up/down by N positions |
-| [`tp-lower-layer`](#tp-lower-layer---mirror-of-tp-raise-layer) | Mirror of `tp-raise-layer`: move layer down/up by N positions |
-| [`tp-rotate-layer`](#tp-rotate-layer---cycle-layers) | Cycle layers up or down by N steps |
-| [`tp-pin-layer`](#tp-pin-layer---pin-layer-to-top) | Move a layer to the top (one-shot; later pushes can cover it) |
-| [`tp-switch-layer`](#tp-switch-layer---switch-two-layers) | Swap positions of two layers |
-
-#### Property Layer Visibility Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-hide-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers) | Hide a layer without removing it from the stack |
-| [`tp-show-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers) | Make a hidden layer render again |
-
-#### Managed Layer Lifecycle
-| Function | Description |
-|----------|-------------|
-| [`tp-attach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | Attach inserted/copied managed layer storage to the current buffer registry |
-| [`tp-detach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | Remove managed storage, optionally keeping rendered visible properties |
-| [`tp-managed-layer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only diagnostics for one layer |
-| [`tp-managed-buffer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only diagnostics for one buffer |
-| [`tp-managed-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only global managed lifecycle diagnostics |
-| [`tp-layer-transaction`](#tp-layer-transaction) | Run a managed stack change with rollback on error |
-
-#### Property Layer Merging Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-merge-layers`](#tp-merge-layers---merge-multiple-layers) | Merge specified layers into a new layer (hidden layers contribute no props) |
-| [`tp-flatten-layers`](#tp-flatten-layers---flatten-all-layers) | Flatten all layers into a single layer (hidden layers are discarded) |
-
-#### Property Layer Query Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-layer-list`](#tp-layer-list---list-all-layers) | List all layer names in region |
-| [`tp-layer-count`](#tp-layer-count) | Count layers in region |
-| [`tp-layer-exists-p`](#tp-layer-exists-p) | Check if layer exists in region |
-| [`tp-layer-top`](#tp-layer-top) | Get name of top layer (in stack order, even when hidden) |
-| [`tp-layer-stack-at`](#tp-layer-stack-at---full-stack-at-a-position) | Full ordered stack at one position as `(NAME . PROPS)` conses |
-| [`tp-region-layer-props`](#tp-region-layer-props---get-layer-properties-in-region) | Get properties for a specific layer in region |
-
-#### Property Layer Manipulation Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-add-to-layers`](#tp-add-to-layers---add-properties-to-specific-layers) | Add/merge properties to specific layers by index or name |
-| [`tp-add-to-all-layers`](#tp-add-to-all-layers---add-properties-to-all-layers) | Add/merge properties to all existing layers |
-
-#### Utility Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-intervals`](#tp-intervals---get-text-property-intervals) | Get all text property intervals in a region (optional ABSOLUTE coordinates) |
-| [`tp-intervals-map`](#tp-intervals-map---apply-function-to-intervals) | Apply function to all intervals in a region (optional ABSOLUTE coordinates) |
-| [`tp-plist`](#tp-plist---get-all-properties-in-region) | Get all properties present in a region |
-| [`tp-empty-p`](#tp-empty-p---check-if-object-has-properties) | Check if object has no text properties |
-| [`tp-with-current-buffer`](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer) | Run body in a buffer with `inhibit-read-only` bound |
-| [`tp-pop-to-buffer`](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer) | Fill a buffer, make it read-only, display via `pop-to-buffer` |
-| [`tp-switch-to-buffer`](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer) | Fill a buffer, make it read-only, display via `switch-to-buffer` |
-
-#### Palette Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-palette-alist`](#color-palette-system) | Registry of named palettes (variable) |
-| [`define-tp-palette`](#color-palette-system) | Register or update a named palette (alias: `tp-define-palette`) |
-| [`tp-palette-color`](#color-palette-system) | Get a palette's `:fg` / `:bg` / `:border` color, theme-resolved |
-| [`tp-palette-has-p`](#color-palette-system) | Test whether a palette (or one of its keys) is defined |
-| [`tp-palette-show`](#color-palette-system) | Show a gallery of all registered palettes |
-| [`tp-parse-color`](#color-palette-system) | Resolve a color spec for the current light/dark theme |
-
-#### Reactive Lifecycle Functions
-| Function | Description |
-|----------|-------------|
-| [`tp-with-batch-updates`](#batched-updates) | Apply several reactive variable changes as one update |
-| [`tp-reactive-layer-buffers`](#layer-buffer-registry--lifecycle) | Buffers registered as showing a layer (or `unknown`) |
-| [`tp-reactive-track-buffer`](#layer-buffer-registry--lifecycle) | Register a buffer after inserting an already-propertized string |
-| [`tp-gc-anonymous-layers`](#layer-buffer-registry--lifecycle) | Collect anonymous layers no registered live buffer still shows |
-
----
-
-### Core Property Functions
-
-> **Important: String Modification Behavior**
->
-> The core property functions (`tp-set`, `tp-reset`, `tp-add`, `tp-remove`) have different behaviors depending on the calling convention:
->
-> | Calling Convention | Underlying Implementation | Modifies Original? |
-> |-------------------|---------------------------|-------------------|
-> | `(tp-set STRING PROP VAL ...)` | Uses `propertize` internally | **No** - Returns a NEW string |
-> | `(tp-set START END PROPS)` | Uses `put-text-property` on buffer | Yes - Modifies current buffer |
-> | `(tp-set START END PROPS STRING)` | Uses `put-text-property` on string | **Yes** - Modifies original string |
-> | `(tp-set START END PROPS BUFFER)` | Uses `put-text-property` on buffer | Yes - Modifies the buffer |
->
-> **Summary:**
-> - **Entire string form** `(tp-set "string" ...)`: Creates a **new** propertized string. The original string is not modified. This uses `propertize` internally.
-> - **Region form with string object** `(tp-set 0 5 '(...) string)`: **Directly modifies** the original string object using `put-text-property` or `set-text-properties`.
-> - **Buffer forms**: Always modify the buffer in-place.
->
-> This distinction applies to all core property functions: `tp-set`, `tp-reset`, `tp-add`, and `tp-remove`.
-
-#### `tp-set` - Set Text Properties
-
-Set text properties on a string or buffer region. Replaces only the specified properties, preserving others.
+To modify an existing range without changing its text:
```elisp
-;; Current buffer (properties as a list) - modifies buffer in-place
-(tp-set START END '(PROPERTY VALUE ...))
-(tp-set START END LAYER-NAME)
-
-;; Specific buffer or string - modifies OBJECT in-place
-(tp-set START END '(PROPERTY VALUE ...) OBJECT)
-(tp-set START END LAYER-NAME OBJECT)
-
-;; Entire string (flat properties or layer name) - returns NEW string
-(tp-set STRING PROPERTY VALUE ...)
-(tp-set STRING LAYER-NAME)
-```
-
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-
-**Return Values:**
-- Buffer forms: Returns `(START . END)` cons cell
-- String region form `(tp-set 0 5 '(...) string)`: Returns the modified string (same object)
-- Entire string form `(tp-set "string" ...)`: Returns a **new** propertized string
-
-**Examples:**
-
-```elisp
-;; Set face on buffer region
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold)))
-;; => (1 . 10)
-
-;; Set multiple properties
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold help-echo "Click me")))
-;; => (1 . 10)
-
-;; Use a defined layer name
-(define-tp warning-style ()
- '(face (:foreground "orange" :weight bold)))
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 'warning-style))
-;; => (1 . 10)
-
-;; Set on specific buffer
-(let ((my-buffer (generate-new-buffer "*test*")))
- (with-current-buffer my-buffer
- (insert "Hello World"))
- (prog1 (tp-set 1 10 '(face italic) my-buffer)
- (kill-buffer my-buffer)))
-;; => (1 . 10)
-
-;; Set properties on a string region (0-indexed) - MODIFIES original string
-(let ((my-string (copy-sequence "Hello World")))
- (tp-set 0 5 '(face italic) my-string)
- my-string)
-;; => #("Hello World" 0 5 (face italic))
-
-;; Set properties on entire string - returns NEW string, original unchanged
-(let ((original "Hello"))
- (let ((result (tp-set original 'face 'bold)))
- (list :original original
- :result result
- :original-has-props (get-text-property 0 'face original)
- :result-has-props (get-text-property 0 'face result))))
-;; => (:original "Hello" :result #("Hello" 0 5 (face bold))
-;; :original-has-props nil :result-has-props bold)
-
-;; Use a defined layer name on entire string
-(define-tp my-style ()
- :props '(face (:foreground $my-color))
- :data '((my-color . "blue")))
-(tp-set " " 'my-style)
-;; => #(" " 0 1 (face (:foreground "blue") tp-name my-style))
-;; (the printed ORDER of properties may differ across Emacs
-;; versions; the values are identical)
-
-;; Merge multiple faces in a single call (duplicate properties auto-merged)
-(tp-set "emacs"
- 'face 'bold
- 'face '(:background "green")
- 'face '(:foreground "red"))
-;; => face is ((:foreground "red") (:background "green") bold)
-;; (entries stack into one face list, most recent first)
-
-;; Later values override earlier ones for the same sub-property
-(tp-set "emacs"
- 'face '(:foreground "red")
- 'face '(:foreground "yellow"))
-;; => face's :foreground is "yellow" (later overrides earlier)
-
-;; Use with tp-palette layer, merging extra face properties
-(tp-set "emacs"
- 'tp-palette 'info
- 'face '(:foreground "red"))
-;; => tp-palette's face is merged with (:foreground "red"), :foreground is overridden
-```
-
----
-
-#### `tp-reset` - Replace All Properties
-
-Completely replace ALL text properties with the specified ones.
-
-```elisp
-;; Buffer/region forms - modifies in-place
-(tp-reset START END '(PROPERTY VALUE ...) &optional OBJECT)
-(tp-reset START END LAYER-NAME &optional OBJECT)
-
-;; Entire string form - returns NEW string
-(tp-reset STRING PROPERTY VALUE ...)
-```
-
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-
-**Return Values:**
-- Buffer forms: Returns `(START . END)` cons cell
-- String region form: Returns the modified string (same object)
-- Entire string form: Returns a **new** propertized string
-
-**Examples:**
-
-```elisp
-;; Replace all properties in region
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(help-echo "old")) ; Set existing property
- (tp-reset 1 10 '(face bold)) ; Any existing properties are removed
- (tp-at 1))
-;; => (face bold) ; help-echo is gone
-
-;; On entire string - returns NEW string, original unchanged
-(let ((original "Hello"))
- (let ((result (tp-reset original 'face 'italic)))
- (list :original-modified (get-text-property 0 'face original)
- :result-face (get-text-property 0 'face result))))
-;; => (:original-modified nil :result-face italic)
-
-;; Use a defined layer name
-(define-tp error-style ()
- '(face (:foreground "red" :weight bold)))
-(with-temp-buffer
- (insert "Hello World")
- (tp-reset 1 10 'error-style))
-;; => (1 . 10) ; All properties replaced with error-style
-```
-
----
-
-#### `tp-add` - Add/Merge Properties
-
-Add or update properties with deep merge support for nested plists.
-
-```elisp
-;; Buffer/region forms - modifies in-place
-(tp-add START END '(PROPERTY VALUE ...) &optional OBJECT)
-(tp-add START END LAYER-NAME &optional OBJECT)
-
-;; Entire string form - returns NEW string
-(tp-add STRING PROPERTY VALUE ...)
-```
-
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-
-**Return Values:**
-- Buffer forms: Returns `(START . END)` cons cell
-- String region form: Returns the modified string (same object)
-- Entire string form: Returns a **new** propertized string
-
-**Examples:**
-
-```elisp
-;; Add properties (preserves existing, merges nested)
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold))
- (tp-add 1 10 '(help-echo "tooltip"))
- (tp-at 1))
-;; => (face bold help-echo "tooltip")
-
-;; Deep merge face properties
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:foreground "red")))
- (tp-add 1 10 '(face (:background "blue")))
- (tp-at 1 'face))
-;; => (:foreground "red" :background "blue")
-
-;; Entire string form - returns NEW string, original unchanged
-(let ((original "Hello"))
- (let ((result (tp-add original 'face 'bold)))
- (list :original-modified (get-text-property 0 'face original)
- :result-face (get-text-property 0 'face result))))
-;; => (:original-modified nil :result-face bold)
-
-;; Use a defined layer name
-(define-tp highlight-style ()
- '(face (:background "yellow")))
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold))
- (tp-add 1 10 'highlight-style)
- (tp-at 1))
-;; => Properties merged with highlight-style
-```
-
----
-
-#### `tp-get` - Get Property Value
-
-Get property value(s) from range or string, with support for nested sub-properties.
-
-Returns a list of `(START END VALUE)` intervals, allowing you to see all property values across the range.
-
-For single position queries, use `tp-at` instead.
-
-```elisp
-;; Range - specific property (returns list of intervals)
-(tp-get START END PROPERTY)
-(tp-get START END PROPERTY OBJECT)
-
-;; Range with property path as list
-(tp-get START END '(PROPERTY) OBJECT)
-(tp-get START END '(PROPERTY SUB-KEY ...) OBJECT)
-
-;; Range with deeply nested property path
-(tp-get START END '(PROPERTY SUB-KEY SUB-SUB-KEY ...) OBJECT)
-
-;; Range extracting multiple keys from nested property
-(tp-get START END '(PROPERTY SUB-KEY (KEY1 KEY2 ...)) OBJECT)
-
-;; Range - all properties (returns list of intervals)
-(tp-get START END)
-(tp-get START END OBJECT)
-
-;; Entire string (returns list of intervals)
-(tp-get STRING)
-(tp-get STRING PROPERTY)
-(tp-get STRING PROPERTY SUB-KEY ...)
-(tp-get STRING PROPERTY SUB-KEY '(KEY1 KEY2 ...))
-(tp-get STRING '(PROPERTY SUB-KEY ...))
-```
-
-**Examples:**
-
-```elisp
-;; Get from range - returns list of (START END VALUE) intervals
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-get 1 10 'face))
-;; => ((1 6 bold))
-
-;; Get with multiple intervals
-(let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-set 12 17 '(face italic) str)
- (tp-get 0 17 'face str))
-;; => ((0 5 bold) (12 17 italic))
-
-;; Get with property path as list
-(let ((my-string (copy-sequence "Hello World Hello World")))
- (tp-set 5 20 '(face (:underline (:style wave))) my-string)
- (tp-get 5 20 '(face :underline :style) my-string))
-;; => ((5 20 wave))
-
-;; Get deeply nested property from entire string
-(let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face (:underline (:color "green"))) str)
- (tp-set 6 11 '(face (:underline (:color "yellow"))) str)
- (tp-get str 'face :underline :color))
-;; => ((0 5 "green") (6 11 "yellow"))
-
-;; Get multiple keys from nested property
-(let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face (:underline (:color "green" :style wave))) str)
- (tp-set 6 11 '(face (:underline (:color "yellow" :style line))) str)
- (tp-get str 'face :underline '(:color :style)))
-;; => ((0 5 (:color "green" :style wave)) (6 11 (:color "yellow" :style line)))
-
-;; Get all properties from range
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold help-echo "test"))
- (tp-get 1 10))
-;; => ((1 6 (face bold help-echo "test")))
-
-;; Get from entire string - returns list of intervals
-(let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-set 12 17 '(face italic) str)
- (list (tp-get str) ; => ((0 5 (face bold)) (12 17 (face italic)))
- (tp-get str 'face))) ; => ((0 5 bold) (12 17 italic))
-;; => (((0 5 (face bold)) (12 17 (face italic))) ((0 5 bold) (12 17 italic)))
-```
-
----
-
-#### `tp-at` - Get Property at Position
-
-```elisp
-;; Get all properties at position
-(tp-at POS)
-(tp-at POS OBJECT)
-
-;; Get specific property at position
-(tp-at POS PROPERTY)
-(tp-at POS PROPERTY OBJECT)
-
-;; Get nested sub-property at position
-(tp-at POS '(PROPERTY SUB-KEY ...))
-(tp-at POS '(PROPERTY SUB-KEY ...) OBJECT)
-```
-
-Get text properties at POS, optionally filtered by PROPERTY.
-
-For single-position property queries (previously done with `tp-get`), use `tp-at`.
-
-**Examples:**
-
-```elisp
-;; Get all properties at position 5 in current buffer
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold help-echo "test"))
- (tp-at 5))
-;; => (face bold help-echo "test")
-
-;; Get all properties at position 0 in string
-(let ((my-string (tp-set "Hello" 'face 'italic 'help-echo "greeting")))
- (tp-at 0 my-string))
-;; => (face italic help-echo "greeting")
-
-;; Get specific property at position
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold))
- (tp-at 5 'face))
-;; => bold
-
-;; Get specific property at position in string
-(let ((my-string (tp-set "Hello" 'face 'italic)))
- (tp-at 0 'face my-string))
-;; => italic
-
-;; Get nested sub-property at position
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:foreground "red" :box (:color "blue"))))
- (list (tp-at 5 '(face :foreground))
- (tp-at 5 '(face :box :color))))
-;; => ("red" "blue")
-
-;; Get nested sub-property from string
-(let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face (:foreground "red" :underline t)) str)
- (tp-at 0 '(face :foreground) str))
-;; => "red"
-```
-
----
-
-#### `tp-member` - Property Membership at Position
-
-```elisp
-(tp-member POS PROPERTY &optional OBJECT)
-```
-
-Like `tp-at`, but returns a `(PROPERTY VALUE)` list when PROPERTY is present
-at POS, or nil when it is absent. This distinguishes a property that is
-present with the value nil from a property that is missing entirely
-(analogous to `plist-member`).
-
-**Examples:**
-
-```elisp
-;; Present with value nil vs. absent
-(let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face nil) str)
- (list (tp-member 0 'face str) ; present, value nil
- (tp-member 0 'display str))) ; absent
-;; => ((face nil) nil)
-
-;; In a buffer
-(with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold))
- (tp-member 1 'face))
-;; => (face bold)
-```
-
----
-
-#### `tp-remove` - Remove Property
-
-Remove a property or nested sub-property from a region or entire string.
-
-```elisp
-;; Remove entire property (buffer) - modifies in-place
-(tp-remove START END PROPERTY &optional OBJECT)
-
-;; Remove sub-property (buffer) - modifies in-place
-(tp-remove START END '(PROPERTY SUB-KEY) &optional OBJECT)
-
-;; Remove nested sub-properties (buffer) - modifies in-place
-(tp-remove START END '(PROPERTY SUB-KEY (NESTED-KEYS...)) &optional OBJECT)
-
-;; Remove from entire string - returns NEW string
-(tp-remove STRING PROP1 PROP2 ...)
-(tp-remove STRING PROPERTY SUB-KEY)
-(tp-remove STRING PROPERTY SUB-KEY '(NESTED-KEYS...))
-```
-
-**Return Values:**
-- Buffer forms: Returns `nil`
-- Entire string forms: Returns a **new** string with properties removed
-
-**Examples:**
-
-```elisp
-;; Remove entire property
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold help-echo "test"))
- (tp-remove 1 10 'face)
- (tp-at 1))
-;; => (help-echo "test")
-
-;; Remove sub-property from face
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:foreground "red" :underline t)))
- (tp-remove 1 10 '(face :underline))
- (tp-at 1 'face))
-;; => (:foreground "red")
-
-;; Remove specific nested keys, keep others
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:underline (:style wave :position t :color "blue"))))
- (tp-remove 1 10 '(face :underline (:style :position)))
- (tp-at 1 '(face :underline)))
-;; => (:color "blue") ; :style and :position removed, :color preserved
-
-;; Remove from entire string - returns NEW string, original unchanged
-(let ((original (propertize "Hello" 'face 'bold 'help-echo "tip")))
- (let ((result (tp-remove original 'face)))
- (list :original-face (get-text-property 0 'face original)
- :result-face (get-text-property 0 'face result))))
-;; => (:original-face bold :result-face nil)
-
-;; Remove sub-property from string - returns NEW string
-(let ((original (propertize "Hello" 'face '(:foreground "red" :underline t))))
- (let ((result (tp-remove original 'face :underline)))
- (list :original (get-text-property 0 'face original)
- :result (get-text-property 0 'face result))))
-;; => (:original (:foreground "red" :underline t) :result (:foreground "red"))
-
-;; Remove nested keys from string
-(let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue")))))
- (let ((result (tp-remove original 'face :underline '(:style))))
- (tp-at 0 '(face :underline) result)))
-;; => (:color "blue")
-```
-
----
-
-#### `tp-clear` - Clear All Properties
-
-```elisp
-(tp-clear &optional START END OBJECT)
-```
-
-Clear all text properties from a region. Returns nil.
-
-**Examples:**
-
-```elisp
-;; Clear region
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold))
- (tp-clear 1 10)
- (tp-at 1))
-;; => nil
-
-;; Clear entire buffer
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 12 '(face bold))
- (tp-clear)
- (tp-at 5))
-;; => nil
-```
-
----
-
-### Pattern Matching Functions
-
-#### `tp-match-set` - Match String
-
-```elisp
-(tp-match-set PATTERN PLIST &optional OBJECT START END)
-(tp-match-set PATTERN LAYER-NAME &optional OBJECT START END)
-```
-
-Set properties on all occurrences of a string pattern.
-PATTERN can be a string (single pattern) or a list of strings (multiple patterns).
-PLIST is a property list like `'(face bold help-echo "tip")`.
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-OBJECT is a buffer or string; nil means current buffer.
-START and END (new in 0.3.0) restrict matching to the `[START, END)` portion
-of OBJECT, in native coordinates (0-based for strings, 1-based for buffers).
-Matching behaves **as if OBJECT consisted only of that portion**, so no match
-crosses the boundaries; reversed bounds are swapped. The same bounds are
-accepted by all six `tp-match-*` / `tp-regexp-*` functions.
-
-**Examples:**
-
-```elisp
-;; In buffer - returns list of (START . END) pairs
-(with-temp-buffer
- (insert "TODO: fix this. TODO: also this.")
- (tp-match-set "TODO" '(face warning)))
-;; => ((1 . 5) (17 . 21))
-
-;; On string - returns a NEW propertized string (original is not modified)
-(tp-match-set "o" '(face bold) "Hello World")
-;; => #("Hello World" 4 5 (face bold) 7 8 (face bold))
-
-;; Multiple patterns - match both "world" and "Hello"
-(with-temp-buffer
- (insert "Hello world, Hello again")
- (tp-match-set '("world" "Hello") '(face bold)))
-;; => ((7 . 12) (1 . 6) (14 . 19)) ; regions grouped per pattern:
-;; "world" first, then each "Hello", in the order patterns are given
-
-;; Multiple patterns on string
-(tp-match-set '("Hello" "world") '(face bold) "Hello world")
-;; => #("Hello world" 0 5 (face bold) 6 11 (face bold))
-
-;; Use a defined layer name
-(define-tp todo-style ()
- '(face (:foreground "orange" :weight bold)))
-(with-temp-buffer
- (insert "TODO: fix this. TODO: also this.")
- (tp-match-set "TODO" 'todo-style))
-;; => ((1 . 5) (17 . 21))
-
-;; Restrict matching with START/END bounds - only the second TODO is in range
-(with-temp-buffer
- (insert "TODO one TODO two")
- (tp-match-set "TODO" '(face warning) nil 5 18))
-;; => ((10 . 14))
-```
-
----
-
-#### `tp-match-reset` - Match and Reset
-
-Reset (completely replace) all properties on matches.
-PATTERN can be a string or list of strings (multiple patterns).
-PLIST is a property list like `'(face bold help-echo "tip")`.
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-OBJECT is a buffer or string; nil means current buffer.
-
-```elisp
-(tp-match-reset PATTERN PLIST &optional OBJECT START END)
-(tp-match-reset PATTERN LAYER-NAME &optional OBJECT START END)
-```
-
-START and END restrict matching to the `[START, END)` portion of OBJECT
-(see [`tp-match-set`](#tp-match-set---match-string)).
-
-**Examples:**
-
-```elisp
-;; Replaces ALL properties on matched text
-(with-temp-buffer
- (insert "TODO: fix this")
- (tp-set 1 5 '(help-echo "original")) ; Set existing property
- (tp-match-reset "TODO" '(face warning))
- (tp-at 1))
-;; => (face warning) ; help-echo is removed
-
-;; Multiple patterns
-(with-temp-buffer
- (insert "TODO: fix. FIXME: also fix.")
- (tp-match-reset '("TODO" "FIXME") '(face warning)))
-;; => ((1 . 5) (12 . 17))
-
-;; Use a defined layer name
-(define-tp alert-style ()
- '(face (:background "red" :foreground "white")))
-(with-temp-buffer
- (insert "TODO: fix this")
- (tp-match-reset "TODO" 'alert-style))
-;; => ((1 . 5))
-```
-
----
-
-#### `tp-match-add` - Match and Add
-
-Add/merge properties on matches with deep merge support.
-PATTERN can be a string or list of strings (multiple patterns).
-PLIST is a property list like `'(face bold help-echo "tip")`.
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-OBJECT is a buffer or string; nil means current buffer.
-
-```elisp
-(tp-match-add PATTERN PLIST &optional OBJECT START END)
-(tp-match-add PATTERN LAYER-NAME &optional OBJECT START END)
-```
-
-START and END restrict matching to the `[START, END)` portion of OBJECT
-(see [`tp-match-set`](#tp-match-set---match-string)).
-
-**Examples:**
-
-```elisp
-;; Merges with existing properties
-(with-temp-buffer
- (insert "TODO: fix this")
- (tp-set 1 5 '(help-echo "important"))
- (tp-match-add "TODO" '(face (:underline t)))
- (tp-at 1))
-;; => (face (:underline t) help-echo "important")
-
-;; Multiple patterns
-(with-temp-buffer
- (insert "TODO: fix. FIXME: also fix.")
- (tp-match-add '("TODO" "FIXME") '(face (:underline t))))
-;; => ((1 . 5) (12 . 17))
-
-;; Use a defined layer name
-(define-tp underline-style ()
- '(face (:underline (:color "blue" :style wave))))
-(with-temp-buffer
- (insert "TODO: fix this")
- (tp-match-add "TODO" 'underline-style))
-;; => ((1 . 5))
-```
-
----
-
-#### `tp-regexp-set` - Match Regexp
-
-```elisp
-(tp-regexp-set PATTERN PLIST &optional OBJECT START END SUBEXP)
-(tp-regexp-set PATTERN LAYER-NAME &optional OBJECT START END SUBEXP)
-```
-
-Set properties on all matches of a regular expression.
-PATTERN can be a string (single regexp) or a list of strings (multiple regexps).
-PLIST is a property list like `'(face bold help-echo "tip")`.
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-OBJECT is a buffer or string; nil means current buffer.
-START and END (new in 0.3.0) restrict matching to the `[START, END)` portion
-of OBJECT, in native coordinates; matching behaves as if OBJECT consisted
-only of that portion, and reversed bounds are swapped
-(see [`tp-match-set`](#tp-match-set---match-string)).
-SUBEXP (new in 0.3.0) names a capture group of PATTERN (1 = first group, as
-in font-lock highlights): properties apply to that group of each match
-instead of the whole match. A match in which the group does not participate
-contributes nothing; a SUBEXP beyond the pattern's group count signals a
-clear error. All three `tp-regexp-*` functions accept SUBEXP.
-
-**Examples:**
-
-```elisp
-;; Highlight all numbers in buffer
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-regexp-set "[0-9]+" '(face font-lock-number-face))
- (list (tp-at 5 'face) (tp-at 13 'face)))
-;; => (font-lock-number-face font-lock-number-face)
-
-;; On string (`case-fold-search' applies by default, so "Hello" matches too;
-;; let-bind it to nil for case-sensitive matching)
-(tp-regexp-set "[A-Z]+" '(face bold) "Hello WORLD")
-;; => #("Hello WORLD" 0 5 (face bold) 6 11 (face bold))
-
-;; Multiple regexps - match both numbers and uppercase letters
-;; (with case folding, "abc" matches "[A-Z]+" as well)
-(tp-regexp-set '("[0-9]+" "[A-Z]+") '(face bold) "abc 123 XYZ")
-;; => #("abc 123 XYZ" 0 3 (face bold) 4 7 (face bold) 8 11 (face bold))
-
-;; Use a defined layer name
-(define-tp number-style ()
- '(face (:foreground "green")))
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-regexp-set "[0-9]+" 'number-style))
-;; => ((5 . 8) (13 . 16))
-
-;; SUBEXP - propertize only capture group 1 of each match
-(tp-regexp-set "\\([0-9]+\\)px" '(face bold) "margin: 10px 4px" nil nil 1)
-;; => #("margin: 10px 4px" 8 10 (face bold) 13 14 (face bold))
-
-;; A match whose group does not participate contributes nothing:
-;; "bar" matches the pattern, but group 1 only participates in "foo"
-(tp-regexp-set "\\(foo\\)\\|bar" '(face bold) "foo bar" nil nil 1)
-;; => #("foo bar" 0 3 (face bold))
-
-;; SUBEXP beyond the pattern's group count signals a clear error
-(tp-regexp-set "[0-9]+" '(face bold) "abc 123" nil nil 2)
-;; error: Regexp "[0-9]+" has no group 2
-
-;; START/END bounds: as if only that portion existed - the greedy a+
-;; matches exactly [1, 3) instead of the whole run
-(tp-regexp-set "a+" '(face bold) "aaaa" 1 3)
-;; => #("aaaa" 1 3 (face bold))
-
-;; Reversed bounds are swapped
-(tp-regexp-set "a+" '(face bold) "aaaa" 3 1)
-;; => #("aaaa" 1 3 (face bold))
-```
-
----
-
-#### `tp-regexp-reset` - Regexp and Reset
-
-Reset (completely replace) all properties on regexp matches.
-PATTERN can be a string or list of strings (multiple regexps).
-PLIST is a property list like `'(face bold help-echo "tip")`.
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-OBJECT is a buffer or string; nil means current buffer.
-
-```elisp
-(tp-regexp-reset PATTERN PLIST &optional OBJECT START END SUBEXP)
-(tp-regexp-reset PATTERN LAYER-NAME &optional OBJECT START END SUBEXP)
-```
-
-START/END bounds and the SUBEXP capture group work exactly as in
-[`tp-regexp-set`](#tp-regexp-set---match-regexp).
-
-**Examples:**
-
-```elisp
-;; Reset all properties on regexp matches
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-set 5 8 '(help-echo "original"))
- (tp-regexp-reset "[0-9]+" '(face bold))
- (tp-at 5))
-;; => (face bold) ; help-echo is removed
-
-;; On string - returns a NEW string; the original is unchanged
-(let ((str (copy-sequence "abc 123 def")))
- (tp-set 4 7 '(help-echo "original") str)
- (let ((result (tp-regexp-reset "[0-9]+" '(face italic) str)))
- (list (tp-at 4 result) (tp-at 4 str))))
-;; => ((face italic) (help-echo "original"))
-
-;; Use a defined layer name
-(define-tp code-number ()
- '(face (:foreground "cyan")))
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-regexp-reset "[0-9]+" 'code-number))
-;; => ((5 . 8) (13 . 16))
-```
-
----
-
-#### `tp-regexp-add` - Regexp and Add
-
-Add/merge properties on regexp matches with deep merge support.
-PATTERN can be a string or list of strings (multiple regexps).
-PLIST is a property list like `'(face bold help-echo "tip")`.
-LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`.
-OBJECT is a buffer or string; nil means current buffer.
-
-```elisp
-(tp-regexp-add PATTERN PLIST &optional OBJECT START END SUBEXP)
-(tp-regexp-add PATTERN LAYER-NAME &optional OBJECT START END SUBEXP)
-```
-
-START/END bounds and the SUBEXP capture group work exactly as in
-[`tp-regexp-set`](#tp-regexp-set---match-regexp).
-
-**Examples:**
-
-```elisp
-;; Add properties to regexp matches (preserves existing)
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-set 5 8 '(help-echo "number"))
- (tp-regexp-add "[0-9]+" '(face bold))
- (tp-at 5))
-;; => (face bold help-echo "number")
-
-;; On string - returns a NEW string; the original is unchanged
-(let ((str (copy-sequence "abc 123 def")))
- (tp-set 4 7 '(help-echo "number") str)
- (let ((result (tp-regexp-add "[0-9]+" '(face italic) str)))
- (list (tp-at 4 result) (tp-at 4 str))))
-;; => ((face italic help-echo "number") (help-echo "number"))
-
-;; Use a defined layer name
-(define-tp bold-underline ()
- '(face (:weight bold :underline t)))
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-regexp-add "[0-9]+" 'bold-underline))
-;; => ((5 . 8) (13 . 16))
-```
-
----
-
-### Search & Navigation Functions
-
-#### `tp-search-forward` / `tp-search-backward`
-
-> ⚠️ **Deprecated since 0.3.0.** These are raw wrappers for Emacs's
-> `text-property-search-forward` / `text-property-search-backward` whose
-> nil-PREDICATE default (match values that are non-nil and **not** `equal`
-> to VALUE) contradicts the `equal`-matching used by the rest of the
-> library. Use [`tp-forward` / `tp-backward`](#tp-forward--tp-backward)
-> for tp's symmetric `equal`-matching search — they now expose PREDICATE
-> and NOT-CURRENT too — or call the Emacs primitives directly for raw
-> access. The wrappers keep working, but are marked obsolete (the byte
-> compiler warns on new callers).
-
-```elisp
-(tp-search-forward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) ; deprecated
-(tp-search-backward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) ; deprecated
-```
-
----
-
-#### `tp-forward` / `tp-backward`
-
-```elisp
-(tp-forward PROPERTY &optional VALUE OBJECT N PREDICATE NOT-CURRENT)
-(tp-backward PROPERTY &optional VALUE OBJECT N PREDICATE NOT-CURRENT)
-```
-
-Search forward/backward N times for text with PROPERTY.
-
-- **N** is the number of searches, defaulting to 1.
-- **VALUE** is `equal`-matched against directly present property values.
- Omitting VALUE matches any present value; explicit nil matches a present
- nil value. Missing-property spans never match.
-- Pass the unique public sentinel **`tp-any-value`** when wildcard matching
- is wanted and later positional arguments such as OBJECT or N are supplied.
-- **`tp-backward` mirrors `tp-forward`**: the same equal-matching semantics,
- in the opposite direction.
-- **OBJECT** can be a buffer or string; nil defaults to current buffer.
-- **PREDICATE** (new in 0.3.0) customizes matching: nil (the default) and t
- both keep the 0.2.0 `equal`-matching contract **exactly**; a function is
- called with `(VALUE PROP-VALUE)` and matches when it returns non-nil.
-- **NOT-CURRENT** (new in 0.3.0), when non-nil, skips a matching region
- containing point, mirroring the `text-property-search-*` primitives.
- Buffer path only; 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 **first N** runs
- where PROPERTY matches, counted from position 0 (point is not involved);
- `tp-backward` returns them from end to start.
-
-**Examples:**
-
-```elisp
-;; Find next text where 'marker equals t
-(with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char 1)
- (let ((match (tp-forward 'marker t)))
- (when match
- (prop-match-beginning match))))
-;; => 7
-
-;; Omitting VALUE matches the next directly present marker value
-(with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char 1)
- (let ((match (tp-forward 'marker)))
- (list (prop-match-beginning match) (prop-match-end match))))
-;; => (7 12)
-
-;; Explicit nil matches only a present nil value
-(let ((str (copy-sequence "abc")))
- (tp-set 1 2 '(marker nil) str)
- (tp-forward 'marker nil str))
-;; => ((1 2 nil))
-
-;; Backward mirrors forward: same value matching, opposite direction
-(with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char (point-max))
- (let ((match (tp-backward 'marker t)))
- (list (prop-match-beginning match) (prop-match-end match))))
-;; => (7 12)
-
-;; Find next text where 'type equals 'heading
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(type heading))
- (goto-char 1)
- (let ((match (tp-forward 'type 'heading)))
- (when match
- (prop-match-value match))))
-;; => heading
-
-;; Search in a string
-(let ((my-string (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward 'marker tp-any-value my-string 2))
-;; => ((0 5 t) (12 17 t))
-
-;; PREDICATE - match with a custom function instead of `equal'
-;; (called with VALUE and the region's property value)
-(with-temp-buffer
+(with-current-buffer (get-buffer-create "*tp-demo*")
+ (erase-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))))
-;; => (3 6) ; the first run whose size exceeds 15
-
-;; PREDICATE works on strings too (returns the first N matching runs)
-(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)))))
-;; => ((6 11 20))
-
-;; NOT-CURRENT - skip the matching region containing point
-(with-temp-buffer
- (insert "one two")
- (tp-set 1 4 '(mark t))
- (tp-set 5 8 '(mark t))
- (let (a b)
- (goto-char 2) ; inside the first mark region
- (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)))
-;; => (2 5) ; without NOT-CURRENT the current region matches at point
-```
-
----
-
-#### `tp-forward-do` / `tp-backward-do`
-
-```elisp
-(tp-forward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END PREDICATE NOT-CURRENT)
-(tp-backward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END PREDICATE NOT-CURRENT)
-```
-
-Search forward/backward TIMES times for text with PROPERTY and apply FUNCTION **only at the TIMES-th match**.
-
-Despite the `-do` suffix this is **not** a for-each — use
-[`tp-search-map`](#tp-search-map---apply-function-to-matched-text) to apply
-a function to *every* match.
-
-- **FUNCTION** receives `(TEXT &optional START END IDX)` where TEXT is the matched text, START and END are the positions of the match, and IDX is the 0-based match index. FUNCTION is called with as many of these arguments as it accepts. When FUNCTION returns a string, it replaces the matched text in the string or buffer.
-- **Replacements may change length in buffers** (the match is deleted and the replacement inserted). **Strings cannot change length in place**: a replacement of a different length signals an error; same-length replacements are applied in place.
-- **PROPERTY** is the text property to search for.
-- **VALUE** follows the presence-aware search contract: omitted means any
- present value; explicit nil means a present nil value. Use
- `tp-any-value` when later positional arguments are supplied.
-- **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 TIMES-th match. All-or-nothing: if fewer than TIMES matches exist, FUNCTION is not applied at all and the number of available matches is returned.
-- **START** and **END** define the search range; defaults are object start and end.
-- **PREDICATE** and **NOT-CURRENT** (new in 0.3.0) work as in
- [`tp-forward` / `tp-backward`](#tp-forward--tp-backward) and are applied
- to each underlying search; the defaults keep the 0.2.0 behavior exactly.
-- Returns the number of successful matches.
-
-**Examples:**
-
-```elisp
-;; Upcase only the last (2nd) match in string
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward-do #'upcase 'marker tp-any-value my-string 2)
- my-string)
-;; => "hello world HELLO" ; Only the 2nd match is upcased
-
-;; Search within a range (only matches in range 6-17)
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward-do #'upcase 'marker tp-any-value my-string 2 6 17)
- my-string)
-;; => "hello world hello" ; only 1 match in range 6-17, so the
-;; requested 2nd match does not exist: nothing is applied
-;; (all-or-nothing; the call still returns the count, 1)
-
-;; Using function with start and end parameters
-;; The function receives position info; use upcase to keep same length
-(let ((my-string (copy-sequence "hello world hello"))
- (match-info nil))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward-do
- (lambda (text start end)
- (setq match-info (list start end))
- (upcase text))
- 'marker tp-any-value my-string 2)
- (list my-string match-info))
-;; => ("hello world HELLO" (12 17)) ; Only the last match is transformed
-
-;; Backward search - upcase only the last (2nd) match
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-backward-do #'upcase 'marker tp-any-value my-string 2)
- my-string)
-;; => "HELLO world hello" ; The first match (last when searching backward) is upcased
-```
-
----
-
-#### `tp-search` - Search All Matches
-
-```elisp
-;; Buffer/string region
-(tp-search START END PROPERTY &optional VALUE OBJECT)
-
-;; Entire string
-(tp-search STRING PROPERTY &optional VALUE)
-```
-
-Search for all text with PROPERTY in a buffer/string range or entire string.
-
-Returns a list of (START END VALUE) for all matching regions.
-
-**Examples:**
-
-```elisp
-;; Find all 'marker properties in buffer range
-(with-temp-buffer
- (insert "Hello World Test Again")
- (tp-set 1 6 '(marker t))
- (tp-set 13 17 '(marker t))
- (tp-search 1 22 'marker))
-;; => ((1 6 t) (13 17 t))
-
-;; Find all 'type properties with value 'heading in string
-(let ((my-string (copy-sequence "Title Here Body Text")))
- (tp-set 0 10 '(type heading) my-string)
- (tp-search my-string 'type 'heading))
-;; => ((0 10 heading))
-
-;; Filter by value
-(with-temp-buffer
- (insert "Heading1 Body Heading2")
- (tp-set 1 9 '(type heading))
- (tp-set 10 14 '(type body))
- (tp-set 15 23 '(type heading))
- (tp-search 1 23 'type 'heading))
-;; => ((1 9 heading) (15 23 heading))
-```
-
----
-
-#### `tp-search-map` - Apply Function to Matched Text
-
-```elisp
-(tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END)
-```
-
-Apply FUNCTION to all matches of PROPERTY in OBJECT.
-
-- **FUNCTION** receives `(TEXT &optional START END IDX)` where:
- - TEXT is the matched text
- - START and END are the positions of the match
- - IDX is the 0-based index of the current match
- FUNCTION is called with as many of these arguments as it accepts. When
- FUNCTION returns a string, it replaces the matched text in the string or
- buffer.
-- **Replacements may change length in buffers** (the match is deleted and the
- replacement inserted). **Strings cannot change length in place**: a
- replacement of a different length signals an error; same-length
- replacements are applied in place.
-- **PROPERTY** is the text property to search for.
-- **VALUE** follows the presence-aware search contract: omitted means any
- present value; explicit nil means a present nil value. Use
- `tp-any-value` when later positional arguments are supplied.
-- **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.
-- Returns the number of matches processed.
-
-**Examples:**
-
-```elisp
-;; Upcase all markers in string
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-search-map #'upcase 'marker tp-any-value my-string)
- my-string)
-;; => "HELLO world HELLO"
-
-;; Search only in a range
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-search-map #'upcase 'marker tp-any-value my-string 0 10)
- my-string)
-;; => "HELLO world hello" ; Only first match in range 0-10
-
-;; Custom transformation with start, end, and index
-;; The function receives position info; use upcase to keep same length
-(let ((my-string (copy-sequence "aaa bbb ccc"))
- (positions nil))
- (tp-set 0 3 '(marker t) my-string)
- (tp-set 4 7 '(marker t) my-string)
- (tp-set 8 11 '(marker t) my-string)
- (tp-search-map
- (lambda (text start end idx)
- (push (list idx start end) positions)
- (upcase text))
- 'marker tp-any-value my-string)
- (list my-string (nreverse positions)))
-;; => ("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11)))
-
-;; Custom transformation without optional parameters
-(let ((my-string (copy-sequence "hello world")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-search-map #'upcase 'marker tp-any-value my-string)
- my-string)
-;; => "HELLO world"
-```
-
----
-
-## Native Text Property Compatibility
-
-Stage 3 makes the text-property boundary explicit, and Stage 5 adds overlay-aware character-property lookup. These APIs map to GNU Emacs primitives; tp does not manage overlay lifecycle.
-
-#### `tp-lookup-result` / `tp-lookup`
-
-`tp-lookup` returns a `tp-lookup-result` record. Use the generated accessors:
-
-| Accessor | Meaning |
-|----------|---------|
-| `tp-lookup-result-property` | requested property |
-| `tp-lookup-result-value` | resolved value |
-| `tp-lookup-result-present-p` | non-nil when the chosen source provides the property; a direct nil counts, while a nil alias follows Emacs' alias fallback |
-| `tp-lookup-result-source` | `:text-direct`, `:category`, `:alias`, `:default`, or `:absent` |
-| `tp-lookup-result-mode` | lookup mode |
-| `tp-lookup-result-object` | queried object |
-| `tp-lookup-result-position` | queried position |
-| `tp-lookup-result-overlay` | winning overlay for `:char` / `:char-source`, otherwise nil |
-
-Modes:
-
-| Mode | Behavior |
-|------|----------|
-| `:text-direct` | inspect only direct text properties with `text-properties-at`; explicit nil is present |
-| `:text-effective` | return `get-text-property`'s effective text value and report its text source |
-| `:text-source` | report the winning text source without overlays |
-| `:char` | overlay-aware `get-char-property-and-overlay` value; text fallback follows Emacs |
-| `:char-source` | like `:char`, plus `:overlay` source and overlay identity when an overlay wins |
-
-```elisp
-;; Direct lookup distinguishes explicit nil from absence
-(let ((str (copy-sequence "ab")))
- (put-text-property 0 1 'state nil str)
- (let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct))
- (absent-result (tp-lookup 1 'state :object str :mode :text-direct)))
- (list (list (tp-lookup-result-present-p nil-result)
- (tp-lookup-result-value nil-result)
- (tp-lookup-result-source nil-result))
- (list (tp-lookup-result-present-p absent-result)
- (tp-lookup-result-value absent-result)
- (tp-lookup-result-source absent-result)))))
-;; => ((t nil :text-direct) (nil nil :absent))
-
-;; Source-aware lookup explains category/default/alias/direct text sources
-(let* ((str (copy-sequence "a"))
- (category (make-symbol "tp-doc-category")))
- (put category 'state 'category-value)
- (put-text-property 0 1 'category category str)
- (let ((result (tp-lookup 0 'state :object str :mode :text-source)))
- (list (tp-lookup-result-value result)
- (tp-lookup-result-source result))))
-;; => (category-value :category)
-
-;; Character-source lookup reports the winning overlay identity
-(with-temp-buffer
- (insert "x")
- (let ((low (make-overlay 1 2))
- (high (make-overlay 1 2)))
- (overlay-put low 'priority 1)
- (overlay-put low 'state 'low)
- (overlay-put high 'priority 10)
- (overlay-put high 'state 'high)
- (let ((result (tp-lookup 1 'state :mode :char-source)))
- (list (tp-lookup-result-value result)
- (tp-lookup-result-source result)
- (eq (tp-lookup-result-overlay result) high)))))
-;; => (high :overlay t)
-```
-
-`tp-lookup` reports overlay winners, but overlay creation, deletion, movement, priority management, and lifecycle remain native Emacs responsibilities.
-
-#### `tp-property-change`
-
-`tp-property-change` wraps `next-property-change`, `previous-property-change`, `next-single-property-change`, and `previous-single-property-change`.
-
-```elisp
-(tp-property-change POSITION :object OBJECT :limit LIMIT :direction :next)
-(tp-property-change POSITION :property PROPERTY :object OBJECT :limit LIMIT :direction :previous)
-```
-
-Omit `:property` for any property change. Pass `:property` for a single-property change. `:direction` is `:next` or `:previous`.
-
-#### `tp-property-any` / `tp-property-not-all`
-
-These are thin wrappers over Emacs primitives:
-
-```elisp
-(tp-property-any START END PROPERTY VALUE &optional OBJECT)
-(tp-property-not-all START END PROPERTY VALUE &optional OBJECT)
-```
-
-They preserve Emacs behavior exactly, including explicit nil matching.
-
-#### `tp-with-mutation-policy`
-
-`tp-with-mutation-policy` makes modified/read-only behavior explicit for buffer mutations:
-
-| Policy | Behavior |
-|--------|----------|
-| `(:modified :ordinary :read-only :respect)` | normal Emacs mutation; read-only text can signal |
-| `(:modified :ordinary :read-only :inhibit)` | bind `inhibit-read-only` and record ordinary modified/undo state |
-| `(:modified :silent :read-only :inhibit)` | bind `inhibit-read-only` and use `with-silent-modifications` |
-
-`(:modified :silent :read-only :respect)` is rejected because silent modification cannot be combined with respecting read-only text.
-
-Insert/copy/yank/stickiness/narrowing/indirect-buffer behavior is delegated directly to Emacs. tp does not provide wrappers for those operations; use the native primitives (`insert`, `insert-and-inherit`, `copy-sequence`, `substring`, `insert-for-yank`, narrowing commands, and indirect buffers).
-
----
-
-## The Property Layer System
-
-The **property layer system** is tp.el's innovative feature that allows stacking multiple sets of properties on the same text region. Only the **top layer** is visible, but lower layers are preserved and can be revealed through rotation or pinning.
-
-### Custom Text Properties
-
-Custom text properties is a **general-purpose feature** provided by tp.el. After defining with `define-tp`, they can be set using core functions like `tp-set`/`tp-reset`/`tp-add`.
-
-#### Core Features
-
-1. **Mixed Use with Built-in Properties**: Custom text properties can be seamlessly mixed with built-in Emacs text properties (such as `face`, `display`, `help-echo`, etc.).
-
-2. **Automatic Merging of Duplicate Properties**: In a single setting operation, if the same property (e.g., `face`) is specified multiple times, they are automatically merged rather than simply overwritten.
-
-```elisp
-;; Define a custom text property
-(define-tp tp-highlight ()
- '(face (:background "yellow")))
-
-;; Mixed use with built-in properties
-(tp-set 1 10 '(tp-highlight t face bold help-echo "tip"))
-;; Result: Has tp-highlight's background color, bold style, and help-echo property
-
-;; Automatic merging of duplicate properties example
-(tp-set "emacs"
- 'face 'bold
- 'face '(:background "green")
- 'face '(:foreground "red"))
-;; Result: face is ((:foreground "red") (:background "green") bold)
-;; Three face properties stack into one face list, most recent first
-
-;; Later values override earlier ones for the same sub-property
-(tp-set "emacs"
- 'face '(:foreground "red")
- 'face '(:foreground "yellow"))
-;; Result: foreground is "yellow"
-
-;; Use with tp-palette layer
-(tp-set "emacs"
- 'tp-palette 'info
- 'face '(:foreground "red"))
-;; Result: tp-palette's face is merged with (:foreground "red")
-```
-
-#### Custom Text Property Groups
-
-Using `define-tps`, you can define multiple related text property groups that can be used individually or as a group.
-
----
-
-### Text Property Layers
-
-Text property layers is a **unique feature** of tp.el that requires specific functions (`tp-put-layer`/`tp-push-layer`) to set and use.
-
-#### Core Features
-
-1. **Layer-Related Properties**: When set using `tp-push-layer`/`tp-put-layer`, layer-related properties (`tp-name`, `tp-layers`) are automatically introduced to support layer stacking and operations.
-
-2. **Layer Stacking Mechanism**: Multiple sets of properties can be stacked on the same text region, with only the top layer visible while lower layers are preserved.
-
-3. **Rich Layer Operations**: Supports various layer operations such as rotation, deletion, merging, etc.
-
-```elisp
-;; Define a text property (can be used as custom property or layer)
-(define-tp tp-highlight ()
- '(face (:background "yellow")))
-
-;; Use as regular custom text property (no layer properties)
-(tp-set 1 10 '(tp-highlight t))
-;; Result: Only face property, no tp-name
-
-;; Use as text property layer (introduces layer-related properties)
-(tp-push-layer 1 10 'tp-highlight)
-;; Result: Both face and tp-name properties, supports layer operations
-```
-
-#### When to Use Which
-
-| Scenario | Recommended Method | Description |
-|----------|-------------------|-------------|
-| Simple property setting | `tp-set`/`tp-reset`/`tp-add` | When you only need to set text properties without layer stacking |
-| Mixed with built-in properties | `tp-set`/`tp-reset`/`tp-add` | Custom properties can be seamlessly mixed with built-in properties |
-| Need layer stacking | `tp-push-layer`/`tp-put-layer` | When you need to stack multiple sets of properties on the same text region |
-| Need layer operations | `tp-push-layer`/`tp-put-layer` | When you need to perform rotation, deletion, and other layer operations |
-
-### Property Layer Concept
-
-```
-┌─────────────────────────────┐
-│ TOP LAYER (visible) │ ← idx=0, What you see
-├─────────────────────────────┤
-│ Middle Layer (hidden) │ ← idx=1, Preserved
-├─────────────────────────────┤
-│ Bottom Layer (hidden) │ ← idx=-1, Preserved
-└─────────────────────────────┘
-```
-
-### Property Layer Definition
-
-#### `define-tp` / `define-tps` - Define Custom Text Properties
-
-> Since 0.3.0 the prefix-conforming aliases `tp-define-layer` (for
-> `define-tp`), `tp-define-group` (for `define-tps`) and
-> `tp-define-palette` (for `define-tp-palette`) are the canonical names
-> going forward — they make the macros discoverable via `C-h f tp-...`.
-> The historical names are permanent aliases and will never be removed;
-> this README's examples keep using them.
-
-##### `define-tp` - Define Single Custom Text Property (Layer)
-
-Define a custom text property. The name does not need to be quoted. The ARGLIST is **mandatory in every format**: `()` for non-parameterized layers (including the reactive keyword format), `(ARG1 ARG2 ...)` with any number of parameter symbols for parameterized layers. Supports three formats:
-
-**Format 1 - Non-parameterized (empty argument list, simple properties):**
-
-```elisp
-(define-tp tp-bold ()
- '(face bold))
-
-;; Usage:
-(tp-set "emacs" 'tp-bold t)
-(tp-set 0 5 '(tp-bold t) "emacs")
-```
-
-**Format 2 - Parameterized (with one or more arguments):**
-
-```elisp
-(define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
-
-;; Usage:
-(tp-set "emacs" 'tp-space 2)
-(tp-set 0 5 '(tp-space 2) "emacs")
-```
-
-Since 0.3.0 the arglist may declare **any number of parameters**. The call
-specs accept the arguments flat — `(LAYER ARG1 ... ARGN)` — or wrapped in
-one list — `(LAYER (ARG1 ... ARGN))` — and both work in `tp-set` and
-`tp-put-layer`:
-
-```elisp
-(define-tp tp-colors (fg bg)
- `(face (:foreground ,fg :background ,bg)))
-
-;; Whole-string form: arguments follow the layer name
-(tp-set "hello" 'tp-colors "red" "blue")
-;; => #("hello" 0 5 (face (:foreground "red" :background "blue")))
-
-;; Region form, wrapped argument list plus extra properties
-(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)))
-;; => ((:foreground "red" :background "blue") "tip")
-
-;; tp-put-layer spec
-(with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(tp-colors "white" "black") 0)
- (tp-at 1 'face))
-;; => (:foreground "white" :background "black")
-
-;; Wrong-arity calls signal a clear error naming the layer and both counts
-(tp-set "hello" 'tp-colors "red")
-;; error: tp layer tp-colors takes 2 argument(s), got 1
-```
-
-Parameterized groups (`define-tps`) accept multiple parameters the same
-way; the `(GROUP ARG1 ... ARGN)` and `(GROUP (ARG1 ... ARGN))` specs work
-in the `tp-set` family. Note: `$`-symbols in parameterized bodies resolve
-to their variables' current values at expansion time — parameterized
-layers are **not** reactive.
-
-**Format 3 - With reactive features (:props, :data, :compute, :watch, :transform):**
-
-```elisp
-(define-tp my-reactive-layer ()
- :props '(face (:foreground $my-color) help-echo $status-note)
- :data '((my-color . "red") (status . "active"))
- :compute '((status-note (lambda () (concat "status: " status))))
- :watch '((my-color (lambda (new old layer) (message "Color changed!"))))
- :transform (lambda (text) (upcase text)))
-
-;; Usage:
-(tp-push-layer 1 10 'my-reactive-layer)
-;; Changing the variable automatically updates the text
-(setq my-color "blue")
-```
-
-**Reactive Keywords:**
-
-- **:props** - Property list where `$`-prefixed symbols are reactive variables
-- **:data** - Additional reactive variables (can include initial values)
-- **:compute** - Computed properties that derive values from other variables
-- **:watch** - Watchers that execute callbacks when variables change
-- **:transform** - Transform function to process `tp-text` values before display
-
-Note: the values of `:props`, `:data`, `:compute`, and `:watch` must be
-**quoted** (they are evaluated when the layer is defined); `:transform`
-takes a function.
-
-##### `define-tps` - Define Custom Text Property Group (Layer Group)
-
-Define multiple related custom text properties. The name does not need to be quoted. As with `define-tp`, the ARGLIST is **mandatory**: `()` for non-parameterized groups, `(ARG1 ARG2 ...)` for parameterized ones (any number of parameters since 0.3.0). Properties in the group can be used individually or with the group name to set multiple layers.
-
-**Format 1 - Non-parameterized (empty argument list):**
-
-```elisp
-(define-tps tp-moon-phases ()
- '(display "🌑")
- '(display "🌕"))
-
-;; Usage:
-(tp-set 1 6 'tp-moon-phases)
-```
-
-**Format 2 - Parameterized (with single argument):**
-
-```elisp
-;; First define parameterized individual layers
-(define-tp tp-color1 (color)
- `(face (:foreground ,color)))
-(define-tp tp-color2 (color)
- `(face (:foreground ,color)))
-(define-tp tp-bg ()
- '(face (:background "green")))
-
-;; Define parameterized layer group referencing the layers above
-(define-tps tp-themed-status (color)
- `(tp-color1 ,color) ;; Use group parameter
- '(tp-color2 "red") ;; Use fixed parameter
- 'tp-bg) ;; Reference non-parameterized layer
-
-;; Usage - sets multi-layer properties:
-(tp-set "emacs" 'tp-themed-status "orange")
-;; Result: Three layers stacked, tp-color1 is top layer with "orange" color
-```
-
-**Supported layer definition formats within the group:**
-
-1. **Anonymous layers** (named as NAME-0, NAME-1, etc.):
- ```elisp
- '(face (:background "yellow"))
- ```
-
-2. **Named layers with cons-cell** (named as NAME-suffix):
- ```elisp
- '("highlight" . (face (:background "yellow")))
- ```
-
-3. **Named layers with :props keyword**:
- ```elisp
- '("highlight" :props (face (:background "yellow")))
- ```
-
-4. **Named layers with reactive features** (:props, :data, :watch, :compute):
- ```elisp
- '("reactive" :props (face (:foreground $my-color))
- :data ((my-color . "red"))
- :watch ((my-color (lambda (new old layer) (message "Changed!")))))
- ```
-
-**Examples:**
-
-```elisp
-;; Define non-parameterized custom text property
-(define-tp tp-highlight ()
- '(face (:background "yellow")))
-
-;; Define parameterized custom text property
-(define-tp tp-color (color)
- `(face (:foreground ,color)))
-
-;; Define property group
-(define-tps tp-status ()
- '("success" . (face (:foreground "green")))
- '("warning" . (face (:foreground "orange")))
- '("error" . (face (:foreground "red"))))
-
-;; Use custom text properties
-(tp-set "Hello" 'tp-highlight t) ; Non-parameterized
-(tp-set "Hello" 'tp-color "blue") ; Parameterized
-(tp-set 1 6 'tp-status) ; Use layer group
-
-;; Use as layers (supports stacking operations)
-(tp-push-layer 1 10 'tp-highlight)
-```
-
-The first layer in the definition is the top layer (visible by default).
-
-**More Examples:**
-
-```elisp
-;; Define status layers, then group them
-(progn
- (tp-layer-reset)
- (define-tp highlight ()
- '(face (:background "yellow" :foreground "black")))
- (define-tp error ()
- '(face (:background "red" :foreground "white")))
- (define-tp info ()
- '(face (:background "blue" :foreground "white")))
- (define-tps status-colors ()
- 'highlight 'error 'info)
- (length (tp-group-props 'status-colors)))
-;; => 3
-
-;; Define a layer group with named layers
-(progn
- (tp-layer-reset)
- (define-tps moon-phases ()
- '("new" . (display "🌑"))
- '("waxing-crescent" . (display "🌒"))
- '("first-quarter" . (display "🌓"))
- '("full" . (display "🌕")))
- (tp-layer-props 'moon-phases-full))
-;; => (display "🌕")
-
-;; Parameterized layer group referencing other defined layers
-(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) ;; Use group parameter
- '(tp-test-l2 "red") ;; Use fixed parameter
- 'tp-test-l3) ;; Reference non-parameterized layer
- (tp-set "emacs" 'tp-test-group1 "orange"))
-;; => #("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))))
-;; (top-level property print order may differ across Emacs versions;
-;; the tp-layers stack order itself is stable)
-```
-
----
-
-#### `tp-layer-props` / `tp-group-props`
-
-```elisp
-(tp-layer-props LAYER-NAME &optional INCLUDE-TP-NAME)
-(tp-group-props GROUP-NAME &optional INCLUDE-TP-NAME)
-```
-
-Get properties for a layer or all layers in a group.
-
-By default the result contains only the layer's own properties. When
-INCLUDE-TP-NAME is non-nil, a `tp-name LAYER-NAME` entry is appended
-(the form used internally by the layer stack). Exception: layers with
-registered reactive dependencies always include `tp-name` — the
-reactive engine uses it to locate and re-render their regions.
-
-**Examples:**
-
-```elisp
-;; Get layer properties (no tp-name by default)
-(progn
- (tp-layer-reset)
- (define-tp my-layer ()
- '(face bold help-echo "tip"))
- (list (tp-layer-props 'my-layer)
- (tp-layer-props 'my-layer t)))
-;; => ((face bold help-echo "tip")
-;; (face bold help-echo "tip" tp-name my-layer))
-
-;; Get group properties
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tps my-group ()
- 'layer1 'layer2)
- (length (tp-group-props 'my-group)))
-;; => 2
-```
-
----
-
-#### `tp-layer-props-with-args` / `tp-group-props-with-args` / `tp-layer-arglist`
-
-```elisp
-(tp-layer-props-with-args LAYER-NAME ARGS &optional INCLUDE-TP-NAME)
-(tp-group-props-with-args GROUP-NAME ARGS &optional INCLUDE-TP-NAME)
-(tp-layer-arglist LAYER-NAME)
-```
-
-Introspection for **parameterized** layers and groups (new in 0.3.0):
-
-- **`tp-layer-props-with-args`** expands a parameterized layer with ARGS,
- a list of values bound positionally to the layer's parameters. Extra
- values are ignored; fewer values than parameters signal a wrong-arity
- error. Returns a fresh copy (mutating it cannot corrupt the registry),
- or nil for non-parameterized or undefined layers. The existing
- single-argument `tp-layer-props-with-arg` (note the one-character name
- difference) remains as a thin `(list ARG)` wrapper.
-- **`tp-group-props-with-args`** is the group counterpart, returning the
- list of expanded per-layer plists; `tp-group-props-with-arg` remains
- as the single-argument convenience.
-- **`tp-layer-arglist`** returns a copy of the layer's parameter list,
- or nil when LAYER-NAME is not a parameterized layer.
-
-**Examples:**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp tp-colors (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (tp-layer-props-with-args 'tp-colors '("red" "blue")))
-;; => (face (:foreground "red" :background "blue"))
-
-;; The parameter list itself
-(tp-layer-arglist 'tp-colors)
-;; => (fg bg)
-
-;; Groups expand to one plist per layer
-(progn
- (define-tps tp-badge (fg bg)
- `(tp-colors ,fg ,bg)
- '(face bold))
- (tp-group-props-with-args 'tp-badge '("white" "black")))
-;; => ((face (:foreground "white" :background "black")) (face bold))
-
-;; Too few arguments signal the same clear arity error as tp-set
-(tp-layer-props-with-args 'tp-colors '("red"))
-;; error: tp layer tp-colors takes 2 argument(s), got 1
-```
-
----
-
-#### `tp-describe-layer` - Describe a Layer
-
-```elisp
-(tp-describe-layer NAME) ; interactive
-```
-
-Pop a help buffer describing layer NAME (with completion over all
-registered layers when called interactively). The buffer shows the
-storage format (flat / unified / parameterized / reactive), the raw
-stored body, the expanded properties (or a placeholder for parameterized
-layers, which need arguments), the parameter list, the reactive
-variables the layer depends on, whether a transform is registered, and
-the group that generated the layer, if any.
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp tp-colors (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (tp-describe-layer 'tp-colors))
-;; Pops a *Help* buffer:
-;; tp-colors is a tp layer.
-;;
-;; Storage format: parameterized
-;; Arguments: (fg bg)
-;; Stored body: `(face (:foreground ,fg :background ,bg))
-;; Expanded props: parameterized layer: expand with `tp-layer-props-with-args'
-;; Reactive deps: none
-;; Transform: no
-```
-
----
-
-#### `tp-undefine-layer` / `tp-undefine-group`
-
-```elisp
-(tp-undefine-layer NAME)
-(tp-undefine-group NAME)
-```
-
-Remove layer or group definition.
-
-**Examples:**
-
-```elisp
-;; Undefine a layer
-(progn
- (tp-layer-reset)
- (define-tp temp-layer () '(face bold))
- (tp-undefine-layer 'temp-layer)
- (tp-layer-props 'temp-layer))
-;; => nil
-
-;; Undefine a group
-(progn
- (tp-layer-reset)
- (define-tp l1 () '(face bold))
- (define-tps my-group ()
- 'l1)
- (tp-undefine-group 'my-group)
- (assoc 'my-group tp-layer-groups))
-;; => nil
-```
-
----
-
-#### `tp-layer-reset`
-
-```elisp
-(tp-layer-reset)
-```
-
-Clear all layer and group definitions, including all reactive dependencies and watchers.
-
-**Examples:**
-
-```elisp
-(progn
- (define-tp test-layer () '(face bold))
- (tp-layer-reset)
- (list tp-layer-alist tp-layer-groups))
-;; => (nil nil)
-```
-
----
-
-#### `tp-reactive-reset`
-
-```elisp
-(tp-reactive-reset)
-```
-
-Clear all reactive text property watchers and dependencies, without affecting layer definitions.
-
-This is useful when you want to remove all reactive bindings but keep the layer definitions intact.
-
-**Examples:**
-
-```elisp
-;; Define a reactive layer
-(progn
- (defvar my-reactive-color "red")
- (define-tp reactive-layer ()
- :props '(face (:foreground $my-reactive-color)))
- ;; Clear reactive bindings only
- (tp-reactive-reset)
- ;; Layer still exists, but changing my-reactive-color no longer updates it
- (tp-layer-props 'reactive-layer))
-;; => (face (:foreground "red"))
-```
-
----
-
-### Property Layer Placement
-
-> ⚠️ **String forms of stack operations mutate in place.** Unlike `tp-set`,
-> which returns a **new** propertized string, the string form of every stack
-> mutator (`tp-put-layer`, `tp-push-layer`, `tp-pop-layer`, `tp-delete-layer`,
-> `tp-move-layer`, `tp-raise-layer`, `tp-lower-layer`, `tp-rotate-layer`,
-> `tp-pin-layer`, `tp-switch-layer`, `tp-hide-layer`, `tp-show-layer`,
-> `tp-merge-layers`, `tp-flatten-layers`, `tp-add-to-layers`,
-> `tp-add-to-all-layers`) modifies STRING **destructively**. Never pass a
-> string literal or a shared string you do not own — use `copy-sequence`
-> first. Unifying this with `tp-set`'s copy semantics is on the 0.4 ledger.
-
-**Return values (0.3.0):** `tp-put-layer` / `tp-push-layer` return OBJECT
-when one was given (the string itself in string forms), else
-`(START . END)`. Every other stack mutator returns the **number of property
-runs it modified**; a missing layer name or index never signals — unmatched
-runs are silently left alone, and a return value of 0 means nothing matched.
-
-#### `tp-put-layer` - Set Layer at Index
-
-```elisp
-;; Buffer/string region
-(tp-put-layer START END LAYER IDX OBJECT NOERROR)
-
-;; Entire string
-(tp-put-layer STRING LAYER IDX NOERROR)
-```
-
-Set layer(s) at a specific index position in the layer stack.
-
-- `IDX = 0`: Top (visible layer)
-- `IDX = -1`: Bottom
-- Other values insert at that position
-
-LAYER accepts several specs:
-
-- a layer name defined with `define-tp`: `'highlight`
-- an inline property plist (no `define-tp` needed): `'(face bold help-echo "tip")`
-- a list of layer names (the first name ends up on top): `'(layer-a layer-b)`
-- a parameterized layer call: `'(tp-color "red")` — multi-argument layers
- work too: `'(tp-colors "white" "black")`
-
-**Stack model:** only the top layer's properties are the visible text
-properties; lower layers are stored in the `tp-layers` text property until
-they are raised, rotated, or flattened.
-
-**NOERROR (new in 0.3.0):** a LAYER naming an undefined layer or group
-normally signals an error. With NOERROR non-nil the call returns nil
-instead and modifies nothing — handy when applying layers that may not be
-defined yet. `tp-push-layer` accepts the same trailing NOERROR.
-
-**Examples:**
-
-```elisp
-;; Put base layer at top
-(progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-at 1 'tp-name)))
-;; => base
-
-;; Put highlight at index 1 (below top)
-(progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-put-layer 1 10 'highlight 1)
- (tp-layer-count 1 10)))
-;; => 2
-
-;; Put layer at bottom
-(progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp info () '(face (:foreground "blue")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-put-layer 1 10 'info -1)
- (tp-layer-top 1 10)))
-;; => base ; info is at bottom, base is visible
-
-;; Inline plist - no define-tp needed
-(with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(face bold help-echo "tip") 0)
- (list (tp-at 1 'face) (tp-at 1 'help-echo)))
-;; => (bold "tip")
-
-;; List of layer names - layer-a ends up on top
-(progn
- (tp-layer-reset)
- (define-tp layer-a () '(face bold))
- (define-tp layer-b () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(layer-a layer-b) 0)
- (list (tp-at 1 'face) (tp-layer-list 1 10))))
-;; => (bold (layer-a layer-b))
-
-;; Parameterized layer call
-(progn
- (tp-layer-reset)
- (define-tp tp-color (color)
- `(face (:foreground ,color)))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(tp-color "red") 0)
- (tp-at 1 'face)))
-;; => (:foreground "red")
-
-;; NOERROR - an undefined layer name returns nil instead of signaling
-(with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'no-such-layer 0 nil t))
-;; => nil ; nothing modified
-```
-
----
-
-#### `tp-push-layer` - Push Layer to Top
-
-```elisp
-;; Buffer/string region
-(tp-push-layer START END LAYER OBJECT NOERROR)
-
-;; Entire string
-(tp-push-layer STRING LAYER NOERROR)
-```
-
-Push a layer to the top of the stack (equivalent to `tp-put-layer ... 0`).
-NOERROR (new in 0.3.0) works as in
-[`tp-put-layer`](#tp-put-layer---set-layer-at-index): an undefined LAYER
-returns nil instead of signaling.
-
-**Examples:**
-
-```elisp
-;; Push base layer first
-(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-at 1 'tp-name)))
-;; => base
-
-;; Push highlight on top (now visible)
-(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-at 1 'tp-name)))
-;; => highlight
-
-;; The top layer's props are visible; lower layers wait in `tp-layers'
-(progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (list :face (tp-at 1 'face)
- :top (tp-layer-top 1 10)
- :layers (tp-layer-list 1 10)
- :hidden (length (tp-at 1 'tp-layers)))))
-;; => (:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2)
-```
-
----
-
-### Property Layer Deletion
-
-#### `tp-delete-layer` - Delete Layer by Name/Index
-
-```elisp
-;; Buffer/string region
-(tp-delete-layer START END LAYER-NAME/IDX OBJECT)
-
-;; Entire string
-(tp-delete-layer STRING LAYER-NAME/IDX)
-```
-
-Delete a layer from anywhere in the stack by name or index.
-
-**Examples:**
-
-```elisp
-;; Remove by name
-(progn
- (tp-layer-reset)
- (define-tp highlight () '(face (:background "yellow")))
- (define-tp base () '(face default))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (tp-delete-layer 1 10 'highlight)
- (tp-at 1 'tp-name)))
-;; => base
-
-;; Remove top layer (idx=0)
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-delete-layer 1 10 0)
- (tp-at 1 'tp-name)))
-;; => layer1
-
-;; Remove bottom layer
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-delete-layer 1 10 -1)
- (tp-layer-count 1 10)))
-;; => 1
-```
-
----
-
-#### `tp-pop-layer` - Pop Top Layer
-
-```elisp
-;; Buffer/string region
-(tp-pop-layer START END OBJECT)
-
-;; Entire string
-(tp-pop-layer STRING)
-```
-
-Remove the top layer (equivalent to `tp-delete-layer ... 0`).
-
-**Examples:**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-pop-layer 1 10)
- (tp-at 1 'tp-name)))
-;; => layer1
-```
-
----
-
-### Property Layer Movement
-
-#### `tp-move-layer` - Move Layer to Position
-
-```elisp
-;; Buffer/string region
-(tp-move-layer START END FROM-ID TO-IDX OBJECT)
-
-;; Entire string
-(tp-move-layer STRING FROM-ID TO-IDX)
-```
-
-Move a layer from one position to another in the layer stack.
-
-- `FROM-ID` identifies the layer to move: an integer index or a layer name symbol
-- `TO-IDX` is the target position (integer index)
-- Index 0 means top (visible), -1 means bottom
-- Both indices refer to positions before the move
-
-This is the generic layer movement function used internally by `tp-raise-layer`, `tp-rotate-layer`, `tp-pin-layer`, and `tp-switch-layer`.
-
-**Examples:**
-
-```elisp
-;; Move layer at index 2 to index 0 (top)
-(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)
- ;; Stack: layer3 (0), layer2 (1), layer1 (2)
- (tp-move-layer 1 10 2 0)
- (tp-layer-top 1 10)))
-;; => layer1
-
-;; Move layer by name to bottom
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- ;; Stack: layer2 (top), layer1 (bottom)
- (tp-move-layer 1 10 'layer2 -1)
- (tp-layer-top 1 10)))
-;; => layer1
-
-;; Move on string
-(let ((str (copy-sequence "Hello")))
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer str 'layer1)
- (tp-push-layer str 'layer2)
- ;; layer2 is on top
- (tp-move-layer str 'layer1 0)
- (tp-at 0 'tp-name str))
-;; => layer1
-```
-
----
-
-#### `tp-raise-layer` - Move Layer Up/Down
-
-```elisp
-;; Buffer/string region
-(tp-raise-layer START END IDX/LAYER-NAME N OBJECT)
-
-;; Entire string
-(tp-raise-layer STRING IDX/LAYER-NAME N)
-```
-
-Raise a layer by N positions. Positive N moves toward top, negative moves toward bottom.
-
-**Examples:**
-
-```elisp
-;; Move layer1 up by 2 positions (to top)
-(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)
- ;; Stack: layer3 (top), layer2, layer1 (bottom)
- (tp-raise-layer 1 10 'layer1 2)
- (tp-layer-top 1 10)))
-;; => layer1
-
-;; Move layer at idx 0 down by 1 position
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- ;; Stack: layer2 (idx 0), layer1 (idx 1)
- (tp-raise-layer 1 10 0 -1)
- (tp-layer-top 1 10)))
-;; => layer1
-```
-
----
-
-#### `tp-lower-layer` - Mirror of `tp-raise-layer`
-
-```elisp
-;; Buffer/string region
-(tp-lower-layer START END IDX/LAYER-NAME N OBJECT)
-
-;; Entire string
-(tp-lower-layer STRING IDX/LAYER-NAME N)
-```
-
-Lower a layer by N positions (new in 0.3.0). The mirror image of
-`tp-raise-layer`: positive N moves the layer down toward the bottom,
-negative N moves it up. N defaults to 1, and the resulting position is
-clamped to the stack. Returns the number of property runs modified.
-
-**Examples:**
-
-```elisp
-;; Lower the top layer by one position
-(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)
- ;; Stack: layer3 (top), layer2, layer1 (bottom)
- (tp-lower-layer 1 10 'layer3 1)
- ;; Stack: layer2 (top), layer3, layer1 (bottom)
- (list (tp-layer-top 1 10) (tp-layer-list 1 10))))
-;; => (layer2 (layer2 layer3 layer1))
-```
-
----
-
-#### `tp-rotate-layer` - Cycle Layers
-
-```elisp
-;; Buffer/string region (canonical order, OBJECT last - new in 0.3.0)
-(tp-rotate-layer START END DIRECTION &optional COUNT OBJECT)
-
-;; Entire string
-(tp-rotate-layer STRING DIRECTION COUNT)
-
-;; Buffer/string region (legacy order, kept working forever)
-(tp-rotate-layer START END OBJECT)
-```
-
-Rotate layers by COUNT steps, preserving their relative order.
-
-- **DIRECTION** is `down` or nil to move the top layer to the bottom (the
- historical behavior), or `up` to bring the bottom layer to the top; any
- other value signals an error.
-- **COUNT** is the number of rotation steps, defaulting to 1; a COUNT below
- 1 rotates nothing. Hidden layers rotate with the rest of the stack.
-- Returns the number of property runs modified.
-
-The two region orders are told apart by the third argument: the symbols
-`up` / `down` are never valid OBJECTs, so `(tp-rotate-layer 1 5 'up)`
-unambiguously selects the canonical `(START END DIRECTION [COUNT]
-[OBJECT])` order — no nil OBJECT placeholder needed. Any other third
-argument (a buffer, a string, or nil for the current buffer) selects the
-legacy `(START END OBJECT [DIRECTION] [COUNT])` order, which keeps working.
-
-**Examples:**
-
-```elisp
-;; Stack: highlight (top) -> base (bottom)
-(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)
- ;; Stack: highlight (top) -> base (bottom)
- (tp-rotate-layer 1 10)
- ;; Stack: base (top) -> highlight (bottom)
- (tp-layer-top 1 10)))
-;; => base
-
-;; Canonical order: `up' brings the bottom layer to the top
-(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)
- ;; Stack: layer3 (top), layer2, layer1 (bottom)
- (tp-rotate-layer 1 10 'up)
- (tp-layer-list 1 10)))
-;; => (layer1 layer3 layer2)
-
-;; COUNT rotates several steps at once
-(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-rotate-layer 1 10 'down 2)
- (tp-layer-list 1 10)))
-;; => (layer1 layer3 layer2)
-```
-
----
-
-#### `tp-pin-layer` - Pin Layer to Top
-
-```elisp
-;; Buffer/string region
-(tp-pin-layer START END IDX/LAYER-NAME OBJECT)
-
-;; Entire string
-(tp-pin-layer STRING IDX/LAYER-NAME)
-```
-
-Move a layer to the top of the stack. **One-shot**: despite the name,
-nothing stays pinned — this is a single move to index 0, and nothing
-prevents a later `tp-push-layer` or `tp-put-layer` from covering the moved
-layer again.
-
-**Examples:**
-
-```elisp
-;; Make 'base the top layer
-(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)
- ;; highlight is on top
- (tp-pin-layer 1 10 'base)
- (tp-layer-top 1 10)))
-;; => base
-```
-
----
-
-#### `tp-switch-layer` - Switch Two Layers
-
-```elisp
-;; Buffer/string region
-(tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT)
-
-;; Entire string
-(tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)
-```
-
-Swap positions of two layers.
-
-**Examples:**
-
-```elisp
-;; Switch layer1 and layer2
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- ;; layer2 is on top
- (tp-switch-layer 1 10 'layer1 'layer2)
- ;; Now layer1 is on top
- (tp-layer-top 1 10)))
-;; => layer1
-```
-
----
-
-### Property Layer Visibility
-
-#### `tp-hide-layer` / `tp-show-layer` - Hide and Show Layers
-
-```elisp
-;; Buffer/string region
-(tp-hide-layer START END NAME OBJECT)
-(tp-show-layer START END NAME OBJECT)
-
-;; Entire string
-(tp-hide-layer STRING NAME)
-(tp-show-layer STRING NAME)
-```
-
-Hide a layer without removing it, and make it render again (new in 0.3.0).
-NAME identifies the layer: a layer name symbol or an integer index into the
-full stack, hidden layers included (0 = top, -1 = bottom).
-
-**The visibility model:**
-
-- 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 does not render. 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 is hidden the text renders bare (only the
- `tp-layers` bookkeeping property remains — not even `tp-name` renders)
- while all layers stay queryable.
-- A hidden layer **keeps receiving reactive updates** while hidden, so
- `tp-show-layer` always reveals current values (see
- [Layer-Buffer Registry & Lifecycle](#layer-buffer-registry--lifecycle)).
-- `tp-flatten-layers` merges only visible layers, and `tp-merge-layers`
- excludes hidden matched layers' properties — hiding can never leak (see
- [Property Layer Merging](#property-layer-merging)).
-- Hiddenness is stored as a `tp-hidden` flag inside the layer's plist in
- `tp-layers` stack storage, so `tp-hidden` is a reserved property name
- inside layers, like `tp-name`.
-- While any layer is hidden, direct properties are a render cache for the
- first visible managed layer. Definition/reactive refresh has enough
- ownership context to preserve native edits on that visible layer. A normal
- stack decode/write remains strict and signals `tp-layer-conflict` before
- changing state when the cache differs; properties appearing while every
- layer is hidden are always a conflict.
-
-Both functions return the number of property runs modified. A NAME matching
-no layer never signals, and hiding an already-hidden layer (or showing a
-visible one) is a silent no-op — 0 means nothing changed.
-
-**Examples:**
-
-```elisp
-;; Hiding the top layer reveals the one below; the stack is intact
-(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))))
-;; => (:visible base :face default :count 2 :layers (highlight base))
-
-;; With every layer hidden the text renders bare
-(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)
- (list :face (tp-at 1 'face) :count (tp-layer-count 1 10))))
-;; => (:face nil :count 2)
-
-;; tp-show-layer restores the layer's rendering
-(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-show-layer 1 10 'highlight)
- (tp-at 1 'face)))
-;; => (:background "yellow")
-
-;; Return value: number of modified runs; a missing name is a silent 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) ; already hidden
- (tp-hide-layer 1 10 'nonexistent)))) ; no such layer
-;; => (1 0 0)
-```
-
----
-
-### Managed Layer Lifecycle
-
-Stage 4 adds explicit lifecycle metadata for managed layer stacks. A single managed layer now uses `tp-layers` storage when metadata is present, because `tp-meta` is authoritative lifecycle state. The rendered direct text properties and public stack queries strip `tp-meta`: `text-properties-at` should show only rendered properties plus stack storage, and `tp-layer-stack-at` returns public layer plists without metadata.
-
-Legacy return values remain unchanged. Stack mutators still return their documented object/range/run-count values; diagnostics are separate read-only APIs.
-
-Parameterized mounted layers store their args and definition version in `tp-meta`. Redefining a parameterized layer refreshes mounted entries from stored args. Entries created before metadata existed are treated conservatively as legacy entries.
-
-#### `tp-attach-managed-layers` / `tp-detach-managed-layers`
-
-```elisp
-(tp-attach-managed-layers START END &optional OBJECT)
-(tp-detach-managed-layers START END &optional OBJECT KEEP-RENDERED)
-```
-
-`tp-attach-managed-layers` scans a range that already contains managed layer storage, normalizes missing metadata, registers found layers in the reactive buffer registry, and returns discovered layer names in range order. Use it after inserting a propertized managed string through native insertion paths.
-
-`tp-detach-managed-layers` removes managed storage and returns detached layer names. When KEEP-RENDERED is non-nil, the currently visible rendered properties remain as ordinary text properties; lifecycle storage (`tp-name`, `tp-layers`, `tp-meta`) is removed.
-
-#### `tp-managed-layer-diagnostics` / `tp-managed-buffer-diagnostics` / `tp-managed-diagnostics`
-
-```elisp
-(tp-managed-layer-diagnostics LAYER-NAME)
-(tp-managed-buffer-diagnostics &optional BUFFER)
-(tp-managed-diagnostics)
-```
-
-These functions are read-only diagnostics. They report layers, buffers, entries, stored args, registry state, errors, and theme diagnostics. `tp-managed-diagnostics` includes a `:theme` plist with generation, last hook source, refresh mode, refreshed ranges, and errors. Theme enable/disable hooks increment the generation and use conservative refresh diagnostics; this is lifecycle evidence, not a benchmark.
-
-#### `tp-layer-transaction`
-
-```elisp
-(tp-layer-transaction START END OBJECT FUNCTION &optional NOERROR)
-```
-
-Runs FUNCTION over a managed range. On success it returns a structured plist with `:status ok`, `:ok t`, FUNCTION's value in `:result`, an operation id, the range, and changed ranges. On error it restores the exact pre-transaction text/property snapshot; by default it signals `tp-layer-transaction-error`, while NOERROR returns the structured failure plist with rollback status.
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp tx-base () '(face bold))
- (define-tp tx-temp () '(face italic))
- (with-temp-buffer
- (insert "abcd")
- (let ((result
- (tp-layer-transaction
- 1 4 (current-buffer)
- (lambda () (tp-put-layer 1 3 'tx-base 0)))))
- (list (plist-get result :status)
- (plist-get result :range)
- (tp-at 1 'face)))))
-;; => (ok (1 . 4) bold)
-```
-
-Theme generation and managed diagnostics are verified as lifecycle behavior. Reproducible benchmark evidence is recorded in `docs/BENCHMARKS.md`; those timings are advisory baseline data, not release thresholds.
-
----
-
-### Property Layer Merging
-
-#### `tp-merge-layers` - Merge Multiple Layers
-
-```elisp
-;; Buffer/string region
-(tp-merge-layers START END NEW-LAYER-NAME '(IDX1 LAYER-NAME1 IDX2 ...) OBJECT)
-
-;; Entire string
-(tp-merge-layers STRING NEW-LAYER-NAME '(IDX1 LAYER-NAME1 IDX2 ...))
-```
-
-Merge specified layers into a new layer. Earlier layers in the list take precedence.
-
-**Hidden layers (0.3.0):** hidden matched layers 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 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. Returns the number of
-property runs modified (0 = no listed layer matched).
-
-**Examples:**
-
-```elisp
-;; Merge layer1 and layer2 into merged-layer
-(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-merge-layers 1 10 'merged-layer '(layer1 layer2))
- (tp-at 1 'tp-name)))
-;; => merged-layer
-
-;; Merge by index
-(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-merge-layers 1 10 'merged '(0 1))
- (tp-layer-count 1 10)))
-;; => 1
-
-;; A hidden layer's properties never leak into the merge
-(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))))
-;; => (:face bold :help nil :name merged) ; layer2 was hidden
-```
-
----
-
-#### `tp-flatten-layers` - Flatten All Layers
-
-```elisp
-;; Buffer/string region
-(tp-flatten-layers START END NAME OBJECT)
-
-;; Entire string
-(tp-flatten-layers STRING NAME)
-```
-
-Flatten all layers into a single layer with the given name.
-
-**Hidden layers (0.3.0):** hidden layers are **discarded**, mirroring
-image-editor flatten semantics — only the visible layers' properties merge
-into the 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`.
-Returns the number of property runs modified (0 = no run had layers).
-
-**Examples:**
-
-```elisp
-;; Flatten all layers into 'flat-layer
-(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-flatten-layers 1 10 'flat-layer)
- (tp-at 1 'tp-name)))
-;; => flat-layer
-
-;; Flatten with nil name (unnamed layer)
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-flatten-layers 1 10 nil)
- (tp-at 1 'tp-name)))
-;; => nil
-
-;; Hidden layers are discarded by flatten
-(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))))
-;; => (default flat) ; highlight's background is gone
-```
-
----
-
-### Property Layer Query Functions
-
-#### `tp-layer-list` - List All Layers
-
-```elisp
-(tp-layer-list START END &optional OBJECT)
-```
-
-Get list of all layer names in region.
-
-**Examples:**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp highlight () '(face (:background "yellow")))
- (define-tp base () '(face default))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (tp-layer-list 1 10)))
-;; => (highlight base)
-```
-
----
-
-#### `tp-layer-count`
-
-```elisp
-(tp-layer-count START END &optional OBJECT)
-```
-
-Count layers in region.
-
-**Examples:**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-layer-count 1 10)))
-;; => 2
-```
-
----
-
-#### `tp-layer-exists-p`
-
-```elisp
-(tp-layer-exists-p START END NAME &optional OBJECT)
-```
-
-Check if layer exists in region.
-
-**Examples:**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (list (tp-layer-exists-p 1 10 'layer1)
- (tp-layer-exists-p 1 10 'layer2))))
-;; => (t nil)
-```
-
----
-
-#### `tp-layer-top`
-
-```elisp
-(tp-layer-top START END &optional OBJECT)
-```
-
-Get name of the top layer. The topmost layer is reported in **stack
-order**, even when it is hidden (see
-[`tp-hide-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers));
-use `tp-layer-stack-at` to distinguish hidden layers from visible ones.
-
-**Examples:**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-layer-top 1 10)))
-;; => layer2
-```
-
----
-
-#### `tp-layer-stack-at` - Full Stack at a Position
-
-```elisp
-(tp-layer-stack-at POS &optional OBJECT)
-```
-
-Return the full ordered layer stack at one position (new in 0.3.0), as a
-list with one element per layer, topmost first, 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 is distinguishable by a `tp-hidden` entry with value t in
- PROPS; visible layers never carry one.
-
-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.
-
-**Examples:**
-
-```elisp
-(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-layer-stack-at 1)))
-;; => ((highlight . (face (:background "yellow")))
-;; (base . (face default)))
-
-;; Hidden layers carry a `tp-hidden' entry in PROPS
-(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-layer-stack-at 1)))
-;; => ((highlight . (tp-hidden t face (:background "yellow")))
-;; (base . (face default)))
-
-;; Bare text has no stack
-(with-temp-buffer
- (insert "Hello")
- (tp-layer-stack-at 1))
-;; => nil
-```
-
----
-
-#### `tp-add-to-layers` - Add Properties to Specific Layers
-
-```elisp
-;; Buffer/string region
-(tp-add-to-layers IDX-OR-LAYER-NAME-LIST START END PLIST &optional OBJECT)
-
-;; Entire string
-(tp-add-to-layers IDX-OR-LAYER-NAME-LIST STRING PROP VAL ...)
-```
-
-Add or merge properties to specific layers in a region or string.
-
-- **IDX-OR-LAYER-NAME-LIST** is a list of layer indices (integers) or layer names (symbols). For indices: 0 means top layer, -1 means bottom layer.
-- Properties are deeply merged into the specified layers (nested plists are merged, not replaced).
-- OBJECT defaults to current buffer for region form.
-- Like the other stack mutators (and unlike `tp-set`), the string form
- modifies STRING **in place** and returns that same mutated string. For
- buffers, returns nil.
-
-**Examples:**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face (:foreground "red")))
- (define-tp layer2 () '(face (:foreground "blue")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- ;; Add underline to both layers
- (tp-add-to-layers '(0 1) 1 10 '(face (:underline t)))
- (tp-at 5)))
-;; Both layers now have underline merged with their colors
-```
-
----
-
-#### `tp-add-to-all-layers` - Add Properties to All Layers
-
-```elisp
-;; Buffer/string region
-(tp-add-to-all-layers START END PLIST &optional OBJECT)
-
-;; Entire string
-(tp-add-to-all-layers STRING PROP VAL ...)
-```
-
-Add or merge properties to all layers in a region or string.
-
-- Properties are deeply merged into all existing layers.
-- OBJECT defaults to current buffer for region form.
-- Like the other stack mutators (and unlike `tp-set`), the string form
- modifies STRING **in place** and returns that same mutated string. For
- buffers, returns nil.
-
-**Examples:**
-
-```elisp
-(let ((str (copy-sequence "Hello World")))
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 0 5 'layer1 str)
- (tp-push-layer 0 5 'layer2 str)
- ;; Add underline to all layers
- (tp-add-to-all-layers 0 5 '(face (:underline t)) str)
- str)
-```
-
----
-
-#### `tp-intervals` - Get Text Property Intervals
-
-```elisp
-(tp-intervals START END &optional OBJECT ABSOLUTE)
-```
-
-Get all text property intervals from START to END in OBJECT.
-
-- Returns a list of (START END PROPERTIES) for each interval, including
- gap intervals with no properties, whose PROPERTIES is nil.
-- For buffer input, START and END are 1-based buffer positions but the
- returned positions are by default **0-based offsets relative to START**
- (the legacy convention). With ABSOLUTE non-nil (new in 0.3.0) 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 indices; ABSOLUTE changes
- nothing.
-- Uses `object-intervals` (requires Emacs 28.1+).
-- OBJECT can be a buffer or string; nil defaults to current buffer.
-
-**Examples:**
-
-```elisp
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-intervals 1 12))
-;; => ((0 5 (face bold)) (5 6 nil) (6 11 (face italic)))
-;; positions are offsets from START; (5 6 nil) is the unpropertized gap
-
-;; ABSOLUTE - native buffer coordinates
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-intervals 1 12 nil t))
-;; => ((1 6 (face bold)) (6 7 nil) (7 12 (face italic)))
-
-;; ABSOLUTE positions feed straight back into other tp calls
-(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))
-;; => "bold text"
-```
-
----
-
-#### `tp-intervals-map` - Apply Function to Intervals
-
-```elisp
-(tp-intervals-map FUNCTION START END &optional OBJECT ABSOLUTE)
-```
-
-Apply FUNCTION to all intervals between START and END in OBJECT.
-
-- FUNCTION receives four arguments: interval-start, interval-end,
- top-props (the directly rendered properties, with the `tp-layers` entry
- removed), and below-props-lst (the `tp-layers` value: the stored layer
- plists buried below the rendered top layer — while any layer is hidden
- it holds the whole ordered stack; see
- [`tp-layer-stack-at`](#tp-layer-stack-at---full-stack-at-a-position) for
- the decoded view).
-- Intervals with no properties are visited too, with nil top-props
- (positions follow the same coordinate convention as `tp-intervals`,
- including the ABSOLUTE argument, new in 0.3.0).
-- OBJECT can be a buffer or string; nil defaults to current buffer.
-- Returns list of function results (nil results are removed).
-
-**Examples:**
-
-```elisp
-(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)
- (list start end (plist-get props 'face)))
- 1 12))
-;; => ((0 5 bold) (5 6 nil) (6 11 italic))
-
-;; ABSOLUTE - FUNCTION receives native buffer positions
-(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)
- (list start end (plist-get props 'face)))
- 1 12 nil t))
-;; => ((1 6 bold) (6 7 nil) (7 12 italic))
-```
-
----
-
-#### `tp-region-layer-props` - Get Layer Properties in Region
-
-```elisp
-(tp-region-layer-props START END LAYER-NAME &optional OBJECT)
-```
-
-Return layer properties for LAYER-NAME in region from START to END.
-
-- Returns a list of (START END PROPERTIES) for matching intervals.
-- OBJECT defaults to current buffer.
-
-**Examples:**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World Test")
- (tp-push-layer 1 6 'highlight)
- (tp-push-layer 12 16 'highlight)
- (tp-region-layer-props 1 16 'highlight)))
-;; => ((1 6 (face (:background "yellow") tp-name highlight))
-;; (12 16 (face (:background "yellow") tp-name highlight)))
-```
-
----
-
-#### `tp-plist` - Get All Properties in Region
-
-```elisp
-;; Buffer/string region
-(tp-plist START END &optional OBJECT)
-
-;; Entire string
-(tp-plist STRING)
-```
-
-Get a property list of all properties present in a region or string.
-
-- Returns a single merged plist of the properties found in the range; when
- the same property occurs in several intervals, the value from the later
- interval wins.
-- OBJECT defaults to current buffer for region form.
-
-**Examples:**
-
-```elisp
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold help-echo "Tip"))
- (tp-set 7 12 '(face italic))
- (tp-plist 1 12))
-;; => (help-echo "Tip" face italic) ; later interval's face wins
-```
-
----
-
-#### `tp-empty-p` - Check if Object Has Properties
-
-```elisp
-(tp-empty-p &optional OBJECT)
-```
-
-Return t if OBJECT has no text properties.
-
-- OBJECT can be a string or buffer; nil defaults to current buffer.
-- Uses `object-intervals` (requires Emacs 28.1+).
-
-**Examples:**
-
-```elisp
-(tp-empty-p "plain text") ; => t
-
-;; Whole-string tp-set is non-destructive: the original stays empty
-(let* ((str "text")
- (new (tp-set str 'face 'bold)))
- (list (tp-empty-p str) (tp-empty-p new)))
-;; => (t nil)
-```
-
----
-
-#### `tp-with-current-buffer` / `tp-pop-to-buffer` / `tp-switch-to-buffer`
-
-```elisp
-(tp-with-current-buffer BUFFER-OR-NAME BODY...)
-(tp-pop-to-buffer BUFFER-OR-NAME BODY...)
-(tp-switch-to-buffer BUFFER-OR-NAME BODY...)
-```
-
-Convenience macros for operating on and displaying propertized content:
-
-- **`tp-with-current-buffer`** evaluates BODY in BUFFER-OR-NAME with
- `inhibit-read-only` bound to t. Useful for modifying read-only display
- buffers.
-- **`tp-pop-to-buffer`** creates (or reuses) BUFFER-OR-NAME, erases it,
- evaluates BODY inside it, then makes it read-only and displays it with
- `pop-to-buffer`. Press `q` in the displayed buffer to quit its window.
-- **`tp-switch-to-buffer`** is the same but displays the buffer with
- `switch-to-buffer`.
-
-**Example:**
-
-```elisp
-(tp-pop-to-buffer "*tp-demo*"
- (insert (tp-set "Important" 'face '(:foreground "red" :weight bold))
- " message\n"))
-;; Displays *tp-demo* with the propertized text; `q' quits the window
-```
-
----
-
-### Color Palette System
-
-`tp-palette.el` ships a set of named color palettes with separate light-mode
-and dark-mode colors, and `tp-builtins.el` exposes them through the built-in
-parameterized `tp-palette` layer (as in `(tp-set "emacs" 'tp-palette 'info)`).
-
-- **`tp-palette-alist`** (variable) — alist of `(NAME . PLIST)` palette
- definitions; the single source of truth for palette lookups. Each PLIST
- maps `:fg`, `:bg`, and `:border` to colors.
-- **`define-tp-palette`** — register (or update) a palette (since 0.3.0
- also available as the prefix-conforming alias `tp-define-palette`):
-
- ```elisp
- (define-tp-palette my-brand
- :fg ("#0969da" . "#58a6ff") ; ("light" . "dark")
- :bg ("#ddf4ff" . "#1f3d5c"))
- ```
-
-- **`tp-palette-color`** (new in 0.3.0) — **the** palette accessor: get a
- palette's `:fg` / `:bg` / `:border` color, resolved for the current
- light/dark theme. Returns nil for a missing palette or key:
-
- ```elisp
- (tp-palette-color 'info :fg)
- ;; => "#0969da" on a light theme, "#58a6ff" on a dark theme
- (tp-palette-color 'no-such-palette :fg)
- ;; => nil
- ```
-
-- **`tp-palette-has-p`** (new in 0.3.0) — **the** palette predicate: with
- just SYMBOL, test whether it names a registered palette; with KIND one of
- `:fg` / `:bg` / `:border`, additionally require that key in its
- definition (a defined key may still resolve to no color for the current
- theme — use `tp-palette-color` when the resolved color matters):
-
- ```elisp
- (list (tp-palette-has-p 'info)
- (tp-palette-has-p 'info :border)
- (tp-palette-has-p 'no-such-palette))
- ;; => (t t nil)
- ```
-
- The older per-key conveniences remain as compatible wrappers:
- `tp-palette-fg-color` / `tp-palette-bg-color` / `tp-palette-border-color`
- (fixed-KEY variants of `tp-palette-color`), `tp-palette-p` (nil-KIND
- `tp-palette-has-p`), and the suffixed-name predicates `tp-palette-fg-p` /
- `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p`, which
- answer a different question: whether a *variant name* like `info-fg`
- denotes a registered palette (the `tp-palette` layer's convention).
-
-- **`tp-palette-show`** — interactive command that displays a gallery buffer
- of every registered palette and its `-fg` / `-bg` / `-fbg` / `-border`
- variants (`q` quits).
-- **`tp-parse-color`** — resolve a color spec for the current theme. Accepts
- a plain color string, a `("light" . "dark")` cons (either side may be nil),
- or a `(:light L :dark D)` plist:
-
- ```elisp
- (tp-parse-color "red") ; => "red"
- (tp-parse-color '("white" . "black")) ; => "white" on a light theme,
- ; "black" on a dark theme
- ```
-
-Note: `tp-layer-reset` clears every layer definition, including built-in
-layers like `tp-palette`.
-
----
-
-## Practical Examples
-
-### Syntax Highlighting with Multiple Layers
-
-```elisp
-;; Complete example that can be run in a buffer
-(progn
- (tp-layer-reset)
- ;; Define layers for different highlighting purposes
- (define-tp code-base ()
- '(face font-lock-keyword-face))
- (define-tp code-error ()
- '(face (:underline (:color "red" :style wave))
- help-echo "Syntax error"))
- (define-tp code-debug ()
- '(face (:background "dark blue")))
- (with-temp-buffer
- (insert (make-string 100 ?x)) ; Create 100-char buffer
- ;; Apply base highlighting
- (tp-push-layer 1 100 'code-base)
- ;; Add error highlight on problematic code
- (tp-push-layer 50 60 'code-error)
- ;; Check the top layer at position 55
- (tp-layer-top 50 60)))
-;; => code-error
-
-;; Toggle function (for use in real buffers)
-(defun toggle-error-view (start end)
- "Toggle between error and normal view."
- (interactive "r")
- (tp-rotate-layer start end))
-```
-
-### Status Indicator
-
-```elisp
-;; Complete example with layer group
-(progn
- (tp-layer-reset)
- ;; Define status layers as a group
- (define-tp status-todo () '(face (:foreground "gray")))
- (define-tp status-progress () '(face (:foreground "yellow")))
- (define-tp status-done () '(face (:foreground "green")))
- (define-tps task-status () 'status-todo 'status-progress 'status-done)
- ;; Check group is defined
- (length (tp-group-props 'task-status)))
-;; => 3
-
-;; Cycle through statuses (for use in real buffers)
-(defun cycle-task-status ()
- "Cycle through task status layers on current line."
- (interactive)
- (tp-rotate-layer (line-beginning-position) (line-end-position)))
-```
-
-### Temporary Highlights
-
-```elisp
-;; Define temporary highlight layer
-(progn
- (tp-layer-reset)
- (define-tp temp-highlight ()
- '(face (:background "yellow")))
- (tp-layer-props 'temp-highlight))
-;; => (face (:background "yellow"))
-
-;; Flash function (for use in real buffers)
-(defun flash-region (start end)
- "Flash a region temporarily."
- (tp-push-layer start end 'temp-highlight)
- (run-with-timer 0.5 nil
- (lambda (s e)
- (tp-delete-layer s e 'temp-highlight))
- start end))
-```
-
----
-
-## Reactive Text Properties
-
-> 📖 **For a comprehensive guide with detailed examples, see [Reactive Text Properties Complete Guide](docs/reactive-text-properties-en.md)**
->
-> 📖 **For advanced optimization features, see [Reactive System Optimization](docs/reactive-optimization-en.md)**
-
-**Reactive Text Properties** is tp.el's groundbreaking innovation that brings reactive programming paradigms to Emacs text properties. Inspired by modern frontend frameworks like Vue.js, this feature enables text properties to automatically update when underlying variable values change.
-
-### Core Concept
-
-Traditional text property manipulation requires manually updating all affected text regions whenever you want to change a property value. With reactive text properties, you simply define a variable relationship once, and tp.el handles all updates automatically:
-
-```elisp
-;; Traditional approach (manual updates required)
-(defvar my-color "red")
-(tp-set 1 10 '(face (:foreground "red")))
-;; To change color, you must manually update every region:
-(setq my-color "blue")
-(tp-set 1 10 '(face (:foreground "blue"))) ; Manual!
-
-;; Reactive approach (automatic updates)
-(defvar my-color "red")
-(define-tp my-layer ()
- :props '(face (:foreground $my-color)))
-(tp-push-layer 1 10 'my-layer)
-;; Just change the variable - all text updates automatically!
-(setq my-color "blue") ; All regions with my-layer update instantly!
-```
-
-### How It Works
-
-1. **Reactive Variables**: Any symbol prefixed with `$` in `:props` is treated as a reactive variable. The `$` is stripped to get the actual variable name.
-
-2. **Variable Watchers**: tp.el uses Emacs's `add-variable-watcher` to monitor changes to reactive variables.
-
-3. **Automatic Updates**: When a reactive variable changes via `setq`, all text regions using layers that depend on that variable are automatically updated with the new property values.
-
-### Defining Reactive Layers
-
-#### Basic Reactive Layer
-
-```elisp
-(defvar highlight-color "yellow")
-
-(define-tp my-highlight ()
- :props '(face (:background $highlight-color)))
-
-(with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'my-highlight)
- ;; Text is highlighted in yellow
-
- (setq highlight-color "cyan")
- ;; Text is now highlighted in cyan - automatically!
-)
-```
-
-#### Multiple Reactive Variables
-
-```elisp
-(defvar fg-color "white")
-(defvar bg-color "black")
-
-(define-tp themed-text ()
- :props '(face (:foreground $fg-color :background $bg-color)))
-
-;; Changing either variable updates the text
-(setq fg-color "yellow") ; Updates foreground
-(setq bg-color "navy") ; Updates background
-```
-
-### :data - Additional Reactive State
-
-The `:data` keyword defines additional reactive variables that aren't directly used in `:props` but can trigger computed value updates or be watched:
-
-```elisp
-(define-tp user-info ()
- :props '(help-echo $full-name)
- :data '(first-name last-name) ; Not used directly in props
- :compute '((full-name (lambda () (concat first-name " " last-name)))))
-```
-
-**With Initial Values:**
-
-You can specify initial values using cons cells:
-
-```elisp
-(define-tp user-info ()
- :props '(help-echo $full-name)
- :data '((first-name . "John") (last-name . "Doe"))
- :compute '((full-name (lambda () (concat first-name " " last-name)))))
-
-;; first-name is now "John", last-name is now "Doe"
-```
-
-### :compute - Computed Properties
-
-The `:compute` keyword creates derived values that are automatically recalculated when their dependencies change:
-
-```elisp
-(define-tp progress-display ()
- :props '(display $progress-text face (:foreground $progress-color))
- :data '((current . 0) (total . 100))
- :compute '((progress-text (lambda () (format "%d%%" (/ (* current 100) total))))
- (progress-color (lambda ()
- (cond ((< current 30) "red")
- ((< current 70) "yellow")
- (t "green"))))))
-
-;; Update progress
-(setq current 50)
-;; progress-text becomes "50%" and progress-color becomes "yellow" automatically!
-```
-
-### :watch - Side Effect Callbacks
-
-The `:watch` keyword lets you execute callbacks when reactive variables change:
-
-```elisp
-(define-tp monitored-layer ()
- :props '(face (:foreground $status-color))
- :watch '((status-color
- (lambda (new-val old-val layer-name)
- (message "Layer %s: color changed from %s to %s"
- layer-name old-val new-val)))))
-
-(setq status-color "red")
-;; Message: "Layer monitored-layer: color changed from nil to red"
-
-(setq status-color "green")
-;; Message: "Layer monitored-layer: color changed from red to green"
-```
-
-### :transform - Value Transformation
-
-The `:transform` keyword allows you to register a transformation function that processes `tp-text` values before they are displayed. This is useful for formatting numbers, dates, or other values:
-
-```elisp
-;; Number formatting
-(define-tp price-display ()
- :props '(tp-text $price)
- :data '((price . "99.9"))
- :transform (lambda (text)
- (format "$%.2f" (string-to-number text))))
-;; 99.9 displays as $99.00
-
-;; Date formatting
-(define-tp date-display ()
- :props '(tp-text $timestamp)
- :data '((timestamp . "1703865600"))
- :transform (lambda (text)
- (format-time-string "%Y-%m-%d"
- (seconds-to-time (string-to-number text)))))
-
-;; Uppercase conversion
-(define-tp uppercase-text ()
- :props '(tp-text $content)
- :data '((content . "hello"))
- :transform #'upcase)
-;; "hello" displays as "HELLO"
+ (tp-apply (current-buffer) 2 5 '(face italic)))
```
-The transform function:
-- Receives the raw `tp-text` string value
-- Returns the transformed string for display
-- Is applied both on initial display and reactive updates
-- Must return a string; failures and non-string results propagate instead of
- rendering stale input
-
-Compute functions follow the same business-error rule. Watch callbacks are
-observers: their failures are isolated so rendering continues, and structured
-records are appended newest-first to `tp-reactive-observer-errors`.
-
-### Anonymous Reactive Layers
+The established `tp-set`, `tp-reset`, `tp-add`, `tp-remove`, `tp-clear`, `tp-get`, `tp-at`, `tp-member`, match, regexp, search, navigation, interval, and native query APIs remain the direct façade for ordinary text-property work.
-You can use reactive variables even without `define-tp`. When you use `$`-prefixed symbols in an anonymous plist, tp.el automatically generates a unique layer name:
+## Reusable declaration recipes
-```elisp
-(defvar my-face-color "blue")
-
-;; Anonymous reactive layer - tp-name is auto-generated
-(tp-set 1 10 '(face (:foreground $my-face-color)))
-
-;; The layer is now reactive - changing the variable updates the text
-(setq my-face-color "red")
-```
-
-### Layer Name Resolution in APIs
-
-All text property APIs (`tp-set`, `tp-match-set`, `tp-regexp-set`, etc.) now accept layer names directly:
+`define-tp` and `define-tps` define reusable recipes that expand to direct Emacs properties. They are definition-time conveniences, not live mounted layers, and they never write identity or provenance into displayed text.
```elisp
-(define-tp warning-style ()
- :props '(face (:foreground "orange" :weight bold)))
-
-;; Use layer name instead of plist
-(tp-set 1 10 'warning-style)
-
-;; Works with all matching functions
-(tp-match-set "TODO" 'warning-style)
-(tp-regexp-set "[0-9]+" 'warning-style)
-```
-
-This direct use is **template expansion** for non-reactive layers: the
-definition becomes ordinary text properties and does not retain `tp-name`.
-Use `tp-push-layer` or `tp-put-layer` for a **managed mount** that can later
-be queried, moved, hidden, deleted by name, or refreshed after a layer
-redefinition. Parameterized mounted entries retain their arguments and use
-them to refresh existing instances after redefinition.
-
-### Reactive Layer Groups
-
-Layer groups can also use reactive features:
+(define-tp link-style (foreground)
+ `(face (:foreground ,foreground :weight bold)
+ mouse-face highlight
+ help-echo "Open item"))
-```elisp
-(define-tps status-indicators ()
- '("success" :props (face (:foreground $success-color))
- :data ((success-color . "green")))
- '("warning" :props (face (:foreground $warning-color))
- :data ((warning-color . "orange")))
- '("error" :props (face (:foreground $error-color))
- :data ((error-color . "red"))))
+(tp-set "Project" '(link-style "#58a6ff"))
```
-### Batched Updates
-
-When modifying multiple reactive variables simultaneously, each `setq` triggers a separate buffer update. Use `tp-with-batch-updates` to consolidate all changes and apply them once at the end:
+Use `tp-computed` when a property value must be evaluated. Every ordinary function object remains literal.
```elisp
-(define-tp themed-text ()
- :props '(face (:foreground $fg-color :background $bg-color))
- :data '((fg-color . "white") (bg-color . "black")))
-
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 12 'themed-text)
-
- ;; Without batching: each setq triggers a buffer update
- (setq fg-color "yellow") ; First update
- (setq bg-color "navy") ; Second update
-
- ;; With batching: all changes applied once at the end
- (tp-with-batch-updates
- (setq fg-color "red")
- (setq bg-color "blue"))) ; Only one update
-```
+(defvar my-height 1.2)
-Benefits of batched updates:
-- Reduces redundant buffer modifications
-- Improves performance when changing multiple variables
-- Ensures consistent state when multiple variables are interdependent
-
-### Layer-Buffer Registry & Lifecycle
-
-Since 0.3.0 the reactive engine keeps a **layer→buffer registry**: every
-buffer-mutating write path that stamps a layer (the `tp-set` family, the
-stack mutators, the match/regexp appliers) registers the target buffer as
-showing that layer, and a reactive update visits **only the registered
-buffers** instead of scanning the whole `(buffer-list)`. Killed buffers are
-pruned automatically. When a layer has no registry entry at all, one
-**learning full scan** falls back to the old behavior and registers every
-buffer where the layer is actually found.
-
-Updates reach a layer's regions even while the layer is **hidden** or
-**buried** below other layers in a stack: the stored `tp-layers` entry is
-updated in place, so `tp-show-layer` (or raising the layer) always reveals
-current values.
-
-#### `tp-reactive-layer-buffers` - Inspect the Registry
-
-```elisp
-(tp-reactive-layer-buffers LAYER-NAME)
+(define-tp sized-label ()
+ `(face ,(tp-computed (lambda () (list :height my-height)))))
```
-Return the live buffers registered as showing LAYER-NAME — a list (possibly
-empty, meaning "known: no buffer shows this layer") — or the symbol
-`unknown` when the layer has no registry entry at all:
-
-```elisp
-(progn
- (tp-layer-reset)
- (defvar reg-color "red")
- (define-tp reg-layer ()
- :props '(face (:foreground $reg-color)))
- (tp-reactive-layer-buffers 'reg-layer))
-;; => unknown ; never applied to any buffer yet
+The computed function runs in the current binding/prepare context, so `tp-signal-read` and `tp-binding-read` establish exact dependencies. Its returned value is normalized and projected once, then treated as literal data.
-(with-temp-buffer
- (rename-buffer "demo-buffer" t)
- (insert "Hello")
- (tp-push-layer 1 6 'reg-layer)
- (mapcar #'buffer-name (tp-reactive-layer-buffers 'reg-layer)))
-;; => ("demo-buffer")
-```
+## Reactive existing text
-#### `tp-reactive-track-buffer` - Close the String-Insert Gap
+`tp-watch` decorates a marker-backed host range without owning or replacing its text:
```elisp
-(tp-reactive-track-buffer &optional BUFFER) ; interactive
+(let ((online (tp-signal-create nil)))
+ (with-current-buffer (get-buffer-create "*tp-status*")
+ (erase-buffer)
+ (insert "offline")
+ (tp-watch
+ (current-buffer) 1 8
+ (lambda ()
+ (list 'face
+ (list :foreground
+ (if (tp-signal-read online) "green" "red")))))))
```
-**Known gap:** inserting an *already-propertized string* into a buffer
-bypasses the buffer operations that register buffers, so that buffer is
-missing from the registry until a learning full scan finds it. Call
-`tp-reactive-track-buffer` after such an insert: it scans BUFFER (default:
-the current buffer) for layer regions — rendered top layers as well as
-layers buried or hidden inside `tp-layers` stack storage — registers the
-buffer for each, and returns the layer names found in buffer order:
-
-```elisp
-(let ((s (tp-set "hello" 'reg-layer))) ; propertized string, detached
- (with-temp-buffer
- (insert s) ; bypasses registration
- (tp-reactive-track-buffer)))
-;; => (reg-layer) ; buffer now registered for reg-layer
-```
+A signal records the binding that actually reads it. Updating one signal invalidates only its subscribers; conditional computations automatically stop subscribing to sources that the new branch no longer reads. Equal writes are no-ops, and repeated writes inside `tp-with-transaction` recompute each affected binding at most once.
-#### `tp-gc-anonymous-layers` - Collect Unused Anonymous Layers
+`tp-watch` returns the underlying surface handle. Pass it to `tp-surface-inspect`, `tp-surface-report`, or `tp-surface-unmount`.
-```elisp
-(tp-gc-anonymous-layers) ; interactive
-```
+## Retained content
-[Anonymous reactive layers](#anonymous-reactive-layers) are interned: an
-`equal` props spec reuses its registry entry instead of minting a new layer
-on every `tp-set`. `tp-gc-anonymous-layers` undefines every interned
-anonymous layer that no registered live buffer still displays (buried and
-hidden layers count as alive) and returns the collected layer names:
+A retained producer receives a prepare context, ensures stable objects before producing output, installs any object-local bindings, and returns a pure surface plan:
```elisp
-(defvar tmp-color "green")
-(let ((buf (generate-new-buffer "*gc-demo*")))
- (with-current-buffer buf
- (insert "Hello")
- (tp-set 1 6 '(face (:foreground $tmp-color)))) ; anonymous layer
- (kill-buffer buf)
- (tp-gc-anonymous-layers))
-;; => (tp-anon-1) ; the collected names (the counter varies)
+(let* ((status (tp-signal-create "ready"))
+ (producer
+ (lambda (context)
+ (let* ((object (tp-object-ensure context nil 'status 'text))
+ (binding
+ (tp-bind object '(demo . status)
+ (lambda () (tp-signal-read status)))))
+ (tp-surface-plan-create
+ :key 'status
+ :kind 'text
+ :text (tp-binding-read binding)
+ :props '(face bold)
+ :capability 'content))))
+ (buffer (get-buffer-create "*tp-retained*"))
+ (surface
+ (tp-surface-mount buffer producer '(:capability content))))
+ (tp-signal-set status "done")
+ (tp-surface-report surface))
```
-**Conservative `unknown` semantics:** a layer whose registry state is
-`unknown` — never seen in any buffer through the registering paths, for
-example referenced only by detached strings — is deliberately **kept**. A
-layer becomes collectable only after it was registered for at least one
-buffer and none of the registered buffers still shows it (e.g. all killed).
-Call `tp-reactive-track-buffer` after inserting propertized strings so
-their buffers are registered too.
+Plan fields are `key`, `kind`, `text`, `props`, `children`, `tags`, and `capability`. Plans contain no markers, buffer positions, patch operations, producer closures, or client continuations. Constructors defensively copy caller-owned strings and property data.
-#### Minimal-Diff `tp-text` Re-Rendering
+Stable identity is surface-local. `tp-object-ensure` reconciles by parent, sibling key, and kind; `tp-object-resolve` returns a live opaque handle by key path. `tp-surface-update-scoped` authorizes a full candidate update against one or more retained objects and rejects output changes outside their current mount ranges unless the caller explicitly selects root fallback.
-Reactive `tp-text` replacements edit only the **differing span** of the old
-and new text (inserting before deleting), so point and markers in unchanged
-text keep their positions; point inside the edited span lands at the edit
-start. An update to an **identical** value is a true no-op: no text edit,
-no property churn, and the buffer-modified flag is untouched.
-
-```elisp
-(progn
- (tp-layer-reset)
- (defvar 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") ; only the digit is edited
- (list (buffer-substring-no-properties 1 (point-max))
- (char-after m)))))
-;; => ("count: 9 items" ?i) ; the marker still points at its character
+`tp-surface-materialize-string` uses the same producer and plan semantics without creating a live surface. Its candidate objects, bindings, subscriptions, and anchors are released before it returns.
-;; Identical-value updates do not touch the buffer at all
-(with-temp-buffer
- (insert "count: 9 items")
- (tp-set 8 9 'counter-label)
- (set-buffer-modified-p nil)
- (setq counter-val "9") ; same text as displayed
- (buffer-modified-p))
-;; => nil
-```
+## Host ranges and property ownership
-### Debug Mode
+The `properties` capability uses opaque range anchors. A producer creates or receives a `tp-range-anchor-create` handle and attaches it to an object with `tp-object-attach-range`. Markers follow host edits; the plan itself remains position-free.
-tp.el provides a debug mode to help understand reactive update flow:
+TP records the host baseline and each TP contribution per property interval. Overlapping contributions are composed through the registered property policy. If external code changes a property after TP publishes it, the next update reports `tp-property-conflict` instead of overwriting the external value. `tp-range-rebase` explicitly accepts the current host value as the new baseline. Unmount restores only values still owned by TP and preserves conflicting host edits.
-```elisp
-;; Enable debug mode
-(setq tp-debug-mode t)
+## Transactions and failures
-;; Also show debug info in minibuffer (optional)
-(setq tp-debug-echo t)
+`tp-with-transaction` batches signal writes and all affected surfaces. TP prepares every candidate first, then publishes surfaces in stable order. A compute, validation, buffer write, marker/index publication, or transaction participant failure restores signal values, binding values and dependencies, text, properties, markers, indexes, plans, client state, revisions, and previous reports together.
-;; View debug log
-(tp-debug-show)
+Observers run only after a successful commit. Their failures are recorded and do not roll back an already committed transaction. A buffer killed during publication remains killed; rollback never recreates it.
-;; Clear debug log
-(tp-debug-clear)
-```
+## Property policies
-Debug log includes:
-- Variable change notifications (old → new value)
-- Layer update tracking
-- Batch update start/end
-- Transform application info
+`tp-define-property-policy` registers generic semantics for a final Emacs text property:
-Example debug output:
-```
-[12:34:56.789] Variable my-color changed: "red" -> "blue" (where: global)
-[12:34:56.790] Updating layer test-layer (tp-text affected: no)
-```
+- normalization and validation;
+- equality for no-op detection;
+- contribution merging;
+- projection to the final property value;
+- explicit presence, including present `nil`.
-### Resetting Reactive State
+`tp-register-text-property` supplies the default policy for a native property. `face` contributions use merge semantics; other properties use their registered policy. `tp-merge-declarations`, `tp-define-style`, and `tp-style-declarations` operate only on direct declarations. They do not implement CSS cascade.
-To clear all reactive dependencies and watchers:
+## Public runtime families
-```elisp
-(tp-reactive-reset) ; Clears only reactive state
+| Family | Main public APIs |
+| --- | --- |
+| Property policy and declarations | `tp-define-property-policy`, `tp-register-text-property`, `tp-text-declarations`, `tp-computed`, `tp-resolve-value`, `tp-merge-declarations`, `tp-define-style`, `tp-style-declarations` |
+| Signals and bindings | `tp-signal-create`, `tp-signal-read`, `tp-signal-peek`, `tp-signal-set`, `tp-bind`, `tp-binding-read`, `tp-with-transaction`, `tp-reactive-counters` |
+| Objects and plans | `tp-object-ensure`, `tp-object-retain`, `tp-object-attach-fragment`, `tp-object-resolve`, `tp-object-mounts`, `tp-surface-plan-create`, `tp-surface-result-create` |
+| Host ranges | `tp-range-anchor-create`, `tp-object-attach-range`, `tp-range-rebase` |
+| Surfaces | `tp-surface-materialize-string`, `tp-surface-mount`, `tp-surface-update`, `tp-surface-update-scoped`, `tp-surface-unmount`, `tp-surface-at-point`, `tp-surface-report`, `tp-surface-inspect` |
+| Direct façade | `tp-propertize`, `tp-apply`, `tp-watch`, `tp-set`, `tp-reset`, `tp-add`, `tp-remove`, `tp-clear`, `tp-get`, `tp-at`, `tp-member` |
-(tp-layer-reset) ; Clears layers, groups, AND reactive state
-```
+See [API semantics](docs/API-SEMANTICS.md) for ownership, lifecycle, error, and return contracts, and [architecture](docs/ARCHITECTURE.md) for module boundaries and transaction flow.
-### Complete Example: Theme-Aware Text
+## TP 1.0 migration
-```elisp
-;; Define theme variables
-(defvar theme-fg "white")
-(defvar theme-bg "black")
-(defvar theme-accent "cyan")
+TP 1.0 removes the 0.3 managed stack/renderer runtime instead of hiding it behind compatibility branches. Removed behavior includes `tp-render.el`, `tp-stack.el`, stack mutation APIs, `tp-text`, `$variable` declarations, layer-to-buffer registries, scan-driven refresh, managed attach/detach/diagnostics, and inline `tp-name`/`tp-layers`/`tp-meta` runtime storage.
-;; Define theme-aware layers - each one references a theme variable
-(define-tp code-text ()
- :props '(face (:foreground $theme-fg :background $theme-bg)))
+Use direct recipes for reusable static declarations, `tp-watch` for reactive properties on existing text, and retained content surfaces for reactive text or structured UI. TP does not automatically scan historical propertized text to reconstruct runtime identity.
-(define-tp code-keyword ()
- :props '(face (:foreground $theme-accent :weight bold)))
+## Examples
-;; Apply layers to code in the current buffer
-(tp-set (point-min) (point-max) 'code-text)
-(tp-match-set '("defun" "defvar" "let" "if" "when") 'code-keyword)
+- [Static properties](examples/static-properties.el)
+- [Reactive status](examples/reactive-status.el)
+- [Retained dashboard](examples/retained-dashboard.el)
+- [Diagnostic decoration](examples/diagnostic-decoration.el)
-;; Switch to light theme - just change the variables!
-(defun switch-to-light-theme ()
- (interactive)
- (setq theme-fg "black")
- (setq theme-bg "white")
- (setq theme-accent "blue"))
+These examples use only TP public APIs and are tested without Ebox or ECSS on the load path.
-;; Switch to dark theme
-(defun switch-to-dark-theme ()
- (interactive)
- (setq theme-fg "white")
- (setq theme-bg "black")
- (setq theme-accent "cyan"))
+## Verification
-;; After `switch-to-light-theme', keywords turn blue and the rest of the
-;; code turns black-on-white - every region re-renders automatically
+```sh
+make test
+make test-shuffled SHUFFLE_SEED=20260806
+make doctest
+make compile-all WERROR=t
+make checkdoc
+make package-lint
+make diff-check
```
----
+The structural tests also prove that normal signal and surface updates do not scan `buffer-list` or search displayed text for identity, equal results do not publish a new revision, and unmount/kill cleanup releases subscriptions and marker-backed runtime state.
## License
-This project is distributed under the GNU General Public License v3 or later
-(`GPL-3.0-or-later`). See [LICENSE](LICENSE) for the complete GPLv3 terms.
-
----
-
-## Contributing
-
-Contributions are welcome! Please feel free to submit issues or pull requests.
-
----
-
-
- tp.el - Making text properties powerful and easy to use
-
+GPL-3.0-or-later. See [LICENSE](LICENSE).
diff --git a/README_CN.md b/README_CN.md
index 35702ba..e63c0ed 100644
--- a/README_CN.md
+++ b/README_CN.md
@@ -1,4361 +1,201 @@
-# tp.el - Emacs 文本属性操作库
+# TP
-
- 一个功能强大的文本属性操作库，具有创新的属性层系统
-
+TP 1.0 是一个可独立使用的 Emacs retained/reactive text runtime。它把声明式属性、响应式数据和稳定文本对象投影到 string 与 buffer，并拥有文本属性 contribution 合成、精确依赖追踪、保留式身份、marker-backed mount、diff、事务、回滚和最终 Buffer publication。
-
- 功能特性 •
- 安装 •
- 快速开始 •
- API 参考 •
- 属性层系统 •
- 响应式文本属性
-
+TP 不依赖 Ebox 或 ECSS，也不实现 CSS selector、stylesheet、specificity、cascade winner、Box、Flex、Grid、测量或布局。需要 CSS 的调用者可以先用 ECSS 算出最终 declarations，再交给 TP 发布；TP 自身只理解 Emacs 文本属性和通用 retained text surface。
----
+英文文档：[README.md](README.md)。
-## 目录
+## 运行要求
-- [快速开始](#快速开始)
-- [概述](#概述)
- - [核心创新](#核心创新)
-- [功能特性](#功能特性)
- - [统一的 API 参数规范](#统一的-api-参数规范)
- - [三种属性操作语义](#三种属性操作语义)
- - [子属性的精细操作](#子属性的精细操作)
- - [创新的属性层系统](#创新的属性层系统)
- - [模式匹配与批量操作](#模式匹配与批量操作)
- - [响应式文本属性](#-响应式文本属性)
- - [增强的搜索与导航](#增强的搜索与导航)
-- [系统要求](#系统要求)
-- [安装](#安装)
-- [API 参考](#api-参考)
- - [API 快速参考](#api-快速参考)
- - [核心属性函数](#核心属性函数)
- - [tp-set](#tp-set---设置文本属性)
- - [tp-reset](#tp-reset---替换所有属性)
- - [tp-add](#tp-add---添加合并属性)
- - [tp-get](#tp-get---获取属性值)
- - [tp-at](#tp-at---获取位置属性)
- - [tp-member](#tp-member---判断位置属性是否存在)
- - [tp-remove](#tp-remove---移除属性)
- - [tp-clear](#tp-clear---清除所有属性)
- - [模式匹配函数](#模式匹配函数)
- - [tp-match-set](#tp-match-set---匹配字符串)
- - [tp-match-reset](#tp-match-reset---匹配并重置)
- - [tp-match-add](#tp-match-add---匹配并添加)
- - [tp-regexp-set](#tp-regexp-set---匹配正则表达式)
- - [tp-regexp-reset](#tp-regexp-reset---正则匹配并重置)
- - [tp-regexp-add](#tp-regexp-add---正则匹配并添加)
- - [搜索和导航函数](#搜索和导航函数)
- - [tp-search-forward / tp-search-backward](#tp-search-forward--tp-search-backward)
- - [tp-forward / tp-backward](#tp-forward--tp-backward)
- - [tp-forward-do / tp-backward-do](#tp-forward-do--tp-backward-do)
- - [tp-search](#tp-search---搜索所有匹配)
- - [tp-search-map](#tp-search-map---对匹配文本应用函数)
- - [原生文本属性兼容](#原生文本属性兼容)
- - [tp-lookup-result / tp-lookup](#tp-lookup-result--tp-lookup)
- - [tp-property-change](#tp-property-change)
- - [tp-property-any / tp-property-not-all](#tp-property-any--tp-property-not-all)
- - [tp-with-mutation-policy](#tp-with-mutation-policy)
-- [属性层系统](#属性层系统)
- - [自定义文本属性](#自定义文本属性)
- - [文本属性层](#文本属性层)
- - [属性层概念](#属性层概念)
- - [属性层定义](#属性层定义)
- - [define-tp / define-tps](#define-tp--define-tps---定义自定义文本属性)
- - [tp-layer-props / tp-group-props](#tp-layer-props--tp-group-props)
- - [tp-layer-props-with-args / tp-group-props-with-args / tp-layer-arglist](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist)
- - [tp-describe-layer](#tp-describe-layer---描述属性层)
- - [tp-undefine-layer / tp-undefine-group](#tp-undefine-layer--tp-undefine-group)
- - [tp-layer-reset](#tp-layer-reset)
- - [tp-reactive-reset](#tp-reactive-reset)
- - [属性层放置](#属性层放置)
- - [tp-put-layer](#tp-put-layer---在指定位置设置属性层)
- - [tp-push-layer](#tp-push-layer---推送属性层到顶部)
- - [属性层删除](#属性层删除)
- - [tp-delete-layer](#tp-delete-layer---按名称索引删除属性层)
- - [tp-pop-layer](#tp-pop-layer---弹出顶层)
- - [属性层移动](#属性层移动)
- - [tp-move-layer](#tp-move-layer---移动属性层到指定位置)
- - [tp-raise-layer](#tp-raise-layer---上移下移属性层)
- - [tp-lower-layer](#tp-lower-layer---tp-raise-layer-的镜像)
- - [tp-rotate-layer](#tp-rotate-layer---轮换属性层)
- - [tp-pin-layer](#tp-pin-layer---将属性层置顶)
- - [tp-switch-layer](#tp-switch-layer---交换两个属性层)
- - [属性层可见性](#属性层可见性)
- - [tp-hide-layer / tp-show-layer](#tp-hide-layer--tp-show-layer---隐藏与显示属性层)
- - [Managed Layer 生命周期](#managed-layer-生命周期)
- - [tp-attach-managed-layers / tp-detach-managed-layers](#tp-attach-managed-layers--tp-detach-managed-layers)
- - [tp-managed-layer-diagnostics / tp-managed-buffer-diagnostics / tp-managed-diagnostics](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics)
- - [tp-layer-transaction](#tp-layer-transaction)
- - [属性层合并](#属性层合并)
- - [tp-merge-layers](#tp-merge-layers---合并多个属性层)
- - [tp-flatten-layers](#tp-flatten-layers---扁平化所有属性层)
- - [属性层查询函数](#属性层查询函数)
- - [tp-layer-list](#tp-layer-list---列出所有属性层)
- - [tp-layer-count](#tp-layer-count)
- - [tp-layer-exists-p](#tp-layer-exists-p)
- - [tp-layer-top](#tp-layer-top)
- - [tp-layer-stack-at](#tp-layer-stack-at---获取某位置的完整层栈)
- - [tp-add-to-layers](#tp-add-to-layers---向特定属性层添加属性)
- - [tp-add-to-all-layers](#tp-add-to-all-layers---向所有属性层添加属性)
- - [实用工具函数](#实用工具函数)
- - [tp-intervals](#tp-intervals---获取文本属性区间)
- - [tp-intervals-map](#tp-intervals-map---对区间应用函数)
- - [tp-plist](#tp-plist---获取区域中的所有属性)
- - [tp-empty-p](#tp-empty-p---检查对象是否有属性)
- - [tp-region-layer-props](#tp-region-layer-props---获取区域中的层属性)
- - [tp-with-current-buffer / tp-pop-to-buffer / tp-switch-to-buffer](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer)
- - [调色板系统](#调色板系统)
-- [响应式文本属性](#响应式文本属性)
- - [核心概念](#核心概念)
- - [工作原理](#工作原理)
- - [定义响应式层](#定义响应式层)
- - [:data - 附加响应式状态](#data---附加响应式状态)
- - [:compute - 计算属性](#compute---计算属性)
- - [:watch - 副作用回调](#watch---副作用回调)
- - [:transform - 值转换](#transform---值转换)
- - [匿名响应式层](#匿名响应式层)
- - [API 中的层名解析](#api-中的层名解析)
- - [响应式层组](#响应式层组)
- - [批量更新](#批量更新)
- - [层-缓冲区注册表与生命周期](#层-缓冲区注册表与生命周期)
- - [调试模式](#调试模式)
- - [重置响应式状态](#重置响应式状态)
- - [完整示例：主题感知文本](#完整示例主题感知文本)
-- [实用示例](#实用示例)
- - [多属性层语法高亮](#多属性层语法高亮)
- - [状态指示器](#状态指示器)
- - [临时高亮](#临时高亮)
-- [许可证](#许可证)
-- [贡献](#贡献)
-
----
-
-## 快速开始
+- Emacs 28.1 或更高版本。
+- 没有第三方运行时依赖。
```elisp
-;; 安装：克隆仓库，将其加入 load-path，然后 require
-(add-to-list 'load-path "/path/to/tp")
-(require 'tp)
-
-;; 用统一的 API 设置属性（返回一个新的带属性字符串）
-(tp-set "hello" 'face 'bold)
-;; => #("hello" 0 5 (face bold))
-
-;; 在缓冲区区域上堆叠属性层
-(define-tp spotlight () '(face (:background "yellow")))
-(with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 6 'spotlight)
- (tp-layer-top 1 6))
-;; => spotlight
-
-;; 响应式：文本属性跟随变量变化
-(defvar accent-color "red")
-(define-tp accent ()
- :props '(face (:foreground $accent-color)))
-(with-temp-buffer
- (insert "Hello")
- (tp-push-layer 1 6 'accent)
- (setq accent-color "blue") ; 文本自动更新！
- (tp-at 1 'face))
-;; => (:foreground "blue")
-```
-
----
-
-## 概述
-
-**tp.el** 是一个全面增强 Emacs 文本属性操作的库。它不仅仅是对原生文本属性 API（如 `put-text-property`、`get-text-property`）的简单封装，更提供了许多**原生函数所不具备的功能拓展**。tp.el 在以下方面进行了创新：
-
-自 0.2.0 起，本库被组织为一组分层模块（`tp-core`、`tp-style`、`tp-reactive`、`tp-layer`、`tp-ops`、`tp-search`、`tp-render`、`tp-stack`、`tp-query`、`tp-palette`、`tp-builtins`），由伞形文件 `tp.el` 统一加载 — `(require 'tp)` 仍会加载全部模块，对用户没有任何变化。模块一览见[安装](#安装)。
-
-TP 1.0 迁移已经从纯 schema-driven cascade kernel 开始。`tp-style.el` 新增 namespaced property schema、结构化 selector、origin/importance/layer/specificity/scope/source-order 优先级、逐属性继承、带 tag 的 CSS-wide 值、可继承 custom property、显式 `tp-computed` source、Emacs 属性投影和只读 winner provenance。`tp-stylesheet-create` 让每个独立 consumer 拥有自己的 rule、layer 与 source-order domain，不必让无关包共享一份进程全局 stylesheet。这个模块刻意不拥有 buffer、marker、mount 或响应式订阅；后续 retained surface 会建立在同一个 kernel 上。
-
-`tp-reactive.el` 现在也提供 TP 1.0 的精确依赖 runtime：signal 只 invalidates 真实订阅的 binding，binding read 建立 memoized binding→binding edge，条件计算会替换已经失效的旧依赖，最外层 `tp-with-transaction` 对每个 dirty binding 最多 flush 一次。candidate signal write 与 binding value/dependencies 一起提交；compute、cycle、publication 或 transaction participant 失败时一起回滚。`tp-transaction-participate` 允许 client 在 surface 发布后晋升 opaque side state，同时为同一 rollback boundary 提供逆操作。global 和 buffer-local variable adapter 复用同一 graph，不再把文本属性或 buffer scan 当作新 runtime database。
-
-`tp-surface.el` 补全了从 object identity 到 marker-backed mount 和 buffer 的 retained publication 路径。producer 获得短生命周期 prepare context，在计算输出前确保 candidate object，并返回防御性 pure plan 与可选 opaque client state。logical object 可以在没有可见输出时被显式保留，也可以挂到多个不连续 plan fragment；plan 仍不包含 runtime handle 或 position，`tp-object-mounts` 则从 side state 直接解析当前数值范围。TP 在 publication 前验证整个 candidate，执行 common-prefix/suffix text edit 与 property-run diff，并以同一个 revision 切换 plan/index/client state；失败时把所有受影响 buffer 与 signal 一起回滚。`content` 拥有一个不重叠的文本 span；`properties` 装饰 attached host range，检测外部 property conflict，并要求显式 rebase。同一 surface 内的 overlap 可以合成；独立 surface 之间的 overlap 会被拒绝，避免所有权静默分裂。
-
-普通调用者不必手工构造 runtime object，也能使用同一个 core：`tp-propertize` 返回带样式的字符串副本，`tp-apply` 把声明一次性应用到已有 buffer range，`tp-watch` 则让已有 range 的属性随 signal 保持同步。这些入口接受 Emacs 原生 property declarations；`help-echo` 等 callback 保持 literal value，只有显式包装的 `tp-computed` source 才由 cascade 求值。
-
-### 核心创新
-
-1. **统一的 API 参数规范**：所有函数支持多种灵活的调用方式，同时适用于字符串和缓冲区
-2. **子属性的精细操作**：支持嵌套属性的路径式访问、修改和深度合并
-3. **创新的属性层系统**：在同一文本区域上堆叠、管理多组属性，实现属性的分层控制
-4. **🆕 响应式文本属性**：当变量值改变时自动更新文本属性 - 受现代响应式 UI 框架启发的突破性功能
-5. **模式匹配批量操作**：通过字符串或正则表达式批量应用属性
-6. **增强的搜索导航**：丰富的属性搜索和遍历功能
-
-## 功能特性
-
-### 统一的 API 参数规范
-
-原生 Emacs API 针对字符串和缓冲区有不同的函数和参数顺序，tp.el 统一了这一切：
-
-- ✅ **三种调用约定**：所有核心函数（`tp-set`、`tp-get`、`tp-remove` 等）支持三种灵活的调用方式：
- ```elisp
- ;; 1. 当前缓冲区
- (tp-set START END '(face bold))
- ;; 2. 指定缓冲区或字符串
- (tp-set START END '(face bold) OBJECT)
- ;; 3. 整个字符串（平铺属性或层名称）
- (tp-set STRING 'face 'bold 'help-echo "tip")
- (tp-set STRING 'layer-name)
- ```
-- ✅ **统一对象支持**：同一个函数同时支持字符串和缓冲区，无需记忆不同的 API
-
-**只需记住一条规则**：当第一个参数是**字符串**时，调用作用于整个字符串；
-当第一个参数是**数字**时，调用作用于 OBJECT 的 `[START, END)` 区域 —— 而
-OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和层栈函数都遵循
-这条规则。
-
-匹配/搜索家族（`tp-match-*`、`tp-regexp-*`、`tp-search-map`、
-`tp-forward-do`/`tp-backward-do`）刻意采用了**第二种约定**：PATTERN
-（或 FUNCTION）和 PLIST 在前，然后是 OBJECT，最后才是可选的 START/END
-边界。对这些函数来说，作用于整个对象才是常见用法，因此 OBJECT 位于范围
-参数之前而不是之后。
-
-**返回值约定**（自 0.3.0 起）：
-
-| 函数家族 | 返回值 |
-|---|---|
-| `tp-set` / `tp-reset` / `tp-add` | 缓冲区/区域形式返回 `(START . END)`；整字符串形式返回一个**新**字符串 |
-| `tp-remove` | 缓冲区形式返回 nil；整字符串形式返回一个**新**字符串 |
-| `tp-clear` | nil |
-| `tp-match-*` / `tp-regexp-*` | 缓冲区返回 `(START . END)` 匹配列表；字符串返回一个**新**字符串 |
-| 栈修改函数（delete/pop/move/raise/lower/rotate/pin/switch/hide/show/merge/flatten） | 被修改的属性区段数量（0 = 没有匹配任何层） |
-| `tp-put-layer` / `tp-push-layer` | 给定 OBJECT 时返回 OBJECT（字符串形式返回该字符串本身），否则返回 `(START . END)` |
-| `tp-add-to-layers` / `tp-add-to-all-layers` | 字符串形式返回该字符串本身（**就地**修改）；缓冲区返回 nil |
-
-对象、修改性、nil/presence、搜索和 managed layer 的精确契约统一记录在
-[docs/API-SEMANTICS.md](docs/API-SEMANTICS.md)。“统一”指共享同一套高层
-词汇；为保持兼容，当前仍存在少数已记录的字符串/缓冲区返回值差异。
-
-**命名空间地图**：接受*层名*参数的 `tp-layer-NAME` 函数
-（`tp-layer-props`、`tp-layer-arglist` 等）查询的是层**注册表**（层定
-义）；接受*位置*参数的函数 —— START END（`tp-layer-list`、
-`tp-layer-count`、`tp-layer-top` 等）或单个 POS（`tp-layer-stack-at`）
-—— 查询的是实际文本上的层**栈**。
-
-**命名约定**：`tp-define-layer` / `tp-define-group` /
-`tp-define-palette` 是今后符合前缀规范的规范名称（可通过
-`C-h f tp-...` 发现）；`define-tp` / `define-tps` / `define-tp-group` /
-`define-tp-palette` 是永久别名，永远不会被移除（本 README 的示例仍使用
-历史名称）。`tp-search-forward` / `tp-search-backward` 自 0.3.0 起已废
-弃 —— 参见[搜索和导航函数](#tp-search-forward--tp-search-backward)。
-
-### 三种属性操作语义
-
-原生 API 只有简单的设置和获取，tp.el 提供了三种清晰的操作语义：
-
-- ✅ **`tp-reset`**：完全替换 - 清除所有现有属性，设置新属性
-- ✅ **`tp-set`**：部分替换 - 只替换指定属性，保留其他属性
-- ✅ **`tp-add`**：深度合并 - 智能合并嵌套属性，而非简单覆盖
-
-```elisp
-;; 深度合并示例
-(tp-set 1 10 '(face (:foreground "red")))
-(tp-add 1 10 '(face (:background "blue")))
-;; 结果: face 是 (:foreground "red" :background "blue")
-;; 原生 API 会完全覆盖，而 tp-add 会智能合并
-```
-
-### 子属性的精细操作
-
-**这是原生 API 完全不具备的功能**。tp.el 支持对嵌套属性进行精细的读取、修改和删除：
-
-- ✅ **路径式访问**：通过路径语法访问深层嵌套的属性值
- ```elisp
- ;; 获取嵌套属性（tp-get 返回 (START END VALUE) 区间列表）
- (tp-get str 'face :underline :style) ; => ((0 5 wave))
- (tp-at 5 '(face :box :color)) ; => "blue"
-
- ;; 获取多个嵌套键
- (tp-get str 'face :underline '(:color :style))
- ;; => ((0 5 (:color "green" :style wave)))
- ```
-- ✅ **子属性删除**：精确移除嵌套属性中的特定键
- ```elisp
- ;; 只删除 :underline 中的 :style，保留 :color
- (tp-remove 1 10 '(face :underline :style))
- ```
-- ✅ **深度合并**：`tp-add` 递归合并嵌套的 plist 结构
-- ✅ **Face 智能合并**：符号 face 自动前置到 face 列表，plist face 深度合并
-- ✅ **单次设置中的重复属性自动合并**：在一次 `tp-set`/`tp-add`/`tp-reset` 调用中，如果同一属性（如 `face`）被指定多次，它们会自动合并
-
-```elisp
-;; 单次调用中合并多个 face
-(tp-set "emacs"
- 'face 'bold
- 'face '(:background "green")
- 'face '(:foreground "red"))
-;; 结果: face 是 ((:foreground "red") (:background "green") bold)
-;; （各条目堆叠为一个 face 列表，最新的在前）
-
-;; 同一子属性后面的覆盖前面的
-(tp-set "emacs"
- 'face '(:foreground "red")
- 'face '(:foreground "yellow"))
-;; 结果: foreground 是 "yellow"
-
-;; 与 tp-palette 层配合使用
-(tp-set "emacs"
- 'tp-palette 'info
- 'face '(:foreground "red"))
-;; 结果: tp-palette 的 face 与 (:foreground "red") 合并
-```
-
-### 创新的属性层系统
-
-**这是 tp.el 最具创新性的功能**，原生 Emacs 完全不支持。属性层系统允许在同一文本区域上堆叠多组属性：
-
-- ✅ **属性层栈概念**：多个属性层像栈一样堆叠，只有顶层可见，下层被保留
-- ✅ **属性层定义与复用**：通过 `define-tp` 定义可复用的自定义文本属性和属性层
-- ✅ **丰富的属性层操作**：
- - 放置：`tp-put-layer`（指定位置）、`tp-push-layer`（顶部）
- - 删除：`tp-delete-layer`（按名称/索引）、`tp-pop-layer`（顶层）
- - 移动：`tp-raise-layer` / `tp-lower-layer`（上下移动）、`tp-rotate-layer`（轮换）、`tp-pin-layer`（一次性置顶）、`tp-switch-layer`（交换）
- - 可见性：`tp-hide-layer` / `tp-show-layer`（隐藏属性层而不移除它）
- - 合并：`tp-merge-layers`（合并指定层）、`tp-flatten-layers`（扁平化所有层）
-- ✅ **属性层查询**：`tp-layer-list`、`tp-layer-count`、`tp-layer-exists-p`、`tp-layer-top`、`tp-layer-stack-at`
-
-```elisp
-;; 属性层使用示例
-(define-tp highlight () '(face (:background "yellow")))
-(define-tp error () '(face (:foreground "red")))
-
-;; 堆叠多个属性层
-(tp-push-layer 1 10 'highlight)
-(tp-push-layer 1 10 'error) ; error 现在可见
-
-;; 轮换显示
-(tp-rotate-layer 1 10) ; highlight 现在可见
-```
-
-### 模式匹配与批量操作
-
-原生 API 需要手动搜索和循环，tp.el 提供了便捷的模式匹配功能：
-
-- ✅ **字符串匹配**：`tp-match-set`、`tp-match-reset`、`tp-match-add`
-- ✅ **正则匹配**：`tp-regexp-set`、`tp-regexp-reset`、`tp-regexp-add`
-- ✅ **三种语义变体**：每种匹配都支持 set/reset/add 三种操作语义
-
-```elisp
-;; 高亮所有 TODO
-(tp-match-set "TODO" '(face warning))
-
-;; 正则匹配所有数字
-(tp-regexp-set "[0-9]+" '(face font-lock-number-face))
-
-;; 深度合并方式添加属性
-(tp-match-add "TODO" '(face (:underline t)))
-```
-
-### 🆕 响应式文本属性
-
-**这是 tp.el 最具创新性的新功能** - 响应式文本属性会在变量值改变时自动更新。受现代响应式 UI 框架（如 Vue.js）启发，这个功能为 Emacs 文本属性带来了响应式编程范式：
-
-- ✅ **响应式变量**：在属性定义中使用 `$` 前缀的符号（如 `$my-color`），它们会自动解析为变量值
-- ✅ **自动更新**：当响应式变量改变时，所有使用该变量的文本区域会自动更新
-- ✅ **:data 附加状态**：定义不直接用于属性但可以触发更新的额外响应式变量
-- ✅ **:compute 计算属性**：创建从其他响应式变量派生值的计算属性（类似 Vue 的 computed）
-- ✅ **:watch 副作用监听**：当响应式变量改变时执行回调函数（类似 Vue 的 watch）
-- ✅ **定向更新（0.3.0）**：层→缓冲区注册表使更新只访问展示受影响层的缓冲区；`tp-text` 重渲染只编辑差异区段（point 和标记保持原位）；`tp-reactive-track-buffer` / `tp-gc-anonymous-layers` 管理层的生命周期 —— 参见[层-缓冲区注册表与生命周期](#层-缓冲区注册表与生命周期)
-
-```elisp
-;; 定义一个带响应式属性的层
-(defvar my-color "red") ;; 响应式变量
-
-;; 使用 define-tp 定义自定义文本属性（推荐方式）
-(define-tp my-highlight ()
- '(face (:foreground $my-color)))
-
-;; 应用该层
-(tp-push-layer 1 10 'my-highlight)
-
-;; 之后只需改变变量 - 文本自动更新！
-(setq my-color "blue") ;; 所有 my-highlight 层的文本自动变成蓝色！
-
-;; 使用 :data、:compute、:watch 的高级示例
-;; （注意：参数列表 () 是必需的，且各关键字的值必须加引号）
-(define-tp full-name-layer ()
- :props '(help-echo $full-name face (:foreground $name-color))
- :data '((first-name . "John") (last-name . "Doe") (name-color . "purple"))
- :compute '((full-name (lambda () (concat first-name " " last-name))))
- :watch '((first-name (lambda (new old layer)
- (message "名字从 %s 改为 %s" old new)))))
-```
-
-### 增强的搜索与导航
-
-- ✅ **范围搜索**：`tp-search` 返回所有匹配区间的列表
-- ✅ **N次搜索**：`tp-forward`/`tp-backward` 支持向前/向后搜索N次，并支持可选的 PREDICATE 匹配和 NOT-CURRENT
-- ✅ **搜索并执行**：`tp-forward-do`/`tp-backward-do` 搜索 N 次并在第 N 个匹配处应用函数
-- ✅ **批量转换**：`tp-search-map` 对所有匹配应用转换函数
-
-```elisp
-;; 搜索所有标记
-(tp-search my-string 'marker) ; => ((0 5 t) (12 17 t))
-
-;; 将所有标记文本转为大写
-(tp-search-map #'upcase 'marker tp-any-value my-string)
-```
-
-## 系统要求
-
-- **Emacs 28.1+**（使用 `object-intervals` 函数）
-- **dash.el 2.19.1+**（列表操作工具库）
-
-## 安装
-
-本库由 `tp-*.el` 模块家族加上伞形文件 `tp.el` 组成。安装即把目录加入
-`load-path` 并 require 伞形文件，它会加载全部模块：
-
-```elisp
-;; 添加到 load-path
(add-to-list 'load-path "/path/to/tp")
(require 'tp)
```
-或使用 `use-package`：
+## 选择最小的公共入口
+
+| 需求 | API | 是否建立 live runtime |
+| --- | --- | --- |
+| 返回带属性的字符串 | `tp-propertize` | 否 |
+| 一次性装饰已有 buffer 范围 | `tp-apply` | 否 |
+| 响应式装饰 host-owned 文本 | `tp-watch` | 是，`properties` capability |
+| 管理 retained text content | `tp-surface-mount` / `tp-surface-update` | 是，`content` capability |
+| 检查或卸载 retained publication | `tp-surface-report` / `tp-surface-inspect` / `tp-surface-unmount` | 是 |
+
+一次性 API 和 retained API 使用相同的 property policy 与 projection 语义。一次性调用不会创建 object、binding、marker、subscription 或 surface state。
+
+## 静态文本属性
```elisp
-(use-package tp
- :load-path "/path/to/tp")
+(let* ((callback (lambda (_window _object _position) "Open"))
+ (text
+ (tp-propertize
+ "Hello"
+ (list 'face '(:foreground "white" :background "navy")
+ 'help-echo callback
+ 'keymap nil))))
+ text)
```
-各模块及其职责：
+显式 `nil` 和属性不存在是两种状态。上例中的 `keymap` 存在且值为 `nil`。函数对象始终是 literal data，因此 TP 会保留 `callback`，不会调用它。
-| 模块 | 职责 |
-|---|---|
-| `tp-core.el` | 区间、plist/face 合并引擎、调试日志、`$var` 工具 |
-| `tp-style.el` | namespaced property schema、结构化 selector、cascade、custom property 和显式 computed value |
-| `tp-reactive.el` | 精确 signal、memoized binding、transaction、scoped variable adapter 和临时 legacy watcher state |
-| `tp-surface.el` | retained plan、prepare/object lifecycle、range anchor、mount、side index、diff、report 和原子 publication |
-| `tp-layer.el` | `define-tp` / `define-tps`、属性层注册表与解析 |
-| `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` |
-| `tp-search.el` | `tp-match-*`、`tp-regexp-*`、`tp-search`、导航 |
-| `tp-render.el` | 响应式重渲染引擎 |
-| `tp-stack.el` | 属性层栈操作（push/pop/移动/合并/扁平化/...） |
-| `tp-query.el` | 原生文本查询/change 封装与修改策略 |
-| `tp-palette.el` | 亮色/暗色调色板数据 |
-| `tp-builtins.el` | 内置属性层、调色板画廊、display-buffer 辅助工具 |
-
-项目附带 `Makefile`，测试源码统一位于 `tests/`：`make test` 运行所有 ERT
-测试套件，`make doctest` 将 README 示例作为可执行测试运行
-（`tests/tp-doctest.el`），`make compile`
-字节编译各模块，`make clean` 清除编译产物。
-
----
-
-## API 参考
-
-### API 快速参考
-
-tp.el 所有函数按类别组织的完整概览：
-
-#### 核心属性函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-set`](#tp-set---设置文本属性) | 设置文本属性（仅替换指定属性） |
-| [`tp-reset`](#tp-reset---替换所有属性) | 替换所有文本属性 |
-| [`tp-add`](#tp-add---添加合并属性) | 添加/合并属性，支持深度合并 |
-| [`tp-get`](#tp-get---获取属性值) | 从范围或字符串获取属性值 |
-| [`tp-at`](#tp-at---获取位置属性) | 获取单个位置的属性值 |
-| [`tp-member`](#tp-member---判断位置属性是否存在) | 类似 `tp-at`，但能区分"存在且值为 nil"与"不存在" |
-| [`tp-remove`](#tp-remove---移除属性) | 移除属性或子属性 |
-| [`tp-clear`](#tp-clear---清除所有属性) | 清除区域中的所有文本属性 |
-
-#### 模式匹配函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-match-set`](#tp-match-set---匹配字符串) | 在字符串匹配处设置属性（可选边界） |
-| [`tp-match-reset`](#tp-match-reset---匹配并重置) | 在字符串匹配处重置所有属性（可选边界） |
-| [`tp-match-add`](#tp-match-add---匹配并添加) | 在字符串匹配处添加/合并属性（可选边界） |
-| [`tp-regexp-set`](#tp-regexp-set---匹配正则表达式) | 在正则匹配处设置属性（可选边界和捕获组） |
-| [`tp-regexp-reset`](#tp-regexp-reset---正则匹配并重置) | 在正则匹配处重置所有属性（可选边界和捕获组） |
-| [`tp-regexp-add`](#tp-regexp-add---正则匹配并添加) | 在正则匹配处添加/合并属性（可选边界和捕获组） |
-
-#### 搜索和导航函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-search-forward`](#tp-search-forward--tp-search-backward) | **已废弃（0.3.0）** —— 请使用 [`tp-forward`](#tp-forward--tp-backward) 或 Emacs 原语 |
-| [`tp-search-backward`](#tp-search-forward--tp-search-backward) | **已废弃（0.3.0）** —— 请使用 [`tp-backward`](#tp-forward--tp-backward) 或 Emacs 原语 |
-| [`tp-forward`](#tp-forward--tp-backward) | 向前搜索 N 次具有属性的文本（可选谓词匹配） |
-| [`tp-backward`](#tp-forward--tp-backward) | 向后搜索 N 次具有属性的文本（可选谓词匹配） |
-| [`tp-forward-do`](#tp-forward-do--tp-backward-do) | 向前搜索 N 次，在第 N 个匹配处应用函数 |
-| [`tp-backward-do`](#tp-forward-do--tp-backward-do) | 向后搜索 N 次，在第 N 个匹配处应用函数 |
-| [`tp-search`](#tp-search---搜索所有匹配) | 在范围或字符串中搜索所有匹配的属性 |
-| [`tp-search-map`](#tp-search-map---对匹配文本应用函数) | 对所有匹配的文本应用函数（支持起始和结束范围） |
-
-#### 原生文本属性兼容
-| 函数 | 描述 |
-|------|------|
-| [`tp-lookup`](#tp-lookup-result--tp-lookup) | text-only 的 direct/effective/source-aware 属性查询 |
-| [`tp-lookup-result`](#tp-lookup-result--tp-lookup) | `tp-lookup` 返回的结果记录 |
-| [`tp-property-change`](#tp-property-change) | next/previous single-property 或 all-property change 位置封装 |
-| [`tp-property-any`](#tp-property-any--tp-property-not-all) | `text-property-any` 封装 |
-| [`tp-property-not-all`](#tp-property-any--tp-property-not-all) | `text-property-not-all` 封装 |
-| [`tp-with-mutation-policy`](#tp-with-mutation-policy) | 显式 modified/read-only 修改策略封装 |
-
-#### Schema-driven Cascade
-
-| 函数 | 描述 |
-|------|------|
-| `tp-define-property` / `tp-property-schema` | 原子注册并查询 namespaced property schema |
-| `tp-text-property-id` / `tp-register-text-property` / `tp-text-declarations` | 把原生 Emacs property 映射到 canonical `text/` domain |
-| `tp-subject-create` / `tp-subject-set-children` | 构造与具体 consumer 无关的 selector subject 和关系 |
-| `tp-selector-match-p` / `tp-selector-specificity` | 匹配结构化 selector AST 并计算 specificity |
-| `tp-define-style` / `tp-style-declarations` / `tp-undefine-style` | 注册、查询并移除防御性复制的 named declarations |
-| `tp-stylesheet-create` / `tp-stylesheet-add-rule` | 创建隔离的 rule/layer domain，并添加支持 origin/layer/scope 的结构化 rule |
-| `tp-wide-value` / `tp-important` / `tp-var` | 构造无歧义 cascade 值，不占用普通 Elisp symbol |
-| `tp-computed` | 标记 TP 唯一应该执行的 function value |
-| `tp-compute-style` / `tp-project-style` | 计算 canonical values/provenance 并投影最终 Emacs text properties |
-| `tp-style-reset-rules` / `tp-style-reset` | 重置某个隔离/default stylesheet，或重置 TP 的全局 schema、named style 与 default stylesheet |
-
-#### Signals 与 Bindings
-
-| 函数 | 描述 |
-|------|------|
-| `tp-signal-create` / `tp-signal-read` / `tp-signal-set` | 创建、依赖收集并 transactionally 更新 reactive source |
-| `tp-signal-peek` / `tp-signal-live-p` / `tp-signal-subscriber-count` / `tp-signal-dispose` | 不收集依赖地检查或显式结束 signal lifecycle |
-| `tp-bind` / `tp-binding-read` | 按 owner+key 幂等安装 memoized computation，并把读取登记为依赖 |
-| `tp-binding-live-p` / `tp-binding-dependency-count` / `tp-binding-subscriber-count` | 检查 binding lifecycle 与精确 graph degree |
-| `tp-binding-dispose-owner` | 删除 owner 的 bindings 及全部 graph edges |
-| `tp-with-transaction` | 批量冻结 candidate write，并原子发布一次去重后的 dirty closure |
-| `tp-transaction-participate` | 在 publication boundary 内晋升 client side state，并提供显式 rollback action |
-| `tp-variable-signal` | 把 global 或 buffer-local Elisp variable 适配为 scoped signal |
-| `tp-reactive-counters` / `tp-reactive-reset-counters` | 读取或重置 public scheduler work counters |
-
-#### Retained Surfaces
-
-| 函数 | 描述 |
-|------|------|
-| `tp-surface-plan-create` / `tp-surface-result-create` | 构造防御性 pure plan data，并附带可选 opaque client state |
-| `tp-object-ensure` / `tp-object-retain` / `tp-object-resolve` | 分配 candidate identity、显式保留 logical object，或按 key path 解析 committed identity |
-| `tp-object-attach-fragment` / `tp-object-mounts` | 让一个 logical object 拥有不连续 output mounts，并读取防御性的数值 range/tag snapshot |
-| `tp-range-anchor-create` / `tp-object-attach-range` / `tp-range-rebase` | 挂载 host-owned text range，不把 position 放进 plan |
-| `tp-surface-materialize-string` | 物化 plan 或 ephemeral producer，不留下 live identity、marker 或 subscription |
-| `tp-surface-mount` / `tp-surface-update` / `tp-surface-unmount` | 唯一 live publication lifecycle |
-| `tp-surface-at-point` / `tp-surface-inspect` / `tp-surface-report` | 不扫描文本地查询 retained side index 与 generic commit diagnostics |
-
-#### 便利 API
-
-| 函数 | 描述 |
-|------|------|
-| `tp-propertize` | 通过 schema/cascade/projector core 返回带样式的字符串副本 |
-| `tp-apply` | 把原生 declarations 一次性应用到已有 buffer range |
-| `tp-watch` | 通过 properties surface 响应式维护已有 range 上的 declarations |
-
-#### 属性层定义函数
-| 函数 | 描述 |
-|------|------|
-| [`define-tp`](#define-tp--define-tps---定义自定义文本属性) | 定义自定义文本属性（层），支持可选参数 |
-| [`define-tps`](#define-tp--define-tps---定义自定义文本属性) | 定义自定义文本属性组（层组），支持可选参数 |
-| [`tp-define-layer` / `tp-define-group`](#define-tp--define-tps---定义自定义文本属性) | `define-tp` / `define-tps` 的前缀规范别名 |
-| [`tp-layer-props`](#tp-layer-props--tp-group-props) | 获取属性层的属性 |
-| [`tp-group-props`](#tp-layer-props--tp-group-props) | 获取属性层组中所有属性层的属性 |
-| [`tp-layer-props-with-args`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | 用参数列表展开参数化属性层 |
-| [`tp-group-props-with-args`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | 用参数列表展开参数化属性层组 |
-| [`tp-layer-arglist`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | 获取参数化属性层的参数列表 |
-| [`tp-describe-layer`](#tp-describe-layer---描述属性层) | 在帮助缓冲区中描述属性层的定义 |
-| [`tp-undefine-layer`](#tp-undefine-layer--tp-undefine-group) | 移除属性层定义 |
-| [`tp-undefine-group`](#tp-undefine-layer--tp-undefine-group) | 移除属性层组定义 |
-| [`tp-layer-reset`](#tp-layer-reset) | 清除所有属性层/属性层组定义 |
-| [`tp-reactive-reset`](#tp-reactive-reset) | 清除所有响应式依赖和监听器 |
-
-#### 属性层放置函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-put-layer`](#tp-put-layer---在指定位置设置属性层) | 在指定索引位置设置属性层（可选 NOERROR） |
-| [`tp-push-layer`](#tp-push-layer---推送属性层到顶部) | 将属性层推到堆栈顶部（可选 NOERROR） |
-
-#### 属性层删除函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-delete-layer`](#tp-delete-layer---按名称索引删除属性层) | 按名称或索引删除属性层 |
-| [`tp-pop-layer`](#tp-pop-layer---弹出顶层) | 移除顶层属性层 |
-
-#### 属性层移动函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-move-layer`](#tp-move-layer---移动属性层到指定位置) | 将属性层从一个位置移动到另一个位置 |
-| [`tp-raise-layer`](#tp-raise-layer---上移下移属性层) | 将属性层上移/下移 N 个位置 |
-| [`tp-lower-layer`](#tp-lower-layer---tp-raise-layer-的镜像) | `tp-raise-layer` 的镜像：将属性层下移/上移 N 个位置 |
-| [`tp-rotate-layer`](#tp-rotate-layer---轮换属性层) | 向上或向下轮换属性层 N 步 |
-| [`tp-pin-layer`](#tp-pin-layer---将属性层置顶) | 将属性层移到顶部（一次性；之后的 push 仍可能覆盖它） |
-| [`tp-switch-layer`](#tp-switch-layer---交换两个属性层) | 交换两个属性层的位置 |
-
-#### 属性层可见性函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-hide-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) | 隐藏属性层而不将其从栈中移除 |
-| [`tp-show-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) | 让隐藏的属性层重新渲染 |
-
-#### Managed Layer 生命周期
-| 函数 | 描述 |
-|------|------|
-| [`tp-attach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | 将插入/复制进来的 managed layer storage 登记到当前缓冲区注册表 |
-| [`tp-detach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | 移除 managed storage，可选保留当前可见渲染属性 |
-| [`tp-managed-layer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 某一层的只读诊断 |
-| [`tp-managed-buffer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 某一缓冲区的只读诊断 |
-| [`tp-managed-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 全局 managed lifecycle 只读诊断 |
-| [`tp-layer-transaction`](#tp-layer-transaction) | 以失败回滚方式执行 managed stack 修改 |
-
-#### 属性层合并函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-merge-layers`](#tp-merge-layers---合并多个属性层) | 将指定属性层合并为新属性层（隐藏层不贡献属性） |
-| [`tp-flatten-layers`](#tp-flatten-layers---扁平化所有属性层) | 将所有属性层扁平化为单一属性层（隐藏层被丢弃） |
-
-#### 属性层查询函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-layer-list`](#tp-layer-list---列出所有属性层) | 列出区域中的所有属性层名称 |
-| [`tp-layer-count`](#tp-layer-count) | 计算区域中的属性层数量 |
-| [`tp-layer-exists-p`](#tp-layer-exists-p) | 检查区域中是否存在某属性层 |
-| [`tp-layer-top`](#tp-layer-top) | 获取顶层属性层的名称（按栈序，即使它被隐藏） |
-| [`tp-layer-stack-at`](#tp-layer-stack-at---获取某位置的完整层栈) | 以 `(NAME . PROPS)` cons 形式返回某位置的完整有序层栈 |
-| [`tp-region-layer-props`](#tp-region-layer-props---获取区域中的层属性) | 获取区域中特定层的属性 |
-
-#### 属性层操作函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-add-to-layers`](#tp-add-to-layers---向特定属性层添加属性) | 通过索引或名称向特定层添加/合并属性 |
-| [`tp-add-to-all-layers`](#tp-add-to-all-layers---向所有属性层添加属性) | 向所有现有层添加/合并属性 |
-
-#### 实用工具函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-intervals`](#tp-intervals---获取文本属性区间) | 获取区域中的所有文本属性区间（可选 ABSOLUTE 坐标） |
-| [`tp-intervals-map`](#tp-intervals-map---对区间应用函数) | 对区域中的所有区间应用函数（可选 ABSOLUTE 坐标） |
-| [`tp-plist`](#tp-plist---获取区域中的所有属性) | 获取区域中存在的所有属性 |
-| [`tp-empty-p`](#tp-empty-p---检查对象是否有属性) | 检查对象是否没有文本属性 |
-| [`tp-with-current-buffer`](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer) | 在绑定 `inhibit-read-only` 的情况下在缓冲区中执行 body |
-| [`tp-pop-to-buffer`](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer) | 填充缓冲区、设为只读并通过 `pop-to-buffer` 显示 |
-| [`tp-switch-to-buffer`](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer) | 填充缓冲区、设为只读并通过 `switch-to-buffer` 显示 |
-
-#### 调色板函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-palette-alist`](#调色板系统) | 具名调色板注册表（变量） |
-| [`define-tp-palette`](#调色板系统) | 注册或更新一个具名调色板（别名：`tp-define-palette`） |
-| [`tp-palette-color`](#调色板系统) | 获取调色板的 `:fg` / `:bg` / `:border` 颜色，按主题解析 |
-| [`tp-palette-has-p`](#调色板系统) | 测试调色板（或其某个键）是否已定义 |
-| [`tp-palette-show`](#调色板系统) | 展示所有已注册调色板的画廊 |
-| [`tp-parse-color`](#调色板系统) | 按当前亮色/暗色主题解析颜色规格 |
-
-#### 响应式生命周期函数
-| 函数 | 描述 |
-|------|------|
-| [`tp-with-batch-updates`](#批量更新) | 将多个响应式变量更改合并为一次更新 |
-| [`tp-reactive-layer-buffers`](#层-缓冲区注册表与生命周期) | 注册为展示某层的缓冲区（或 `unknown`） |
-| [`tp-reactive-track-buffer`](#层-缓冲区注册表与生命周期) | 插入已带属性的字符串后注册缓冲区 |
-| [`tp-gc-anonymous-layers`](#层-缓冲区注册表与生命周期) | 回收已无注册的存活缓冲区展示的匿名层 |
-
----
-
-### 核心属性函数
-
-> **重要：字符串修改行为**
->
-> 核心属性函数（`tp-set`、`tp-reset`、`tp-add`、`tp-remove`）根据调用方式有不同的行为：
->
-> | 调用方式 | 底层实现 | 是否修改原始对象？ |
-> |---------|---------|------------------|
-> | `(tp-set STRING PROP VAL ...)` | 内部使用 `propertize` | **否** - 返回新字符串 |
-> | `(tp-set START END PROPS)` | 对缓冲区使用 `put-text-property` | 是 - 修改当前缓冲区 |
-> | `(tp-set START END PROPS STRING)` | 对字符串使用 `put-text-property` | **是** - 修改原始字符串 |
-> | `(tp-set START END PROPS BUFFER)` | 对缓冲区使用 `put-text-property` | 是 - 修改缓冲区 |
->
-> **总结：**
-> - **整个字符串形式** `(tp-set "string" ...)`：创建一个**新的**带属性字符串。原始字符串不会被修改。内部使用 `propertize` 实现。
-> - **区域形式（字符串对象）** `(tp-set 0 5 '(...) string)`：使用 `put-text-property` 或 `set-text-properties` **直接修改**原始字符串对象。
-> - **缓冲区形式**：始终就地修改缓冲区。
->
-> 这一区别适用于所有核心属性函数：`tp-set`、`tp-reset`、`tp-add` 和 `tp-remove`。
-
-#### `tp-set` - 设置文本属性
-
-在字符串或缓冲区区域上设置文本属性。只替换指定的属性，保留其他属性。
+一次性修改已有范围而不改变文字：
```elisp
-;; 当前缓冲区（属性作为列表）- 就地修改缓冲区
-(tp-set START END '(PROPERTY VALUE ...))
-(tp-set START END LAYER-NAME)
-
-;; 特定缓冲区或字符串 - 就地修改 OBJECT
-(tp-set START END '(PROPERTY VALUE ...) OBJECT)
-(tp-set START END LAYER-NAME OBJECT)
-
-;; 整个字符串（平铺属性或层名称）- 返回新字符串
-(tp-set STRING PROPERTY VALUE ...)
-(tp-set STRING LAYER-NAME)
-```
-
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-
-**返回值：**
-- 缓冲区形式：返回 `(START . END)` 点对
-- 字符串区域形式 `(tp-set 0 5 '(...) string)`：返回修改后的字符串（同一对象）
-- 整个字符串形式 `(tp-set "string" ...)`：返回一个**新的**带属性字符串
-
-**示例：**
-
-```elisp
-;; 在缓冲区区域设置 face
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold)))
-;; => (1 . 10)
-
-;; 设置多个属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold help-echo "Click me")))
-;; => (1 . 10)
-
-;; 在特定缓冲区设置
-(let ((my-buffer (generate-new-buffer "*test*")))
- (with-current-buffer my-buffer
- (insert "Hello World"))
- (prog1 (tp-set 1 10 '(face italic) my-buffer)
- (kill-buffer my-buffer)))
-;; => (1 . 10)
-
-;; 在字符串区域设置属性（0 索引）- 修改原始字符串
-(let ((my-string (copy-sequence "Hello World")))
- (tp-set 0 5 '(face italic) my-string)
- my-string)
-;; => #("Hello World" 0 5 (face italic))
-
-;; 在整个字符串上设置属性 - 返回新字符串，原始字符串不变
-(let ((original "Hello"))
- (let ((result (tp-set original 'face 'bold)))
- (list :original original
- :result result
- :original-has-props (get-text-property 0 'face original)
- :result-has-props (get-text-property 0 'face result))))
-;; => (:original "Hello" :result #("Hello" 0 5 (face bold))
-;; :original-has-props nil :result-has-props bold)
-
-;; 在整个字符串上使用已定义的层名称
-(define-tp my-style ()
- :props '(face (:foreground $my-color))
- :data '((my-color . "blue")))
-(tp-set " " 'my-style)
-;; => #(" " 0 1 (face (:foreground "blue") tp-name my-style))
-;; （属性的打印顺序在不同 Emacs 版本间可能不同，值本身一致）
-
-;; 单次调用中合并多个 face（重复属性自动合并）
-(tp-set "emacs"
- 'face 'bold
- 'face '(:background "green")
- 'face '(:foreground "red"))
-;; => face 是 ((:foreground "red") (:background "green") bold)
-;; （各条目堆叠为一个 face 列表，最新的在前）
-
-;; 同一子属性后面的值覆盖前面的
-(tp-set "emacs"
- 'face '(:foreground "red")
- 'face '(:foreground "yellow"))
-;; => face 的 :foreground 是 "yellow"（后面的覆盖前面的）
-
-;; 与 tp-palette 层配合使用，合并额外的 face 属性
-(tp-set "emacs"
- 'tp-palette 'info
- 'face '(:foreground "red"))
-;; => tp-palette 的 face 与 (:foreground "red") 合并，:foreground 被覆盖
-```
-
----
-
-#### `tp-reset` - 替换所有属性
-
-用指定的属性完全替换所有文本属性。
-
-```elisp
-;; 缓冲区/区域形式 - 就地修改
-(tp-reset START END '(PROPERTY VALUE ...) &optional OBJECT)
-(tp-reset START END LAYER-NAME &optional OBJECT)
-
-;; 整个字符串形式 - 返回新字符串
-(tp-reset STRING PROPERTY VALUE ...)
-```
-
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-
-**返回值：**
-- 缓冲区形式：返回 `(START . END)` 点对
-- 字符串区域形式：返回修改后的字符串（同一对象）
-- 整个字符串形式：返回一个**新的**带属性字符串
-
-**示例：**
-
-```elisp
-;; 替换区域中的所有属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(help-echo "old")) ; 设置已有属性
- (tp-reset 1 10 '(face bold)) ; 任何现有属性都会被移除
- (tp-at 1))
-;; => (face bold) ; help-echo 被移除了
-
-;; 在整个字符串上 - 返回新字符串，原始字符串不变
-(let ((original "Hello"))
- (let ((result (tp-reset original 'face 'italic)))
- (list :original-modified (get-text-property 0 'face original)
- :result-face (get-text-property 0 'face result))))
-;; => (:original-modified nil :result-face italic)
-
-;; 使用已定义的层名称
-(define-tp error-style ()
- '(face (:foreground "red" :weight bold)))
-(with-temp-buffer
- (insert "Hello World")
- (tp-reset 1 10 'error-style))
-;; => (1 . 10) ; 所有属性被 error-style 替换
-```
-
----
-
-#### `tp-add` - 添加/合并属性
-
-添加或更新属性，支持嵌套属性列表的深度合并。
-
-```elisp
-;; 缓冲区/区域形式 - 就地修改
-(tp-add START END '(PROPERTY VALUE ...) &optional OBJECT)
-(tp-add START END LAYER-NAME &optional OBJECT)
-
-;; 整个字符串形式 - 返回新字符串
-(tp-add STRING PROPERTY VALUE ...)
-```
-
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-
-**返回值：**
-- 缓冲区形式：返回 `(START . END)` 点对
-- 字符串区域形式：返回修改后的字符串（同一对象）
-- 整个字符串形式：返回一个**新的**带属性字符串
-
-**示例：**
-
-```elisp
-;; 添加属性（保留现有，合并嵌套）
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold))
- (tp-add 1 10 '(help-echo "tooltip"))
- (tp-at 1))
-;; => (face bold help-echo "tooltip")
-
-;; 深度合并 face 属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:foreground "red")))
- (tp-add 1 10 '(face (:background "blue")))
- (tp-at 1 'face))
-;; => (:foreground "red" :background "blue")
-
-;; 整个字符串形式 - 返回新字符串，原始字符串不变
-(let ((original "Hello"))
- (let ((result (tp-add original 'face 'bold)))
- (list :original-modified (get-text-property 0 'face original)
- :result-face (get-text-property 0 'face result))))
-;; => (:original-modified nil :result-face bold)
-
-;; 使用已定义的层名称
-(define-tp highlight-style ()
- '(face (:background "yellow")))
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold))
- (tp-add 1 10 'highlight-style)
- (tp-at 1))
-;; => 属性与 highlight-style 合并
-```
-
----
-
-#### `tp-get` - 获取属性值
-
-从范围或字符串获取属性值，支持嵌套子属性访问。
-
-返回 `(START END VALUE)` 区间列表，让你可以查看范围内所有的属性值。
-
-对于单个位置的查询，请使用 `tp-at`。
-
-```elisp
-;; 范围 - 特定属性（返回区间列表）
-(tp-get START END PROPERTY)
-(tp-get START END PROPERTY OBJECT)
-
-;; 范围 - 属性路径作为列表
-(tp-get START END '(PROPERTY) OBJECT)
-(tp-get START END '(PROPERTY SUB-KEY ...) OBJECT)
-
-;; 范围 - 深层嵌套属性路径
-(tp-get START END '(PROPERTY SUB-KEY SUB-SUB-KEY ...) OBJECT)
-
-;; 范围 - 从嵌套属性中提取多个键
-(tp-get START END '(PROPERTY SUB-KEY (KEY1 KEY2 ...)) OBJECT)
-
-;; 范围 - 所有属性（返回区间列表）
-(tp-get START END)
-(tp-get START END OBJECT)
-
-;; 整个字符串（返回区间列表）
-(tp-get STRING)
-(tp-get STRING PROPERTY)
-(tp-get STRING PROPERTY SUB-KEY ...)
-(tp-get STRING PROPERTY SUB-KEY '(KEY1 KEY2 ...))
-(tp-get STRING '(PROPERTY SUB-KEY ...))
-```
-
-**示例：**
-
-```elisp
-;; 从范围获取 - 返回 (START END VALUE) 区间列表
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-get 1 10 'face))
-;; => ((1 6 bold))
-
-;; 获取多个区间
-(let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-set 12 17 '(face italic) str)
- (tp-get 0 17 'face str))
-;; => ((0 5 bold) (12 17 italic))
-
-;; 使用列表形式的属性路径
-(let ((my-string (copy-sequence "Hello World Hello World")))
- (tp-set 5 20 '(face (:underline (:style wave))) my-string)
- (tp-get 5 20 '(face :underline :style) my-string))
-;; => ((5 20 wave))
-
-;; 从整个字符串获取深层嵌套属性
-(let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face (:underline (:color "green"))) str)
- (tp-set 6 11 '(face (:underline (:color "yellow"))) str)
- (tp-get str 'face :underline :color))
-;; => ((0 5 "green") (6 11 "yellow"))
-
-;; 从嵌套属性中获取多个键
-(let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face (:underline (:color "green" :style wave))) str)
- (tp-set 6 11 '(face (:underline (:color "yellow" :style line))) str)
- (tp-get str 'face :underline '(:color :style)))
-;; => ((0 5 (:color "green" :style wave)) (6 11 (:color "yellow" :style line)))
-
-;; 获取范围内的所有属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold help-echo "test"))
- (tp-get 1 10))
-;; => ((1 6 (face bold help-echo "test")))
-
-;; 从整个字符串获取 - 返回区间列表
-(let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-set 12 17 '(face italic) str)
- (list (tp-get str) ; => ((0 5 (face bold)) (12 17 (face italic)))
- (tp-get str 'face))) ; => ((0 5 bold) (12 17 italic))
-;; => (((0 5 (face bold)) (12 17 (face italic))) ((0 5 bold) (12 17 italic)))
-```
-
----
-
-#### `tp-at` - 获取位置属性
-
-```elisp
-;; 获取位置的所有属性
-(tp-at POS)
-(tp-at POS OBJECT)
-
-;; 获取位置的特定属性
-(tp-at POS PROPERTY)
-(tp-at POS PROPERTY OBJECT)
-
-;; 获取位置的嵌套子属性
-(tp-at POS '(PROPERTY SUB-KEY ...))
-(tp-at POS '(PROPERTY SUB-KEY ...) OBJECT)
-```
-
-获取 POS 位置的文本属性，可选择按 PROPERTY 过滤。
-
-对于单位置属性查询（以前使用 `tp-get`），现在使用 `tp-at`。
-
-**示例：**
-
-```elisp
-;; 获取当前缓冲区位置 5 的所有属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold help-echo "test"))
- (tp-at 5))
-;; => (face bold help-echo "test")
-
-;; 获取字符串位置 0 的所有属性
-(let ((my-string (tp-set "Hello" 'face 'italic 'help-echo "greeting")))
- (tp-at 0 my-string))
-;; => (face italic help-echo "greeting")
-
-;; 获取位置的特定属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold))
- (tp-at 5 'face))
-;; => bold
-
-;; 获取字符串位置的特定属性
-(let ((my-string (tp-set "Hello" 'face 'italic)))
- (tp-at 0 'face my-string))
-;; => italic
-
-;; 获取位置的嵌套子属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:foreground "red" :box (:color "blue"))))
- (list (tp-at 5 '(face :foreground))
- (tp-at 5 '(face :box :color))))
-;; => ("red" "blue")
-
-;; 从字符串获取嵌套子属性
-(let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face (:foreground "red" :underline t)) str)
- (tp-at 0 '(face :foreground) str))
-;; => "red"
-```
-
----
-
-#### `tp-member` - 判断位置属性是否存在
-
-```elisp
-(tp-member POS PROPERTY &optional OBJECT)
-```
-
-类似 `tp-at`，但当 PROPERTY 在 POS 处存在时返回 `(PROPERTY VALUE)` 列表，不存在时返回 nil。由此可以区分"属性存在且值为 nil"与"属性完全不存在"（类似 `plist-member`）。
-
-**示例：**
-
-```elisp
-;; 存在且值为 nil vs. 不存在
-(let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face nil) str)
- (list (tp-member 0 'face str) ; 存在，值为 nil
- (tp-member 0 'display str))) ; 不存在
-;; => ((face nil) nil)
-
-;; 在缓冲区中
-(with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold))
- (tp-member 1 'face))
-;; => (face bold)
-```
-
----
-
-#### `tp-remove` - 移除属性
-
-从区域或整个字符串中移除属性或嵌套子属性。
-
-```elisp
-;; 移除整个属性（缓冲区）- 就地修改
-(tp-remove START END PROPERTY &optional OBJECT)
-
-;; 移除子属性（缓冲区）- 就地修改
-(tp-remove START END '(PROPERTY SUB-KEY) &optional OBJECT)
-
-;; 移除嵌套子属性（缓冲区）- 就地修改
-(tp-remove START END '(PROPERTY SUB-KEY (NESTED-KEYS...)) &optional OBJECT)
-
-;; 从整个字符串移除 - 返回新字符串
-(tp-remove STRING PROP1 PROP2 ...)
-(tp-remove STRING PROPERTY SUB-KEY)
-(tp-remove STRING PROPERTY SUB-KEY '(NESTED-KEYS...))
-```
-
-**返回值：**
-- 缓冲区形式：返回 `nil`
-- 整个字符串形式：返回一个**新的**移除了属性的字符串
-
-**示例：**
-
-```elisp
-;; 移除整个属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold help-echo "test"))
- (tp-remove 1 10 'face)
- (tp-at 1))
-;; => (help-echo "test")
-
-;; 从 face 移除子属性
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:foreground "red" :underline t)))
- (tp-remove 1 10 '(face :underline))
- (tp-at 1 'face))
-;; => (:foreground "red")
-
-;; 移除特定嵌套键，保留其他
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:underline (:style wave :position t :color "blue"))))
- (tp-remove 1 10 '(face :underline (:style :position)))
- (tp-at 1 '(face :underline)))
-;; => (:color "blue") ; :style 和 :position 被移除, :color 保留
-
-;; 从整个字符串移除 - 返回新字符串，原始字符串不变
-(let ((original (propertize "Hello" 'face 'bold 'help-echo "tip")))
- (let ((result (tp-remove original 'face)))
- (list :original-face (get-text-property 0 'face original)
- :result-face (get-text-property 0 'face result))))
-;; => (:original-face bold :result-face nil)
-
-;; 从字符串移除子属性 - 返回新字符串
-(let ((original (propertize "Hello" 'face '(:foreground "red" :underline t))))
- (let ((result (tp-remove original 'face :underline)))
- (list :original (get-text-property 0 'face original)
- :result (get-text-property 0 'face result))))
-;; => (:original (:foreground "red" :underline t) :result (:foreground "red"))
-
-;; 从字符串移除嵌套键
-(let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue")))))
- (let ((result (tp-remove original 'face :underline '(:style))))
- (tp-at 0 '(face :underline) result)))
-;; => (:color "blue")
-```
-
----
-
-#### `tp-clear` - 清除所有属性
-
-```elisp
-(tp-clear &optional START END OBJECT)
-```
-
-清除区域中的所有文本属性。返回 nil。
-
-**示例：**
-
-```elisp
-;; 清除区域
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face bold))
- (tp-clear 1 10)
- (tp-at 1))
-;; => nil
-
-;; 清除整个缓冲区
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 12 '(face bold))
- (tp-clear)
- (tp-at 5))
-;; => nil
-```
-
----
-
-### 模式匹配函数
-
-#### `tp-match-set` - 匹配字符串
-
-```elisp
-(tp-match-set PATTERN PLIST &optional OBJECT START END)
-(tp-match-set PATTERN LAYER-NAME &optional OBJECT START END)
-```
-
-在所有字符串模式匹配处设置属性。
-PATTERN 可以是字符串（单个模式）或字符串列表（多个模式）。
-PLIST 是属性列表，如 `'(face bold help-echo "tip")`。
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
-START 和 END（0.3.0 新增）将匹配限制在 OBJECT 的 `[START, END)` 部分，
-使用原生坐标（字符串从 0 开始，缓冲区从 1 开始）。匹配的行为**如同
-OBJECT 只由这一部分组成**，因此匹配不会跨越边界；颠倒的边界会被交换。
-全部六个 `tp-match-*` / `tp-regexp-*` 函数都接受同样的边界参数。
-
-**示例：**
-
-```elisp
-;; 在缓冲区中 - 返回 (START . END) 对的列表
-(with-temp-buffer
- (insert "TODO: fix this. TODO: also this.")
- (tp-match-set "TODO" '(face warning)))
-;; => ((1 . 5) (17 . 21))
-
-;; 在字符串上 - 返回新的带属性字符串（原始字符串不变）
-(tp-match-set "o" '(face bold) "Hello World")
-;; => #("Hello World" 4 5 (face bold) 7 8 (face bold))
-
-;; 多个模式 - 同时匹配 "world" 和 "Hello"
-(with-temp-buffer
- (insert "Hello world, Hello again")
- (tp-match-set '("world" "Hello") '(face bold)))
-;; => ((7 . 12) (1 . 6) (14 . 19)) ; 结果按模式分组：
-;; 先是 "world" 的区域，再是每个 "Hello"，顺序与模式列表一致
-
-;; 在字符串上使用多个模式
-(tp-match-set '("Hello" "world") '(face bold) "Hello world")
-;; => #("Hello world" 0 5 (face bold) 6 11 (face bold))
-
-;; 使用已定义的层名称
-(define-tp todo-style ()
- '(face (:foreground "orange" :weight bold)))
-(with-temp-buffer
- (insert "TODO: fix this. TODO: also this.")
- (tp-match-set "TODO" 'todo-style))
-;; => ((1 . 5) (17 . 21))
-
-;; 用 START/END 边界限制匹配 - 只有第二个 TODO 在范围内
-(with-temp-buffer
- (insert "TODO one TODO two")
- (tp-match-set "TODO" '(face warning) nil 5 18))
-;; => ((10 . 14))
-```
-
----
-
-#### `tp-match-reset` - 匹配并重置
-
-重置（完全替换）匹配处的所有属性。
-PATTERN 可以是字符串或字符串列表（多个模式）。
-PLIST 是属性列表，如 `'(face bold help-echo "tip")`。
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
-
-```elisp
-(tp-match-reset PATTERN PLIST &optional OBJECT START END)
-(tp-match-reset PATTERN LAYER-NAME &optional OBJECT START END)
-```
-
-START 和 END 将匹配限制在 OBJECT 的 `[START, END)` 部分
-（参见 [`tp-match-set`](#tp-match-set---匹配字符串)）。
-
-**示例：**
-
-```elisp
-;; 替换匹配文本上的所有属性
-(with-temp-buffer
- (insert "TODO: fix this")
- (tp-set 1 5 '(help-echo "original")) ; 设置已有属性
- (tp-match-reset "TODO" '(face warning))
- (tp-at 1))
-;; => (face warning) ; help-echo 被移除
-
-;; 多个模式
-(with-temp-buffer
- (insert "TODO: fix. FIXME: also fix.")
- (tp-match-reset '("TODO" "FIXME") '(face warning)))
-;; => ((1 . 5) (12 . 17))
-
-;; 使用已定义的层名称
-(define-tp alert-style ()
- '(face (:background "red" :foreground "white")))
-(with-temp-buffer
- (insert "TODO: fix this")
- (tp-match-reset "TODO" 'alert-style))
-;; => ((1 . 5))
-```
-
----
-
-#### `tp-match-add` - 匹配并添加
-
-在匹配处添加/合并属性，支持深度合并。
-PATTERN 可以是字符串或字符串列表（多个模式）。
-PLIST 是属性列表，如 `'(face bold help-echo "tip")`。
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
-
-```elisp
-(tp-match-add PATTERN PLIST &optional OBJECT START END)
-(tp-match-add PATTERN LAYER-NAME &optional OBJECT START END)
-```
-
-START 和 END 将匹配限制在 OBJECT 的 `[START, END)` 部分
-（参见 [`tp-match-set`](#tp-match-set---匹配字符串)）。
-
-**示例：**
-
-```elisp
-;; 与现有属性合并
-(with-temp-buffer
- (insert "TODO: fix this")
- (tp-set 1 5 '(help-echo "important"))
- (tp-match-add "TODO" '(face (:underline t)))
- (tp-at 1))
-;; => (face (:underline t) help-echo "important")
-
-;; 多个模式
-(with-temp-buffer
- (insert "TODO: fix. FIXME: also fix.")
- (tp-match-add '("TODO" "FIXME") '(face (:underline t))))
-;; => ((1 . 5) (12 . 17))
-
-;; 使用已定义的层名称
-(define-tp underline-style ()
- '(face (:underline (:color "blue" :style wave))))
-(with-temp-buffer
- (insert "TODO: fix this")
- (tp-match-add "TODO" 'underline-style))
-;; => ((1 . 5))
-```
-
----
-
-#### `tp-regexp-set` - 匹配正则表达式
-
-```elisp
-(tp-regexp-set PATTERN PLIST &optional OBJECT START END SUBEXP)
-(tp-regexp-set PATTERN LAYER-NAME &optional OBJECT START END SUBEXP)
-```
-
-在所有正则表达式匹配处设置属性。
-PATTERN 可以是字符串（单个正则）或字符串列表（多个正则）。
-PLIST 是属性列表，如 `'(face bold help-echo "tip")`。
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
-START 和 END（0.3.0 新增）将匹配限制在 OBJECT 的 `[START, END)` 部分，
-使用原生坐标；匹配的行为如同 OBJECT 只由这一部分组成，颠倒的边界会被
-交换（参见 [`tp-match-set`](#tp-match-set---匹配字符串)）。
-SUBEXP（0.3.0 新增）指定 PATTERN 的一个捕获组（1 = 第一个组，与
-font-lock 高亮的约定一致）：属性应用于每个匹配中的该捕获组，而不是整个
-匹配。捕获组未参与的匹配不贡献任何内容；SUBEXP 超出模式的捕获组数量时
-会发出明确的错误信号。全部三个 `tp-regexp-*` 函数都接受 SUBEXP。
-
-**示例：**
-
-```elisp
-;; 高亮缓冲区中的所有数字
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-regexp-set "[0-9]+" '(face font-lock-number-face))
- (list (tp-at 5 'face) (tp-at 13 'face)))
-;; => (font-lock-number-face font-lock-number-face)
-
-;; 在字符串上（默认受 `case-fold-search' 影响，"Hello" 也会匹配；
-;; 需要区分大小写时请将其 let 绑定为 nil）
-(tp-regexp-set "[A-Z]+" '(face bold) "Hello WORLD")
-;; => #("Hello WORLD" 0 5 (face bold) 6 11 (face bold))
-
-;; 多个正则 - 同时匹配数字和大写字母
-;; （忽略大小写时 "abc" 也匹配 "[A-Z]+"）
-(tp-regexp-set '("[0-9]+" "[A-Z]+") '(face bold) "abc 123 XYZ")
-;; => #("abc 123 XYZ" 0 3 (face bold) 4 7 (face bold) 8 11 (face bold))
-
-;; 使用已定义的层名称
-(define-tp number-style ()
- '(face (:foreground "green")))
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-regexp-set "[0-9]+" 'number-style))
-;; => ((5 . 8) (13 . 16))
-
-;; SUBEXP - 只对每个匹配的捕获组 1 设置属性
-(tp-regexp-set "\\([0-9]+\\)px" '(face bold) "margin: 10px 4px" nil nil 1)
-;; => #("margin: 10px 4px" 8 10 (face bold) 13 14 (face bold))
-
-;; 捕获组未参与的匹配不贡献任何内容：
-;; "bar" 匹配该模式，但捕获组 1 只在 "foo" 中参与
-(tp-regexp-set "\\(foo\\)\\|bar" '(face bold) "foo bar" nil nil 1)
-;; => #("foo bar" 0 3 (face bold))
-
-;; SUBEXP 超出模式的捕获组数量时发出明确的错误信号
-(tp-regexp-set "[0-9]+" '(face bold) "abc 123" nil nil 2)
-;; error: Regexp "[0-9]+" has no group 2
-
-;; START/END 边界：如同只有这一部分存在 - 贪婪的 a+
-;; 恰好匹配 [1, 3) 而不是整段字符
-(tp-regexp-set "a+" '(face bold) "aaaa" 1 3)
-;; => #("aaaa" 1 3 (face bold))
-
-;; 颠倒的边界会被交换
-(tp-regexp-set "a+" '(face bold) "aaaa" 3 1)
-;; => #("aaaa" 1 3 (face bold))
-```
-
----
-
-#### `tp-regexp-reset` - 正则匹配并重置
-
-重置（完全替换）正则匹配处的所有属性。
-PATTERN 可以是字符串或字符串列表（多个正则）。
-PLIST 是属性列表，如 `'(face bold help-echo "tip")`。
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
-
-```elisp
-(tp-regexp-reset PATTERN PLIST &optional OBJECT START END SUBEXP)
-(tp-regexp-reset PATTERN LAYER-NAME &optional OBJECT START END SUBEXP)
-```
-
-START/END 边界和 SUBEXP 捕获组的用法与
-[`tp-regexp-set`](#tp-regexp-set---匹配正则表达式) 完全相同。
-
-**示例：**
-
-```elisp
-;; 重置正则匹配处的所有属性
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-set 5 8 '(help-echo "original"))
- (tp-regexp-reset "[0-9]+" '(face bold))
- (tp-at 5))
-;; => (face bold) ; help-echo 被移除
-
-;; 在字符串上 - 返回新字符串，原字符串保持不变
-(let ((str (copy-sequence "abc 123 def")))
- (tp-set 4 7 '(help-echo "original") str)
- (let ((result (tp-regexp-reset "[0-9]+" '(face italic) str)))
- (list (tp-at 4 result) (tp-at 4 str))))
-;; => ((face italic) (help-echo "original"))
-
-;; 使用已定义的层名称
-(define-tp code-number ()
- '(face (:foreground "cyan")))
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-regexp-reset "[0-9]+" 'code-number))
-;; => ((5 . 8) (13 . 16))
-```
-
----
-
-#### `tp-regexp-add` - 正则匹配并添加
-
-在正则匹配处添加/合并属性，支持深度合并。
-PATTERN 可以是字符串或字符串列表（多个正则）。
-PLIST 是属性列表，如 `'(face bold help-echo "tip")`。
-LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。
-OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
-
-```elisp
-(tp-regexp-add PATTERN PLIST &optional OBJECT START END SUBEXP)
-(tp-regexp-add PATTERN LAYER-NAME &optional OBJECT START END SUBEXP)
-```
-
-START/END 边界和 SUBEXP 捕获组的用法与
-[`tp-regexp-set`](#tp-regexp-set---匹配正则表达式) 完全相同。
-
-**示例：**
-
-```elisp
-;; 添加属性到正则匹配处（保留现有）
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-set 5 8 '(help-echo "number"))
- (tp-regexp-add "[0-9]+" '(face bold))
- (tp-at 5))
-;; => (face bold help-echo "number")
-
-;; 在字符串上 - 返回新字符串，原字符串保持不变
-(let ((str (copy-sequence "abc 123 def")))
- (tp-set 4 7 '(help-echo "number") str)
- (let ((result (tp-regexp-add "[0-9]+" '(face italic) str)))
- (list (tp-at 4 result) (tp-at 4 str))))
-;; => ((face italic help-echo "number") (help-echo "number"))
-
-;; 使用已定义的层名称
-(define-tp bold-underline ()
- '(face (:weight bold :underline t)))
-(with-temp-buffer
- (insert "abc 123 def 456")
- (tp-regexp-add "[0-9]+" 'bold-underline))
-;; => ((5 . 8) (13 . 16))
-```
-
----
-
-### 搜索和导航函数
-
-#### `tp-search-forward` / `tp-search-backward`
-
-> ⚠️ **自 0.3.0 起已废弃。**这两个函数是 Emacs 的
-> `text-property-search-forward` / `text-property-search-backward` 的原
-> 始包装，其 nil-PREDICATE 默认行为（匹配非 nil 且与 VALUE **不**
-> `equal` 的值）与本库其余部分使用的 `equal` 匹配相矛盾。请使用
-> [`tp-forward` / `tp-backward`](#tp-forward--tp-backward) 获得 tp 对称
-> 的 `equal` 匹配搜索 —— 它们现在也暴露了 PREDICATE 和 NOT-CURRENT ——
-> 或者直接调用 Emacs 原语进行底层访问。这两个包装仍然可用，但已被标记
-> 为过时（字节编译器会对新的调用发出警告）。
-
-```elisp
-(tp-search-forward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) ; deprecated
-(tp-search-backward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) ; deprecated
-```
-
----
-
-#### `tp-forward` / `tp-backward`
-
-```elisp
-(tp-forward PROPERTY &optional VALUE OBJECT N PREDICATE NOT-CURRENT)
-(tp-backward PROPERTY &optional VALUE OBJECT N PREDICATE NOT-CURRENT)
-```
-
-向前/向后搜索 N 次具有 PROPERTY 的文本。
-
-- **N** 是搜索次数，默认为 1。
-- **VALUE** 与直接存在的属性值做 `equal` 匹配。省略 VALUE 匹配任意已
- 存在值；显式 nil 只匹配“键存在且值为 nil”。缺少该属性的区段不匹配。
-- 需要继续传入 OBJECT、N 等后续位置参数并保持通配时，传入公共唯一哨兵
- **`tp-any-value`**。
-- **`tp-backward` 与 `tp-forward` 对称**：相同的 equal 匹配语义，
- 方向相反。
-- **OBJECT** 可以是缓冲区或字符串；nil 默认为当前缓冲区。
-- **PREDICATE**（0.3.0 新增）自定义匹配方式：nil（默认值）和 t 都
- **完全**保持 0.2.0 的 `equal` 匹配契约；传入函数时以 `(VALUE PROP-VALUE)`
- 调用，返回非 nil 即视为匹配。
-- **NOT-CURRENT**（0.3.0 新增）非 nil 时跳过包含 point 的匹配区段，与
- `text-property-search-*` 原语的行为一致。仅缓冲区路径有效；字符串没
- 有 point，因此在字符串上会被忽略。
-- 对于缓冲区，返回最后一次成功搜索的 prop-match 对象。
-- 对于字符串，返回**前 N 个** PROPERTY 匹配区段的 (START END VALUE)
- 列表，从位置 0 开始计数（与 point 无关）。`tp-backward` 按从末尾到
- 开头的顺序返回。
-
-**示例：**
-
-```elisp
-;; 查找下一个 'marker 等于 t 的文本
-(with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char 1)
- (let ((match (tp-forward 'marker t)))
- (when match
- (prop-match-beginning match))))
-;; => 7
-
-;; 省略 VALUE 时匹配下一个直接存在的 marker 值
-(with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char 1)
- (let ((match (tp-forward 'marker)))
- (list (prop-match-beginning match) (prop-match-end match))))
-;; => (7 12)
-
-;; 显式 nil 只匹配“属性存在且值为 nil”
-(let ((str (copy-sequence "abc")))
- (tp-set 1 2 '(marker nil) str)
- (tp-forward 'marker nil str))
-;; => ((1 2 nil))
-
-;; backward 与 forward 对称：相同的值匹配，方向相反
-(with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char (point-max))
- (let ((match (tp-backward 'marker t)))
- (list (prop-match-beginning match) (prop-match-end match))))
-;; => (7 12)
-
-;; 查找下一个 'type 等于 'heading 的文本
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(type heading))
- (goto-char 1)
- (let ((match (tp-forward 'type 'heading)))
- (when match
- (prop-match-value match))))
-;; => heading
-
-;; 在字符串中搜索
-(let ((my-string (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward 'marker tp-any-value my-string 2))
-;; => ((0 5 t) (12 17 t))
-
-;; PREDICATE - 用自定义函数代替 `equal' 进行匹配
-;; （调用参数为 VALUE 和该区段的属性值）
-(with-temp-buffer
+(with-current-buffer (get-buffer-create "*tp-demo*")
+ (erase-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))))
-;; => (3 6) ; 第一个 size 超过 15 的区段
-
-;; PREDICATE 也适用于字符串（返回前 N 个匹配区段）
-(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)))))
-;; => ((6 11 20))
-
-;; NOT-CURRENT - 跳过包含 point 的匹配区段
-(with-temp-buffer
- (insert "one two")
- (tp-set 1 4 '(mark t))
- (tp-set 5 8 '(mark t))
- (let (a b)
- (goto-char 2) ; 位于第一个 mark 区段内
- (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)))
-;; => (2 5) ; 不带 NOT-CURRENT 时当前区段在 point 处即匹配
-```
-
----
-
-#### `tp-forward-do` / `tp-backward-do`
-
-```elisp
-(tp-forward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END PREDICATE NOT-CURRENT)
-(tp-backward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END PREDICATE NOT-CURRENT)
-```
-
-向前/向后搜索 TIMES 次具有 PROPERTY 的文本，**仅在第 TIMES 个匹配处应用 FUNCTION**。
-
-尽管带有 `-do` 后缀，它并**不是** for-each —— 要对*每个*匹配应用函数，
-请使用 [`tp-search-map`](#tp-search-map---对匹配文本应用函数)。
-
-- **FUNCTION** 的参数是 `(TEXT &optional START END IDX)`，其中 TEXT 是此次匹配到的文本，START 和 END 为开始结束的位置，IDX 是从 0 开始的匹配索引。FUNCTION 会按其实际接受的参数个数被调用。当 FUNCTION 返回字符串时，它将替换字符串或缓冲区中的匹配文本。
-- **在缓冲区中替换文本可以改变长度**（先删除匹配文本，再插入替换文本）。**字符串无法就地改变长度**：长度不同的替换会发出错误信号；长度相同的替换会就地应用。
-- **PROPERTY** 是要搜索的文本属性。
-- **VALUE** 遵循 presence-aware 搜索契约：省略表示任意已存在值；显式
- nil 表示“键存在且值为 nil”。需要继续传入后续位置参数时使用
- `tp-any-value`。
-- **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。
-- **TIMES** 表示向前/向后搜索几次，默认搜索一次。该函数会搜索 TIMES 次，但仅对第 TIMES 个匹配应用 FUNCTION。要么全有要么全无：当匹配数量不足 TIMES 时，完全不应用 FUNCTION，仅返回实际找到的匹配数量。
-- **START** 和 **END** 默认为 OBJECT 的起始和结束位置。
-- **PREDICATE** 和 **NOT-CURRENT**（0.3.0 新增）的用法与
- [`tp-forward` / `tp-backward`](#tp-forward--tp-backward) 相同，并被应
- 用到每一次底层搜索；默认值完全保持 0.2.0 的行为。
-- 返回成功匹配的数量。
-
-**示例：**
-
-```elisp
-;; 仅将最后一次（第 2 次）匹配的文本转为大写
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward-do #'upcase 'marker tp-any-value my-string 2)
- my-string)
-;; => "hello world HELLO" ; 仅第 2 次匹配被转为大写
-
-;; 在指定范围内搜索（仅搜索范围 6-17 内的匹配）
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward-do #'upcase 'marker tp-any-value my-string 2 6 17)
- my-string)
-;; => "hello world hello" ; 范围 6-17 内仅有 1 个匹配，请求的
-;; 第 2 个匹配不存在：不做任何应用（要么全有要么全无；
-;; 调用仍返回实际匹配数 1）
-
-;; 使用带有 start 和 end 参数的函数
-;; 函数接收位置信息；使用 upcase 保持相同长度
-(let ((my-string (copy-sequence "hello world hello"))
- (match-info nil))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward-do
- (lambda (text start end)
- (setq match-info (list start end))
- (upcase text))
- 'marker tp-any-value my-string 2)
- (list my-string match-info))
-;; => ("hello world HELLO" (12 17)) ; 仅最后一次匹配被转换
-
-;; 向后搜索 - 仅将最后一次（第 2 次）匹配的文本转为大写
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-backward-do #'upcase 'marker tp-any-value my-string 2)
- my-string)
-;; => "HELLO world hello" ; 向后搜索时第一个匹配（即最后找到的）被转为大写
-```
-
----
-
-#### `tp-search` - 搜索所有匹配
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-search START END PROPERTY &optional VALUE OBJECT)
-
-;; 整个字符串
-(tp-search STRING PROPERTY &optional VALUE)
-```
-
-在缓冲区/字符串范围或整个字符串中搜索所有具有 PROPERTY 的文本。
-
-返回所有匹配区域的 (START END VALUE) 列表。
-
-**示例：**
-
-```elisp
-;; 在缓冲区范围内查找所有 'marker 属性
-(with-temp-buffer
- (insert "Hello World Test Again")
- (tp-set 1 6 '(marker t))
- (tp-set 13 17 '(marker t))
- (tp-search 1 22 'marker))
-;; => ((1 6 t) (13 17 t))
-
-;; 在字符串中查找所有值为 'heading 的 'type 属性
-(let ((my-string (copy-sequence "Title Here Body Text")))
- (tp-set 0 10 '(type heading) my-string)
- (tp-search my-string 'type 'heading))
-;; => ((0 10 heading))
-
-;; 按值过滤
-(with-temp-buffer
- (insert "Heading1 Body Heading2")
- (tp-set 1 9 '(type heading))
- (tp-set 10 14 '(type body))
- (tp-set 15 23 '(type heading))
- (tp-search 1 23 'type 'heading))
-;; => ((1 9 heading) (15 23 heading))
-```
-
----
-
-#### `tp-search-map` - 对匹配文本应用函数
-
-```elisp
-(tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END)
-```
-
-在 OBJECT 的 START 到 END 范围内，匹配到 PROPERTY 属性（值是 VALUE）的部分执行 FUNCTION 函数。
-
-- **FUNCTION** 的参数是 `(TEXT &optional START END IDX)`，其中：
- - TEXT 是此次匹配到的文本
- - START 和 END 为开始结束的位置
- - IDX 是遍历中的当前从 0 开始的索引
- FUNCTION 会按其实际接受的参数个数被调用。当 FUNCTION 返回字符串时，
- 它将替换字符串或缓冲区中的匹配文本。
-- **在缓冲区中替换文本可以改变长度**（先删除匹配文本，再插入替换文本）。
- **字符串无法就地改变长度**：长度不同的替换会发出错误信号；
- 长度相同的替换会就地应用。
-- **PROPERTY** 是要搜索的文本属性。
-- **VALUE** 遵循 presence-aware 搜索契约：省略表示任意已存在值；显式
- nil 表示“键存在且值为 nil”。需要继续传入后续位置参数时使用
- `tp-any-value`。
-- **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。
-- **START** 和 **END** 默认为 OBJECT 的起始和结束位置。
-- 返回处理的匹配数量。
-
-**示例：**
-
-```elisp
-;; 将字符串中所有 marker 文本转为大写
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-search-map #'upcase 'marker tp-any-value my-string)
- my-string)
-;; => "HELLO world HELLO"
-
-;; 仅在指定范围内搜索
-(let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-search-map #'upcase 'marker tp-any-value my-string 0 10)
- my-string)
-;; => "HELLO world hello" ; 仅范围 0-10 内的第一个匹配被处理
-
-;; 使用 start、end 和 idx 参数的自定义转换
-;; 函数接收位置信息；使用 upcase 保持相同长度
-(let ((my-string (copy-sequence "aaa bbb ccc"))
- (positions nil))
- (tp-set 0 3 '(marker t) my-string)
- (tp-set 4 7 '(marker t) my-string)
- (tp-set 8 11 '(marker t) my-string)
- (tp-search-map
- (lambda (text start end idx)
- (push (list idx start end) positions)
- (upcase text))
- 'marker tp-any-value my-string)
- (list my-string (nreverse positions)))
-;; => ("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11)))
-
-;; 不使用可选参数的自定义转换
-(let ((my-string (copy-sequence "hello world")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-search-map #'upcase 'marker tp-any-value my-string)
- my-string)
-;; => "HELLO world"
-```
-
----
-
-## 原生文本属性兼容
-
-Stage 3 明确了文本属性边界，Stage 5 增加 overlay-aware 字符属性查询。这组 API 映射 GNU Emacs 原语；tp 不管理 overlay 生命周期。
-
-#### `tp-lookup-result` / `tp-lookup`
-
-`tp-lookup` 返回 `tp-lookup-result` 记录。使用自动生成的访问器读取字段：
-
-| 访问器 | 含义 |
-|--------|------|
-| `tp-lookup-result-property` | 请求的属性 |
-| `tp-lookup-result-value` | 解析出的值 |
-| `tp-lookup-result-present-p` | 选定来源提供该属性时为非 nil；direct 显式 nil 计为存在，alias nil 则遵循 Emacs 的 alias fallback |
-| `tp-lookup-result-source` | `:text-direct`、`:category`、`:alias`、`:default` 或 `:absent` |
-| `tp-lookup-result-mode` | 查询模式 |
-| `tp-lookup-result-object` | 被查询对象 |
-| `tp-lookup-result-position` | 被查询位置 |
-| `tp-lookup-result-overlay` | `:char` / `:char-source` 中的获胜 overlay；其他模式为 nil |
-
-模式：
-
-| 模式 | 行为 |
-|------|------|
-| `:text-direct` | 只检查 `text-properties-at` 的直接文本属性；显式 nil 算存在 |
-| `:text-effective` | 返回 `get-text-property` 的有效文本值，并报告其文本来源 |
-| `:text-source` | 报告不含 overlay 的获胜文本来源 |
-| `:char` | overlay-aware 的 `get-char-property-and-overlay` 值；文本 fallback 遵循 Emacs |
-| `:char-source` | 类似 `:char`，当 overlay 获胜时额外记录 `:overlay` 来源和 overlay 对象 |
-
-```elisp
-;; direct 查询区分显式 nil 与缺失
-(let ((str (copy-sequence "ab")))
- (put-text-property 0 1 'state nil str)
- (let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct))
- (absent-result (tp-lookup 1 'state :object str :mode :text-direct)))
- (list (list (tp-lookup-result-present-p nil-result)
- (tp-lookup-result-value nil-result)
- (tp-lookup-result-source nil-result))
- (list (tp-lookup-result-present-p absent-result)
- (tp-lookup-result-value absent-result)
- (tp-lookup-result-source absent-result)))))
-;; => ((t nil :text-direct) (nil nil :absent))
-
-;; source-aware 查询解释 category/default/alias/direct 文本来源
-(let* ((str (copy-sequence "a"))
- (category (make-symbol "tp-doc-category")))
- (put category 'state 'category-value)
- (put-text-property 0 1 'category category str)
- (let ((result (tp-lookup 0 'state :object str :mode :text-source)))
- (list (tp-lookup-result-value result)
- (tp-lookup-result-source result))))
-;; => (category-value :category)
-
-;; char-source 查询报告获胜 overlay 身份
-(with-temp-buffer
- (insert "x")
- (let ((low (make-overlay 1 2))
- (high (make-overlay 1 2)))
- (overlay-put low 'priority 1)
- (overlay-put low 'state 'low)
- (overlay-put high 'priority 10)
- (overlay-put high 'state 'high)
- (let ((result (tp-lookup 1 'state :mode :char-source)))
- (list (tp-lookup-result-value result)
- (tp-lookup-result-source result)
- (eq (tp-lookup-result-overlay result) high)))))
-;; => (high :overlay t)
-```
-
-`tp-lookup` 会报告 overlay 获胜者，但 overlay 创建、删除、移动、priority 管理和生命周期仍由 Emacs 原生机制负责。
-
-#### `tp-property-change`
-
-`tp-property-change` 封装 `next-property-change`、`previous-property-change`、`next-single-property-change` 和 `previous-single-property-change`。
-
-```elisp
-(tp-property-change POSITION :object OBJECT :limit LIMIT :direction :next)
-(tp-property-change POSITION :property PROPERTY :object OBJECT :limit LIMIT :direction :previous)
-```
-
-省略 `:property` 表示任意属性变化；传入 `:property` 表示单属性变化。`:direction` 为 `:next` 或 `:previous`。
-
-#### `tp-property-any` / `tp-property-not-all`
-
-这两个函数是 Emacs 原语的薄封装：
-
-```elisp
-(tp-property-any START END PROPERTY VALUE &optional OBJECT)
-(tp-property-not-all START END PROPERTY VALUE &optional OBJECT)
-```
-
-它们完整保留 Emacs 行为，包括显式 nil 匹配。
-
-#### `tp-with-mutation-policy`
-
-`tp-with-mutation-policy` 显式声明 buffer 修改的 modified/read-only 行为：
-
-| 策略 | 行为 |
-|------|------|
-| `(:modified :ordinary :read-only :respect)` | 普通 Emacs 修改；read-only 文本可报错 |
-| `(:modified :ordinary :read-only :inhibit)` | 绑定 `inhibit-read-only`，并记录普通 modified/undo 状态 |
-| `(:modified :silent :read-only :inhibit)` | 绑定 `inhibit-read-only`，并使用 `with-silent-modifications` |
-
-`(:modified :silent :read-only :respect)` 会被拒绝，因为 silent modification 不能与尊重 read-only 文本同时成立。
-
-insert/copy/yank/stickiness/narrowing/indirect-buffer 行为直接委托 Emacs。tp 不提供这些操作的 wrapper；请使用原生原语（`insert`、`insert-and-inherit`、`copy-sequence`、`substring`、`insert-for-yank`、narrowing 命令和 indirect buffer）。
-
----
-
-## 属性层系统
-
-属性层系统是 tp.el 的创新功能，允许在同一文本区域堆叠多组属性。只有顶层属性可见，但下层属性会被保留，并可通过轮转或固定操作使其显现。
-
-### 自定义文本属性
-
-自定义文本属性是 tp.el 提供的一个**通用功能**。使用 `define-tp` 定义后，可以通过 `tp-set`/`tp-reset`/`tp-add` 等核心函数设置。
-
-#### 核心特性
-
-1. **与内置属性混合使用**：自定义文本属性可以和 Emacs 内置的文本属性（如 `face`、`display`、`help-echo` 等）无缝混合使用。
-
-2. **重复属性自动合并**：在一次设置操作中，如果同一个属性（如 `face`）被指定多次，它们会自动合并，而非简单覆盖。
-
-```elisp
-;; 定义自定义文本属性
-(define-tp tp-highlight ()
- '(face (:background "yellow")))
-
-;; 与内置属性混合使用
-(tp-set 1 10 '(tp-highlight t face bold help-echo "提示"))
-;; 结果: 同时具有 tp-highlight 的背景色、bold 样式和 help-echo 属性
-
-;; 重复属性自动合并示例
-(tp-set "emacs"
- 'face 'bold
- 'face '(:background "green")
- 'face '(:foreground "red"))
-;; 结果: face 是 ((:foreground "red") (:background "green") bold)
-;; 三个 face 属性堆叠为一个 face 列表，最新的在前
-
-;; 同一子属性后面的覆盖前面的
-(tp-set "emacs"
- 'face '(:foreground "red")
- 'face '(:foreground "yellow"))
-;; 结果: foreground 是 "yellow"
-
-;; 与 tp-palette 层配合使用
-(tp-set "emacs"
- 'tp-palette 'info
- 'face '(:foreground "red"))
-;; 结果: tp-palette 的 face 与 (:foreground "red") 合并
-```
-
-#### 自定义文本属性组
-
-使用 `define-tps` 可以定义多个相关的文本属性组，它们可以单独使用，也可以作为一组使用。
-
----
-
-### 文本属性层
-
-文本属性层是 tp.el 的**独特功能**，需要使用特定的函数（`tp-put-layer`/`tp-push-layer`）才能设置和使用。
-
-#### 核心特性
-
-1. **引入层相关属性**：当使用 `tp-push-layer`/`tp-put-layer` 设置时，会自动引入 `tp-name`、`tp-layers` 等层相关属性，用于支持层的堆叠和操作。
-
-2. **层堆叠机制**：可以在同一文本区域堆叠多组属性，只有顶层可见，下层被保留。
-
-3. **丰富的层操作**：支持轮换、删除、合并等多种层操作。
-
-```elisp
-;; 定义文本属性（可同时用作自定义属性或层）
-(define-tp tp-highlight ()
- '(face (:background "yellow")))
-
-;; 作为普通自定义文本属性使用（不引入层属性）
-(tp-set 1 10 '(tp-highlight t))
-;; 结果: 只有 face 属性，没有 tp-name
-
-;; 作为文本属性层使用（引入层相关属性）
-(tp-push-layer 1 10 'tp-highlight)
-;; 结果: 同时有 face 和 tp-name 属性，支持层操作
-```
-
-#### 何时使用哪种方式
-
-| 场景 | 推荐方式 | 说明 |
-|------|----------|------|
-| 简单属性设置 | `tp-set`/`tp-reset`/`tp-add` | 当你只需要设置文本属性，不需要层堆叠功能时 |
-| 与内置属性混合 | `tp-set`/`tp-reset`/`tp-add` | 自定义属性可以和内置属性无缝混合 |
-| 需要层堆叠 | `tp-push-layer`/`tp-put-layer` | 当你需要在同一文本区域堆叠多组属性时 |
-| 需要层操作 | `tp-push-layer`/`tp-put-layer` | 当你需要进行轮换、删除等层操作时 |
-
-### 属性层概念
-
-```
-┌─────────────────────────────┐
-│ 顶层（可见） │ ← idx=0，你看到的
-├─────────────────────────────┤
-│ 中间层（隐藏） │ ← idx=1，被保留
-├─────────────────────────────┤
-│ 底层（隐藏） │ ← idx=-1，被保留
-└─────────────────────────────┘
-```
-
-### 属性层定义
-
-#### `define-tp` / `define-tps` - 定义自定义文本属性
-
-> 自 0.3.0 起，符合前缀规范的别名 `tp-define-layer`（对应
-> `define-tp`）、`tp-define-group`（对应 `define-tps`）和
-> `tp-define-palette`（对应 `define-tp-palette`）是今后的规范名称 ——
-> 它们让这些宏可以通过 `C-h f tp-...` 被发现。历史名称是永久别名，永远
-> 不会被移除；本 README 的示例仍继续使用它们。
-
-##### `define-tp` - 定义单个自定义文本属性（层）
-
-定义自定义文本属性，名称无需单引号引用。**所有格式中参数列表都是必需的**：无参数层（包括响应式关键字格式）用 `()`，参数化层用 `(ARG1 ARG2 ...)`，可包含任意数量的参数符号。支持三种格式：
-
-**格式一 - 无参数（空参数列表，简单属性）：**
-
-```elisp
-(define-tp tp-bold ()
- '(face bold))
-
-;; 用法:
-(tp-set "emacs" 'tp-bold t)
-(tp-set 0 5 '(tp-bold t) "emacs")
-```
-
-**格式二 - 有参数（带一个或多个参数）：**
-
-```elisp
-(define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
-
-;; 用法:
-(tp-set "emacs" 'tp-space 2)
-(tp-set 0 5 '(tp-space 2) "emacs")
-```
-
-自 0.3.0 起，参数列表可以声明**任意数量的参数**。调用规格既接受平铺的
-参数 —— `(LAYER ARG1 ... ARGN)` —— 也接受包在一个列表中的参数 ——
-`(LAYER (ARG1 ... ARGN))` —— 两种写法在 `tp-set` 和 `tp-put-layer` 中
-都有效：
-
-```elisp
-(define-tp tp-colors (fg bg)
- `(face (:foreground ,fg :background ,bg)))
-
-;; 整字符串形式：参数跟在层名后面
-(tp-set "hello" 'tp-colors "red" "blue")
-;; => #("hello" 0 5 (face (:foreground "red" :background "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)))
-;; => ((:foreground "red" :background "blue") "tip")
-
-;; tp-put-layer 规格
-(with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(tp-colors "white" "black") 0)
- (tp-at 1 'face))
-;; => (:foreground "white" :background "black")
-
-;; 参数个数不符的调用会发出明确的错误信号，指出层名和两个数量
-(tp-set "hello" 'tp-colors "red")
-;; error: tp layer tp-colors takes 2 argument(s), got 1
-```
-
-参数化层组（`define-tps`）以同样的方式接受多个参数；
-`(GROUP ARG1 ... ARGN)` 和 `(GROUP (ARG1 ... ARGN))` 规格在 `tp-set`
-家族中都有效。注意：参数化 body 中的 `$` 符号在展开时解析为其变量的当
-前值 —— 参数化层**不是**响应式的。
-
-**格式三 - 响应式特性（支持 :props、:data、:compute、:watch、:transform）：**
-
-```elisp
-(define-tp my-reactive-layer ()
- :props '(face (:foreground $my-color) help-echo $status-note)
- :data '((my-color . "red") (status . "active"))
- :compute '((status-note (lambda () (concat "status: " status))))
- :watch '((my-color (lambda (new old layer) (message "Color changed!"))))
- :transform (lambda (text) (upcase text)))
-
-;; 用法:
-(tp-push-layer 1 10 'my-reactive-layer)
-;; 改变变量会自动更新文本
-(setq my-color "blue")
-```
-
-**响应式关键字说明：**
-
-- **:props** - 属性列表，`$` 前缀的符号是响应式变量
-- **:data** - 额外的响应式变量列表（可以包含初始值）
-- **:compute** - 计算属性列表，从其他变量派生值
-- **:watch** - 监听器列表，变量改变时执行回调
-- **:transform** - 转换函数，在显示 `tp-text` 值之前对其进行处理
-
-注意：`:props`、`:data`、`:compute` 和 `:watch` 的值必须**加引号**
-（它们在层定义时会被求值）；`:transform` 接受一个函数。
-
-##### `define-tps` - 定义自定义文本属性组（层组）
-
-定义多个相关的自定义文本属性，名称无需单引号引用。与 `define-tp` 一样，**参数列表是必需的**：无参数层组用 `()`，参数化层组用 `(ARG1 ARG2 ...)`（自 0.3.0 起支持任意数量的参数）。属性组中定义的文本属性可以单独使用，也可以使用组名称来设置多层。
-
-**格式一 - 无参数（空参数列表）：**
-
-```elisp
-(define-tps tp-moon-phases ()
- '(display "🌑")
- '(display "🌕"))
-
-;; 用法:
-(tp-set 1 6 'tp-moon-phases)
-```
-
-**格式二 - 有参数（带单个参数）：**
-
-```elisp
-;; 先定义参数化的单独层
-(define-tp tp-color1 (color)
- `(face (:foreground ,color)))
-(define-tp tp-color2 (color)
- `(face (:foreground ,color)))
-(define-tp tp-bg ()
- '(face (:background "green")))
-
-;; 定义参数化的层组，引用上面定义的层
-(define-tps tp-themed-status (color)
- `(tp-color1 ,color) ;; 使用层组参数
- '(tp-color2 "red") ;; 使用固定参数
- 'tp-bg) ;; 引用无参数层
-
-;; 用法 - 设置多层属性:
-(tp-set "emacs" 'tp-themed-status "orange")
-;; 结果: 三个层堆叠，tp-color1 为顶层，使用 "orange" 颜色
-```
-
-**支持的层定义格式：**
-
-每个元素可以是以下格式之一：
-
-1. **匿名层**（命名为 NAME-0, NAME-1 等）:
- ```elisp
- '(face (:background "yellow"))
- ```
-
-2. **使用 cons-cell 命名层**（命名为 NAME-suffix）:
- ```elisp
- '("highlight" . (face (:background "yellow")))
- ```
-
-3. **使用 :props 关键字命名层**:
- ```elisp
- '("highlight" :props (face (:background "yellow")))
- ```
-
-4. **带响应式特性的命名层**（:props、:data、:watch、:compute）:
- ```elisp
- '("reactive" :props (face (:foreground $my-color))
- :data ((my-color . "red"))
- :watch ((my-color (lambda (new old layer) (message "Changed!")))))
- ```
-
-**示例：**
-
-```elisp
-;; 定义无参数的自定义文本属性
-(define-tp tp-highlight ()
- '(face (:background "yellow")))
-
-;; 定义有参数的自定义文本属性
-(define-tp tp-color (color)
- `(face (:foreground ,color)))
-
-;; 定义属性组
-(define-tps tp-status ()
- '("success" . (face (:foreground "green")))
- '("warning" . (face (:foreground "orange")))
- '("error" . (face (:foreground "red"))))
-
-;; 使用自定义文本属性
-(tp-set "Hello" 'tp-highlight t) ; 无参数
-(tp-set "Hello" 'tp-color "blue") ; 有参数
-(tp-set 1 6 'tp-status) ; 使用层组
-
-;; 作为层使用（支持堆叠操作）
-(tp-push-layer 1 10 'tp-highlight)
-```
-
----
-定义中的第一个属性层是顶层（默认可见）。
-
-**示例：**
-
-```elisp
-;; 先定义状态层，然后将它们组合成层组
-(progn
- (tp-layer-reset)
- (define-tp highlight ()
- '(face (:background "yellow" :foreground "black")))
- (define-tp error ()
- '(face (:background "red" :foreground "white")))
- (define-tp info ()
- '(face (:background "blue" :foreground "white")))
- (define-tps status-colors ()
- 'highlight 'error 'info)
- (length (tp-group-props 'status-colors)))
-;; => 3
-
-;; 使用命名层定义层组
-(progn
- (tp-layer-reset)
- (define-tps moon-phases ()
- '("new" . (display "🌑"))
- '("waxing-crescent" . (display "🌒"))
- '("first-quarter" . (display "🌓"))
- '("full" . (display "🌕")))
- (tp-layer-props 'moon-phases-full))
-;; => (display "🌕")
-
-;; 参数化层组，引用其他已定义的层
-(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"))
-;; => #("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))))
-;; （顶层属性的打印顺序在不同 Emacs 版本间可能不同，
-;; tp-layers 栈内顺序本身是稳定的）
-```
-
----
-
-#### `tp-layer-props` / `tp-group-props`
-
-```elisp
-(tp-layer-props LAYER-NAME &optional INCLUDE-TP-NAME)
-(tp-group-props GROUP-NAME &optional INCLUDE-TP-NAME)
-```
-
-获取属性层或属性层组中所有属性层的属性。
-
-默认情况下，结果只包含属性层自身的属性。当 INCLUDE-TP-NAME 非 nil 时，
-会在结果末尾追加一个 `tp-name LAYER-NAME` 条目（属性层栈内部使用的形式）。
-例外：注册了响应式依赖的属性层总是包含 `tp-name` —— 响应式引擎依靠
-它定位并重新渲染这些区域。
-
-**示例：**
-
-```elisp
-;; 获取属性层属性（默认不含 tp-name）
-(progn
- (tp-layer-reset)
- (define-tp my-layer ()
- '(face bold help-echo "tip"))
- (list (tp-layer-props 'my-layer)
- (tp-layer-props 'my-layer t)))
-;; => ((face bold help-echo "tip")
-;; (face bold help-echo "tip" tp-name my-layer))
-
-;; 获取属性层组属性
-(progn
- (tp-layer-reset)
- (define-tp layer1 ()
- '(face bold))
- (define-tp layer2 ()
- '(face italic))
- (define-tps my-group ()
- 'layer1 'layer2)
- (length (tp-group-props 'my-group)))
-;; => 2
-```
-
----
-
-#### `tp-layer-props-with-args` / `tp-group-props-with-args` / `tp-layer-arglist`
-
-```elisp
-(tp-layer-props-with-args LAYER-NAME ARGS &optional INCLUDE-TP-NAME)
-(tp-group-props-with-args GROUP-NAME ARGS &optional INCLUDE-TP-NAME)
-(tp-layer-arglist LAYER-NAME)
-```
-
-针对**参数化**属性层和属性层组的自省函数（0.3.0 新增）：
-
-- **`tp-layer-props-with-args`** 用 ARGS 展开参数化属性层，ARGS 是按位
- 置绑定到层参数的值列表。多余的值会被忽略；值的数量少于参数数量时会发
- 出参数个数不符的错误信号。返回一个全新的副本（修改它不会破坏注册
- 表）；对无参数或未定义的层返回 nil。原有的单参数
- `tp-layer-props-with-arg`（注意名称只差一个字符）保留为一个薄薄的
- `(list ARG)` 包装。
-- **`tp-group-props-with-args`** 是层组版本，返回展开后的逐层 plist 列
- 表；`tp-group-props-with-arg` 保留为单参数便捷形式。
-- **`tp-layer-arglist`** 返回层参数列表的副本；当 LAYER-NAME 不是参数
- 化层时返回 nil。
-
-**示例：**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp tp-colors (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (tp-layer-props-with-args 'tp-colors '("red" "blue")))
-;; => (face (:foreground "red" :background "blue"))
-
-;; 参数列表本身
-(tp-layer-arglist 'tp-colors)
-;; => (fg bg)
-
-;; 层组展开为每层一个 plist
-(progn
- (define-tps tp-badge (fg bg)
- `(tp-colors ,fg ,bg)
- '(face bold))
- (tp-group-props-with-args 'tp-badge '("white" "black")))
-;; => ((face (:foreground "white" :background "black")) (face bold))
-
-;; 参数太少时发出与 tp-set 相同的明确错误信号
-(tp-layer-props-with-args 'tp-colors '("red"))
-;; error: tp layer tp-colors takes 2 argument(s), got 1
-```
-
----
-
-#### `tp-describe-layer` - 描述属性层
-
-```elisp
-(tp-describe-layer NAME) ; interactive
-```
-
-弹出一个帮助缓冲区，描述属性层 NAME（交互式调用时可在所有已注册层中补
-全）。该缓冲区会展示存储格式（flat / unified / parameterized /
-reactive）、原始存储的 body、展开后的属性（参数化层需要参数，因此显示
-占位说明）、参数列表、该层依赖的响应式变量、是否注册了 transform，以及
-生成该层的层组（如果有）。
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp tp-colors (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (tp-describe-layer 'tp-colors))
-;; 弹出一个 *Help* 缓冲区:
-;; tp-colors is a tp layer.
-;;
-;; Storage format: parameterized
-;; Arguments: (fg bg)
-;; Stored body: `(face (:foreground ,fg :background ,bg))
-;; Expanded props: parameterized layer: expand with `tp-layer-props-with-args'
-;; Reactive deps: none
-;; Transform: no
-```
-
----
-
-#### `tp-undefine-layer` / `tp-undefine-group`
-
-```elisp
-(tp-undefine-layer NAME)
-(tp-undefine-group NAME)
-```
-
-移除属性层或属性层组定义。
-
-**示例：**
-
-```elisp
-;; 取消定义属性层
-(progn
- (tp-layer-reset)
- (define-tp temp-layer ()
- '(face bold))
- (tp-undefine-layer 'temp-layer)
- (tp-layer-props 'temp-layer))
-;; => nil
-
-;; 取消定义属性层组
-(progn
- (tp-layer-reset)
- (define-tp l1 () '(face bold))
- (define-tps my-group ()
- 'l1)
- (tp-undefine-group 'my-group)
- (assoc 'my-group tp-layer-groups))
-;; => nil
-```
-
----
-
-#### `tp-layer-reset`
-
-```elisp
-(tp-layer-reset)
-```
-
-清除所有属性层和属性层组定义，包括所有响应式依赖和监听器。
-
-**示例：**
-
-```elisp
-(progn
- (define-tp test-layer () '(face bold))
- (tp-layer-reset)
- (list tp-layer-alist tp-layer-groups))
-;; => (nil nil)
-```
-
----
-
-#### `tp-reactive-reset`
-
-```elisp
-(tp-reactive-reset)
-```
-
-清除所有响应式文本属性的监听器和依赖关系，但不影响层定义。
-
-当你想要移除所有响应式绑定但保留层定义时，这个函数很有用。
-
-**示例：**
-
-```elisp
-;; 定义一个响应式层
-(progn
- (defvar my-reactive-color "red")
- (define-tp reactive-layer ()
- :props '(face (:foreground $my-reactive-color)))
- ;; 仅清除响应式绑定
- (tp-reactive-reset)
- ;; 层仍然存在，但改变 my-reactive-color 不再更新它
- (tp-layer-props 'reactive-layer))
-;; => (face (:foreground "red"))
-```
-
----
-
-### 属性层放置
-
-> ⚠️ **栈操作的字符串形式会就地修改字符串。**与返回**新**属性字符串的
-> `tp-set` 不同，每一个栈修改函数（`tp-put-layer`、`tp-push-layer`、
-> `tp-pop-layer`、`tp-delete-layer`、`tp-move-layer`、`tp-raise-layer`、
-> `tp-lower-layer`、`tp-rotate-layer`、`tp-pin-layer`、
-> `tp-switch-layer`、`tp-hide-layer`、`tp-show-layer`、
-> `tp-merge-layers`、`tp-flatten-layers`、`tp-add-to-layers`、
-> `tp-add-to-all-layers`）的字符串形式都会**破坏性地**修改 STRING。绝
-> 不要传入字符串字面量或不属于你的共享字符串 —— 请先用
-> `copy-sequence`。将这一行为与 `tp-set` 的复制语义统一已列入 0.4 计划。
-
-**返回值（0.3.0）：**`tp-put-layer` / `tp-push-layer` 在给定 OBJECT 时
-返回 OBJECT（字符串形式返回该字符串本身），否则返回 `(START . END)`。
-其余每个栈修改函数都返回**被修改的属性区段数量**；层名或索引不存在时
-从不发出错误信号 —— 未匹配的区段被静默跳过，返回 0 表示没有任何匹配。
-
-#### `tp-put-layer` - 在指定位置设置属性层
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-put-layer START END LAYER IDX OBJECT NOERROR)
-
-;; 整个字符串
-(tp-put-layer STRING LAYER IDX NOERROR)
-```
-
-在属性层堆栈的指定索引位置设置属性层。
-
-- `IDX = 0`：顶部（可见属性层）
-- `IDX = -1`：底部
-- 其他值在该位置插入
-
-LAYER 接受以下几种形式：
-
-- 用 `define-tp` 定义的层名：`'highlight`
-- 内联属性 plist（无需 `define-tp`）：`'(face bold help-echo "tip")`
-- 层名列表（第一个层名位于顶部）：`'(layer-a layer-b)`
-- 参数化层调用：`'(tp-color "red")` —— 多参数层同样可用：
- `'(tp-colors "white" "black")`
-
-**栈模型：**只有顶层的属性是可见的文本属性；下层被保存在
-`tp-layers` 文本属性中，直到被上移、轮换或扁平化。
-
-**NOERROR（0.3.0 新增）：**LAYER 指向未定义的层或层组时，通常会发出错
-误信号。NOERROR 非 nil 时，调用改为返回 nil 且不做任何修改 —— 在应用
-可能尚未定义的层时非常方便。`tp-push-layer` 接受同样的末尾 NOERROR 参
-数。
-
-**示例：**
-
-```elisp
-;; 将 base 属性层放在顶部
-(progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-at 1 'tp-name)))
-;; => base
-
-;; 将 highlight 放在索引 1（顶部下面）
-(progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-put-layer 1 10 'highlight 1)
- (tp-layer-count 1 10)))
-;; => 2
-
-;; 将属性层放在底部
-(progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp info () '(face (:foreground "blue")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-put-layer 1 10 'info -1)
- (tp-layer-top 1 10)))
-;; => base ; info 在底部，base 可见
-
-;; 内联 plist - 无需 define-tp
-(with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(face bold help-echo "tip") 0)
- (list (tp-at 1 'face) (tp-at 1 'help-echo)))
-;; => (bold "tip")
-
-;; 层名列表 - layer-a 位于顶部
-(progn
- (tp-layer-reset)
- (define-tp layer-a () '(face bold))
- (define-tp layer-b () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(layer-a layer-b) 0)
- (list (tp-at 1 'face) (tp-layer-list 1 10))))
-;; => (bold (layer-a layer-b))
-
-;; 参数化层调用
-(progn
- (tp-layer-reset)
- (define-tp tp-color (color)
- `(face (:foreground ,color)))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(tp-color "red") 0)
- (tp-at 1 'face)))
-;; => (:foreground "red")
-
-;; NOERROR - 未定义的层名返回 nil 而不发出错误信号
-(with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'no-such-layer 0 nil t))
-;; => nil ; 没有任何修改
-```
-
----
-
-#### `tp-push-layer` - 推送属性层到顶部
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-push-layer START END LAYER OBJECT NOERROR)
-
-;; 整个字符串
-(tp-push-layer STRING LAYER NOERROR)
-```
-
-将属性层推到堆栈顶部（相当于 `tp-put-layer ... 0`）。
-NOERROR（0.3.0 新增）的用法与
-[`tp-put-layer`](#tp-put-layer---在指定位置设置属性层) 相同：未定义的
-LAYER 返回 nil 而不发出错误信号。
-
-**示例：**
-
-```elisp
-;; 首先推入 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-at 1 'tp-name)))
-;; => base
-
-;; 将 highlight 推到顶部（现在可见）
-(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-at 1 'tp-name)))
-;; => highlight
-
-;; 顶层的属性是可见的；下层保存在 `tp-layers' 中等待
-(progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (list :face (tp-at 1 'face)
- :top (tp-layer-top 1 10)
- :layers (tp-layer-list 1 10)
- :hidden (length (tp-at 1 'tp-layers)))))
-;; => (:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2)
-```
-
----
-
-### 属性层删除
-
-#### `tp-delete-layer` - 按名称/索引删除属性层
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-delete-layer START END LAYER-NAME/IDX OBJECT)
-
-;; 整个字符串
-(tp-delete-layer STRING LAYER-NAME/IDX)
-```
-
-通过名称或索引从堆栈任意位置删除属性层。
-
-**示例：**
-
-```elisp
-;; 按名称删除
-(progn
- (tp-layer-reset)
- (define-tp highlight () '(face (:background "yellow")))
- (define-tp base () '(face default))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (tp-delete-layer 1 10 'highlight)
- (tp-at 1 'tp-name)))
-;; => base
-
-;; 删除顶层（idx=0）
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-delete-layer 1 10 0)
- (tp-at 1 'tp-name)))
-;; => layer1
-
-;; 删除底层
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-delete-layer 1 10 -1)
- (tp-layer-count 1 10)))
-;; => 1
-```
-
----
-
-#### `tp-pop-layer` - 弹出顶层
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-pop-layer START END OBJECT)
-
-;; 整个字符串
-(tp-pop-layer STRING)
-```
-
-删除顶层（相当于 `tp-delete-layer ... 0`）。
-
-**示例：**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-pop-layer 1 10)
- (tp-at 1 'tp-name)))
-;; => layer1
-```
-
----
-
-### 属性层移动
-
-#### `tp-move-layer` - 移动属性层到指定位置
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-move-layer START END FROM-ID TO-IDX OBJECT)
-
-;; 整个字符串
-(tp-move-layer STRING FROM-ID TO-IDX)
-```
-
-将属性层从一个位置移动到另一个位置。
-
-- `FROM-ID` 标识要移动的层：可以是整数索引或层名称符号
-- `TO-IDX` 是目标位置（整数索引）
-- 索引 0 表示顶层（可见），-1 表示底层
-- 两个索引都是指移动之前的位置
-
-这是通用的属性层移动函数，`tp-raise-layer`、`tp-rotate-layer`、`tp-pin-layer` 和 `tp-switch-layer` 内部都使用它来实现。
-
-**示例：**
-
-```elisp
-;; 将索引 2 的层移动到索引 0（顶部）
-(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)
- ;; 堆栈: layer3 (0), layer2 (1), layer1 (2)
- (tp-move-layer 1 10 2 0)
- (tp-layer-top 1 10)))
-;; => layer1
-
-;; 按名称移动层到底部
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- ;; 堆栈: layer2 (顶), layer1 (底)
- (tp-move-layer 1 10 'layer2 -1)
- (tp-layer-top 1 10)))
-;; => layer1
-
-;; 在字符串上移动
-(let ((str (copy-sequence "Hello")))
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer str 'layer1)
- (tp-push-layer str 'layer2)
- ;; layer2 在顶部
- (tp-move-layer str 'layer1 0)
- (tp-at 0 'tp-name str))
-;; => layer1
-```
-
----
-
-#### `tp-raise-layer` - 上移/下移属性层
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-raise-layer START END IDX/LAYER-NAME N OBJECT)
-
-;; 整个字符串
-(tp-raise-layer STRING IDX/LAYER-NAME N)
-```
-
-将属性层上移 N 个位置。正数 N 向顶部移动，负数向底部移动。
-
-**示例：**
-
-```elisp
-;; 将 layer1 上移 2 个位置（到顶部）
-(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)
- ;; 堆栈: layer3 (顶), layer2, layer1 (底)
- (tp-raise-layer 1 10 'layer1 2)
- (tp-layer-top 1 10)))
-;; => layer1
-
-;; 将索引 0 的属性层下移 1 个位置
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- ;; 堆栈: layer2 (idx 0), layer1 (idx 1)
- (tp-raise-layer 1 10 0 -1)
- (tp-layer-top 1 10)))
-;; => layer1
-```
-
----
-
-#### `tp-lower-layer` - `tp-raise-layer` 的镜像
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-lower-layer START END IDX/LAYER-NAME N OBJECT)
-
-;; 整个字符串
-(tp-lower-layer STRING IDX/LAYER-NAME N)
-```
-
-将属性层下移 N 个位置（0.3.0 新增）。它是 `tp-raise-layer` 的镜像：正
-数 N 向底部移动，负数 N 向顶部移动。N 默认为 1，最终位置会被钳制在栈的
-范围内。返回被修改的属性区段数量。
-
-**示例：**
-
-```elisp
-;; 将顶层下移一个位置
-(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)
- ;; 堆栈: layer3 (顶), layer2, layer1 (底)
- (tp-lower-layer 1 10 'layer3 1)
- ;; 堆栈: layer2 (顶), layer3, layer1 (底)
- (list (tp-layer-top 1 10) (tp-layer-list 1 10))))
-;; => (layer2 (layer2 layer3 layer1))
-```
-
----
-
-#### `tp-rotate-layer` - 轮换属性层
-
-```elisp
-;; 缓冲区/字符串区域（规范顺序，OBJECT 在最后 - 0.3.0 新增）
-(tp-rotate-layer START END DIRECTION &optional COUNT OBJECT)
-
-;; 整个字符串
-(tp-rotate-layer STRING DIRECTION COUNT)
-
-;; 缓冲区/字符串区域（历史顺序，永远保持可用）
-(tp-rotate-layer START END OBJECT)
-```
-
-将属性层轮换 COUNT 步，保持它们的相对顺序。
-
-- **DIRECTION** 为 `down` 或 nil 时将顶层移到底部（历史行为），为
- `up` 时将底层带到顶部；其他值会发出错误信号。
-- **COUNT** 是轮换的步数，默认为 1；COUNT 小于 1 时不做任何轮换。隐藏
- 层随栈中其他层一起轮换。
-- 返回被修改的属性区段数量。
-
-两种区域顺序通过第三个参数区分：符号 `up` / `down` 永远不是合法的
-OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的
-`(START END DIRECTION [COUNT] [OBJECT])` 顺序 —— 无需 nil OBJECT 占位。
-第三个参数为其他值（缓冲区、字符串，或表示当前缓冲区的 nil）时选中历
-史的 `(START END OBJECT [DIRECTION] [COUNT])` 顺序，后者继续可用。
-
-**示例：**
-
-```elisp
-;; 堆栈: 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)
- ;; 堆栈: highlight (顶) -> base (底)
- (tp-rotate-layer 1 10)
- ;; 堆栈: base (顶) -> highlight (底)
- (tp-layer-top 1 10)))
-;; => base
-
-;; 规范顺序：`up' 将底层带到顶部
-(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)
- ;; 堆栈: layer3 (顶), layer2, layer1 (底)
- (tp-rotate-layer 1 10 'up)
- (tp-layer-list 1 10)))
-;; => (layer1 layer3 layer2)
-
-;; COUNT 一次轮换多步
-(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-rotate-layer 1 10 'down 2)
- (tp-layer-list 1 10)))
-;; => (layer1 layer3 layer2)
-```
-
----
-
-#### `tp-pin-layer` - 将属性层置顶
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-pin-layer START END IDX/LAYER-NAME OBJECT)
-
-;; 整个字符串
-(tp-pin-layer STRING IDX/LAYER-NAME)
-```
-
-将属性层移到栈顶。**一次性操作**：尽管名字里有 pin，但没有任何东西会
-保持"钉住"状态 —— 这只是一次移动到索引 0 的操作，之后的
-`tp-push-layer` 或 `tp-put-layer` 仍然可以覆盖被移动的层。
-
-**示例：**
-
-```elisp
-;; 将 '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)
- ;; highlight 在顶部
- (tp-pin-layer 1 10 'base)
- (tp-layer-top 1 10)))
-;; => base
-```
-
----
-
-#### `tp-switch-layer` - 交换两个属性层
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT)
-
-;; 整个字符串
-(tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)
-```
-
-交换两个属性层的位置。
-
-**示例：**
-
-```elisp
-;; 交换 layer1 和 layer2
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- ;; layer2 在顶部
- (tp-switch-layer 1 10 'layer1 'layer2)
- ;; 现在 layer1 在顶部
- (tp-layer-top 1 10)))
-;; => layer1
-```
-
----
-
-### 属性层可见性
-
-#### `tp-hide-layer` / `tp-show-layer` - 隐藏与显示属性层
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-hide-layer START END NAME OBJECT)
-(tp-show-layer START END NAME OBJECT)
-
-;; 整个字符串
-(tp-hide-layer STRING NAME)
-(tp-show-layer STRING NAME)
-```
-
-隐藏属性层而不移除它，以及让它重新渲染（0.3.0 新增）。NAME 标识属性
-层：层名符号，或指向完整栈（包含隐藏层）的整数索引（0 = 顶层，-1 =
-底层）。
-
-**可见性模型：**
-
-- 隐藏层**仍留在栈中**：它仍计入 `tp-layer-count`，出现在
- `tp-layer-list` 和 `tp-layer-stack-at` 中，也可以被移动、上移或下移
- —— 但它不渲染。文本改为展示最顶部**未隐藏**层的属性。
-- 因此隐藏当前可见的顶层会显露它下面的下一个可见层。
-- 当**所有**层都被隐藏时，文本以裸文本渲染（只剩 `tp-layers` 这个簿记
- 属性 —— 连 `tp-name` 也不渲染），同时所有层仍然可查询。
-- 隐藏层在隐藏期间**持续接收响应式更新**，因此 `tp-show-layer` 总是显
- 露最新的值（参见[层-缓冲区注册表与生命周期](#层-缓冲区注册表与生命周期)）。
-- `tp-flatten-layers` 只合并可见层，`tp-merge-layers` 排除隐藏的匹配层
- 的属性 —— 隐藏的内容绝不会泄漏（参见[属性层合并](#属性层合并)）。
-- 隐藏状态以 `tp-hidden` 标志的形式存储在 `tp-layers` 栈存储内该层的
- plist 中，因此 `tp-hidden` 与 `tp-name` 一样是层内部的保留属性名。
-- 任一层隐藏期间，直接属性是第一个可见 managed layer 的渲染缓存。
- definition/reactive refresh 具备明确所有权上下文，会把原生编辑保留到该
- 可见层；普通栈解码/写入仍采用严格策略，缓存不一致时会在改变状态之前发出
- `tp-layer-conflict`。所有层都隐藏时出现直接属性始终属于冲突。
-
-两个函数都返回被修改的属性区段数量。NAME 不匹配任何层时从不发出错误信
-号，隐藏一个已隐藏的层（或显示一个可见的层）是静默的空操作 —— 返回 0
-表示没有任何变化。
-
-**示例：**
-
-```elisp
-;; 隐藏顶层会显露下面的层；栈保持完整
-(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))))
-;; => (: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)
- (tp-hide-layer 1 10 'base)
- (list :face (tp-at 1 'face) :count (tp-layer-count 1 10))))
-;; => (:face nil :count 2)
-
-;; tp-show-layer 恢复该层的渲染
-(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-show-layer 1 10 'highlight)
- (tp-at 1 'face)))
-;; => (:background "yellow")
-
-;; 返回值：被修改的区段数量；名称不存在时静默返回 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)))) ; 没有这个层
-;; => (1 0 0)
-```
-
----
-
-### Managed Layer 生命周期
-
-Stage 4 为 managed layer stack 增加显式生命周期 metadata。只要存在 metadata，单个 managed layer 现在也使用 `tp-layers` 存储，因为 `tp-meta` 是权威生命周期状态。直接渲染到文本上的属性和公开 stack 查询都会剥离 `tp-meta`：`text-properties-at` 应只显示渲染属性和 stack storage，`tp-layer-stack-at` 返回的公开层 plist 不含 metadata。
-
-历史返回值保持不变。stack mutator 仍返回各自已记录的 object/range/run-count；诊断信息通过独立的只读 API 查询。
-
-参数化 mounted layer 会把 args 和 definition version 存入 `tp-meta`。重新定义参数化层后，已挂载 entry 会用保存的 args 刷新。metadata 出现前创建的 entry 作为 legacy entry 保守处理。
-
-#### `tp-attach-managed-layers` / `tp-detach-managed-layers`
-
-```elisp
-(tp-attach-managed-layers START END &optional OBJECT)
-(tp-detach-managed-layers START END &optional OBJECT KEEP-RENDERED)
-```
-
-`tp-attach-managed-layers` 扫描已含 managed layer storage 的区域，补齐缺失 metadata，把发现的层登记到响应式缓冲区注册表，并按范围顺序返回层名。通过原生插入路径插入带 managed 属性的字符串后使用它。
-
-`tp-detach-managed-layers` 移除 managed storage 并返回被 detach 的层名。KEEP-RENDERED 非 nil 时，当前可见渲染属性会保留为普通文本属性；生命周期存储（`tp-name`、`tp-layers`、`tp-meta`）会被移除。
-
-#### `tp-managed-layer-diagnostics` / `tp-managed-buffer-diagnostics` / `tp-managed-diagnostics`
-
-```elisp
-(tp-managed-layer-diagnostics LAYER-NAME)
-(tp-managed-buffer-diagnostics &optional BUFFER)
-(tp-managed-diagnostics)
-```
-
-这些函数是只读诊断。它们报告 layers、buffers、entries、保存的 args、registry state、errors 和 theme diagnostics。`tp-managed-diagnostics` 包含 `:theme` plist，其中有 generation、last hook source、refresh mode、refreshed ranges 和 errors。theme enable/disable hook 会递增 generation，并使用 conservative refresh diagnostics；这是生命周期证据，不是 benchmark。
-
-#### `tp-layer-transaction`
-
-```elisp
-(tp-layer-transaction START END OBJECT FUNCTION &optional NOERROR)
-```
-
-在 managed range 上执行 FUNCTION。成功时返回结构化 plist，包含 `:status ok`、`:ok t`、FUNCTION 返回值对应的 `:result`、operation id、range 和 changed ranges。失败时恢复事务前的完整文本/属性快照；默认发出 `tp-layer-transaction-error`，NOERROR 非 nil 时返回带 rollback 状态的结构化失败 plist。
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp tx-base () '(face bold))
- (define-tp tx-temp () '(face italic))
- (with-temp-buffer
- (insert "abcd")
- (let ((result
- (tp-layer-transaction
- 1 4 (current-buffer)
- (lambda () (tp-put-layer 1 3 'tx-base 0)))))
- (list (plist-get result :status)
- (plist-get result :range)
- (tp-at 1 'face)))))
-;; => (ok (1 . 4) bold)
-```
-
-theme generation 与 managed diagnostics 已作为生命周期行为验证。可复现 benchmark 证据记录在 `docs/BENCHMARKS.md`；这些耗时是建议性基线，不是发布阈值。
-
----
-
-### 属性层合并
-
-#### `tp-merge-layers` - 合并多个属性层
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-merge-layers START END NEW-LAYER-NAME '(IDX1 LAYER-NAME1 IDX2 ...) OBJECT)
-
-;; 整个字符串
-(tp-merge-layers STRING NEW-LAYER-NAME '(IDX1 LAYER-NAME1 IDX2 ...))
-```
-
-将指定的属性层合并为一个新属性层。列表中靠前的属性层优先级更高。
-
-**隐藏层（0.3.0）：**隐藏的匹配层会和其他层一起被合并掉，但**不**向合
-并层贡献任何属性，因此合并绝不会渲染出被隐藏的内容。当*所有*匹配层都
-被隐藏时，合并层保留它们合并后的属性，但自身携带 `tp-hidden` 标志 ——
-数据被保留而没有取消任何隐藏，对合并层执行 `tp-show-layer` 即可渲染
-它。返回被修改的属性区段数量（0 = 列出的层都没有匹配）。
-
-**示例：**
-
-```elisp
-;; 将 layer1 和 layer2 合并为 merged-layer
-(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-merge-layers 1 10 'merged-layer '(layer1 layer2))
- (tp-at 1 'tp-name)))
-;; => merged-layer
-
-;; 按索引合并
-(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-merge-layers 1 10 'merged '(0 1))
- (tp-layer-count 1 10)))
-;; => 1
-
-;; 隐藏层的属性绝不会泄漏进合并结果
-(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))))
-;; => (:face bold :help nil :name merged) ; layer2 被隐藏了
-```
-
----
-
-#### `tp-flatten-layers` - 扁平化所有属性层
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-flatten-layers START END NAME OBJECT)
-
-;; 整个字符串
-(tp-flatten-layers STRING NAME)
-```
-
-将所有属性层扁平化为一个具有给定名称的单一属性层。
-
-**隐藏层（0.3.0）：**隐藏层会被**丢弃**，与图像编辑器的扁平化语义一致
-—— 只有可见层的属性会合并进结果，因此扁平化绝不会渲染出被隐藏的内容。
-当某个区段的*所有*层都被隐藏时，该区段的属性会被完全清除（裸文本），
-与 `tp-hide-layer` 的全隐藏渲染行为一致。返回被修改的属性区段数量
-（0 = 没有区段带有属性层）。
-
-**示例：**
-
-```elisp
-;; 将所有属性层扁平化为 'flat-layer
-(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-flatten-layers 1 10 'flat-layer)
- (tp-at 1 'tp-name)))
-;; => flat-layer
-
-;; 使用 nil 名称扁平化（无名属性层）
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-flatten-layers 1 10 nil)
- (tp-at 1 'tp-name)))
-;; => 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)
- (tp-hide-layer 1 10 'highlight)
- (tp-flatten-layers 1 10 'flat)
- (list (tp-at 1 'face) (tp-at 1 'tp-name))))
-;; => (default flat) ; highlight 的背景色消失了
-```
-
----
-
-### 属性层查询函数
-
-#### `tp-layer-list` - 列出所有属性层
-
-```elisp
-(tp-layer-list START END &optional OBJECT)
-```
-
-获取区域中所有属性层名称的列表。
-
-**示例：**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp highlight () '(face (:background "yellow")))
- (define-tp base () '(face default))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (tp-layer-list 1 10)))
-;; => (highlight base)
-```
-
----
-
-#### `tp-layer-count`
-
-```elisp
-(tp-layer-count START END &optional OBJECT)
-```
-
-计算区域中的属性层数量。
-
-**示例：**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-layer-count 1 10)))
-;; => 2
-```
-
----
-
-#### `tp-layer-exists-p`
-
-```elisp
-(tp-layer-exists-p START END NAME &optional OBJECT)
-```
-
-检查区域中是否存在某属性层。
-
-**示例：**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (list (tp-layer-exists-p 1 10 'layer1)
- (tp-layer-exists-p 1 10 'layer2))))
-;; => (t nil)
-```
-
----
-
-#### `tp-layer-top`
-
-```elisp
-(tp-layer-top START END &optional OBJECT)
-```
-
-获取顶层属性层的名称。最顶部的层按**栈序**报告，即使它被隐藏（参见
-[`tp-hide-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层)）；
-要区分隐藏层和可见层，请使用 `tp-layer-stack-at`。
-
-**示例：**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-layer-top 1 10)))
-;; => layer2
-```
-
----
-
-#### `tp-layer-stack-at` - 获取某位置的完整层栈
-
-```elisp
-(tp-layer-stack-at POS &optional OBJECT)
-```
-
-返回某一位置上完整的有序层栈（0.3.0 新增），列表中每层一个元素，最顶
-层在前，每个元素是一个 cons `(NAME . PROPS)`：
-
-- **NAME** 是层的 `tp-name` 符号，无名层为 nil。
-- **PROPS** 是层的属性 plist，其中不含 `tp-name` 条目。隐藏层可通过
- PROPS 中值为 t 的 `tp-hidden` 条目辨认；可见层永远不携带该条目。
-
-隐藏层按其栈位置包含在内。裸文本返回 nil。POS 使用 OBJECT 的原生坐标
-（字符串从 0 开始，缓冲区从 1 开始）；OBJECT 是字符串、缓冲区，或表示
-当前缓冲区的 nil。
-
-**示例：**
-
-```elisp
-(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-layer-stack-at 1)))
-;; => ((highlight . (face (:background "yellow")))
-;; (base . (face default)))
-
-;; 隐藏层在 PROPS 中携带 `tp-hidden' 条目
-(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-layer-stack-at 1)))
-;; => ((highlight . (tp-hidden t face (:background "yellow")))
-;; (base . (face default)))
-
-;; 裸文本没有层栈
-(with-temp-buffer
- (insert "Hello")
- (tp-layer-stack-at 1))
-;; => nil
-```
-
----
-
-#### `tp-add-to-layers` - 向特定属性层添加属性
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-add-to-layers IDX-OR-LAYER-NAME-LIST START END PLIST &optional OBJECT)
-
-;; 整个字符串
-(tp-add-to-layers IDX-OR-LAYER-NAME-LIST STRING PROP VAL ...)
-```
-
-向区域或字符串中的特定属性层添加或合并属性。
-
-- **IDX-OR-LAYER-NAME-LIST** 是层索引（整数）或层名称（符号）的列表。对于索引：0 表示顶层，-1 表示底层。
-- 属性被深度合并到指定的层中（嵌套的 plist 被合并，而非替换）。
-- OBJECT 在区域形式中默认为当前缓冲区。
-- 与其他栈修改函数一样（且与 `tp-set` 不同），字符串形式会**就地**修
- 改 STRING 并返回这个被修改的字符串本身。对于缓冲区，返回 nil。
-
-**示例：**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp layer1 () '(face (:foreground "red")))
- (define-tp layer2 () '(face (:foreground "blue")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- ;; 向两个层添加下划线
- (tp-add-to-layers '(0 1) 1 10 '(face (:underline t)))
- (tp-at 5)))
-;; 两个层现在都有下划线与其颜色合并
-```
-
----
-
-#### `tp-add-to-all-layers` - 向所有属性层添加属性
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-add-to-all-layers START END PLIST &optional OBJECT)
-
-;; 整个字符串
-(tp-add-to-all-layers STRING PROP VAL ...)
-```
-
-向区域或字符串中的所有属性层添加或合并属性。
-
-- 属性被深度合并到所有现有层中。
-- OBJECT 在区域形式中默认为当前缓冲区。
-- 与其他栈修改函数一样（且与 `tp-set` 不同），字符串形式会**就地**修
- 改 STRING 并返回这个被修改的字符串本身。对于缓冲区，返回 nil。
-
-**示例：**
-
-```elisp
-(let ((str (copy-sequence "Hello World")))
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 0 5 'layer1 str)
- (tp-push-layer 0 5 'layer2 str)
- ;; 向所有层添加下划线
- (tp-add-to-all-layers 0 5 '(face (:underline t)) str)
- str)
-```
-
----
-
-#### `tp-intervals` - 获取文本属性区间
-
-```elisp
-(tp-intervals START END &optional OBJECT ABSOLUTE)
-```
-
-从 OBJECT 中获取 START 到 END 之间的所有文本属性区间。
-
-- 返回每个区间的 (START END PROPERTIES) 列表，包括没有属性的
- 间隙区间，其 PROPERTIES 为 nil。
-- 对于缓冲区输入，START 和 END 是从 1 开始的缓冲区位置，但返回的位置
- 默认是**相对于 START 的 0 基偏移量**（历史约定）。ABSOLUTE 非 nil
- 时（0.3.0 新增），返回的位置改为原生的 1 基缓冲区位置，可以不做偏移
- 运算直接用于其他 tp 调用（`tp-set`、`tp-remove` 等）。对于字符串，
- 位置始终是绝对的 0 基索引；ABSOLUTE 不改变任何行为。
-- 使用 `object-intervals`（需要 Emacs 28.1+）。
-- OBJECT 可以是缓冲区或字符串；nil 默认为当前缓冲区。
-
-**示例：**
-
-```elisp
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-intervals 1 12))
-;; => ((0 5 (face bold)) (5 6 nil) (6 11 (face italic)))
-;; 位置是相对 START 的偏移量；(5 6 nil) 是无属性的间隙
-
-;; ABSOLUTE - 原生缓冲区坐标
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-intervals 1 12 nil t))
-;; => ((1 6 (face bold)) (6 7 nil) (7 12 (face italic)))
-
-;; ABSOLUTE 位置可直接回馈给其他 tp 调用
-(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))
-;; => "bold text"
-```
-
----
-
-#### `tp-intervals-map` - 对区间应用函数
-
-```elisp
-(tp-intervals-map FUNCTION START END &optional OBJECT ABSOLUTE)
-```
-
-对 OBJECT 中 START 到 END 之间的所有区间应用 FUNCTION。
-
-- FUNCTION 接收四个参数：interval-start、interval-end、top-props（直
- 接渲染的属性，其中的 `tp-layers` 条目已被移除）和 below-props-lst
- （`tp-layers` 的值：埋在被渲染顶层之下的层 plist 存储 —— 当任何层被
- 隐藏时它保存整个有序层栈；解码后的视图参见
- [`tp-layer-stack-at`](#tp-layer-stack-at---获取某位置的完整层栈)）。
-- 没有属性的区间也会被访问，此时 top-props 为 nil（位置遵循与
- `tp-intervals` 相同的坐标约定，包括 0.3.0 新增的 ABSOLUTE 参数）。
-- OBJECT 可以是缓冲区或字符串；nil 默认为当前缓冲区。
-- 返回函数结果列表（nil 结果被移除）。
-
-**示例：**
-
-```elisp
-(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)
- (list start end (plist-get props 'face)))
- 1 12))
-;; => ((0 5 bold) (5 6 nil) (6 11 italic))
-
-;; ABSOLUTE - FUNCTION 接收原生缓冲区位置
-(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)
- (list start end (plist-get props 'face)))
- 1 12 nil t))
-;; => ((1 6 bold) (6 7 nil) (7 12 italic))
-```
-
----
-
-#### `tp-region-layer-props` - 获取区域中的层属性
-
-```elisp
-(tp-region-layer-props START END LAYER-NAME &optional OBJECT)
-```
-
-返回区域 START 到 END 中 LAYER-NAME 的层属性。
-
-- 返回匹配区间的 (START END PROPERTIES) 列表。
-- OBJECT 默认为当前缓冲区。
-
-**示例：**
-
-```elisp
-(progn
- (tp-layer-reset)
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World Test")
- (tp-push-layer 1 6 'highlight)
- (tp-push-layer 12 16 'highlight)
- (tp-region-layer-props 1 16 'highlight)))
-;; => ((1 6 (face (:background "yellow") tp-name highlight))
-;; (12 16 (face (:background "yellow") tp-name highlight)))
-```
-
----
-
-#### `tp-plist` - 获取区域中的所有属性
-
-```elisp
-;; 缓冲区/字符串区域
-(tp-plist START END &optional OBJECT)
-
-;; 整个字符串
-(tp-plist STRING)
-```
-
-获取区域或字符串中存在的所有属性的属性列表。
-
-- 返回将范围内找到的属性合并成的单个 plist；当同一属性出现在多个
- 区间中时，靠后区间的值胜出。
-- OBJECT 在区域形式中默认为当前缓冲区。
-
-**示例：**
-
-```elisp
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold help-echo "Tip"))
- (tp-set 7 12 '(face italic))
- (tp-plist 1 12))
-;; => (help-echo "Tip" face italic) ; 靠后区间的 face 胜出
-```
-
----
-
-#### `tp-empty-p` - 检查对象是否有属性
-
-```elisp
-(tp-empty-p &optional OBJECT)
-```
-
-如果 OBJECT 没有文本属性，返回 t。
-
-- OBJECT 可以是字符串或缓冲区；nil 默认为当前缓冲区。
-- 使用 `object-intervals`（需要 Emacs 28.1+）。
-
-**示例：**
-
-```elisp
-(tp-empty-p "plain text") ; => t
-
-;; 整个字符串形式的 tp-set 是非破坏性的：原始字符串保持无属性
-(let* ((str "text")
- (new (tp-set str 'face 'bold)))
- (list (tp-empty-p str) (tp-empty-p new)))
-;; => (t nil)
-```
-
----
-
-#### `tp-with-current-buffer` / `tp-pop-to-buffer` / `tp-switch-to-buffer`
-
-```elisp
-(tp-with-current-buffer BUFFER-OR-NAME BODY...)
-(tp-pop-to-buffer BUFFER-OR-NAME BODY...)
-(tp-switch-to-buffer BUFFER-OR-NAME BODY...)
-```
-
-用于操作和展示带属性内容的便捷宏：
-
-- **`tp-with-current-buffer`** 在 BUFFER-OR-NAME 中求值 BODY，并将
- `inhibit-read-only` 绑定为 t。适合修改只读的展示缓冲区。
-- **`tp-pop-to-buffer`** 创建（或复用）BUFFER-OR-NAME，清空它，在其中
- 求值 BODY，然后将其设为只读并通过 `pop-to-buffer` 显示。在显示的
- 缓冲区中按 `q` 可退出其窗口。
-- **`tp-switch-to-buffer`** 与上者相同，但通过 `switch-to-buffer`
- 显示缓冲区。
-
-**示例：**
-
-```elisp
-(tp-pop-to-buffer "*tp-demo*"
- (insert (tp-set "Important" 'face '(:foreground "red" :weight bold))
- " message\n"))
-;; 显示 *tp-demo* 及其中的带属性文本；按 `q' 退出窗口
-```
-
----
-
-### 调色板系统
-
-`tp-palette.el` 内置了一组具名调色板，每个调色板包含独立的亮色模式和
-暗色模式颜色；`tp-builtins.el` 通过内置的参数化 `tp-palette` 层将它们
-暴露出来（如 `(tp-set "emacs" 'tp-palette 'info)`）。
-
-- **`tp-palette-alist`**（变量）— `(NAME . PLIST)` 形式的调色板定义
- alist；调色板查询的唯一数据源。每个 PLIST 将 `:fg`、`:bg` 和
- `:border` 映射到颜色。
-- **`define-tp-palette`** — 注册（或更新）一个调色板（自 0.3.0 起也可
- 使用符合前缀规范的别名 `tp-define-palette`）：
-
- ```elisp
- (define-tp-palette my-brand
- :fg ("#0969da" . "#58a6ff") ; ("亮色" . "暗色")
- :bg ("#ddf4ff" . "#1f3d5c"))
- ```
-
-- **`tp-palette-color`**（0.3.0 新增）— **首选的**调色板访问器：获取调
- 色板的 `:fg` / `:bg` / `:border` 颜色，按当前亮色/暗色主题解析。调色
- 板或键不存在时返回 nil：
-
- ```elisp
- (tp-palette-color 'info :fg)
- ;; => 亮色主题下为 "#0969da"，暗色主题下为 "#58a6ff"
- (tp-palette-color 'no-such-palette :fg)
- ;; => nil
- ```
-
-- **`tp-palette-has-p`**（0.3.0 新增）— **首选的**调色板谓词：只传
- SYMBOL 时测试它是否命名了一个已注册的调色板；KIND 为 `:fg` / `:bg` /
- `:border` 之一时，还要求其定义中含有该键（已定义的键在当前主题下仍
- 可能解析不出颜色 —— 在意解析后颜色时请使用 `tp-palette-color`）：
-
- ```elisp
- (list (tp-palette-has-p 'info)
- (tp-palette-has-p 'info :border)
- (tp-palette-has-p 'no-such-palette))
- ;; => (t t nil)
- ```
-
- 旧的按键便捷函数保留为兼容包装：`tp-palette-fg-color` /
- `tp-palette-bg-color` / `tp-palette-border-color`（`tp-palette-color`
- 的固定 KEY 变体）、`tp-palette-p`（KIND 为 nil 的
- `tp-palette-has-p`），以及带后缀名的谓词 `tp-palette-fg-p` /
- `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p` —— 它
- 们回答的是另一个问题：像 `info-fg` 这样的*变体名*是否表示一个已注册
- 的调色板（`tp-palette` 层使用的约定）。
-
-- **`tp-palette-show`** — 交互式命令，显示一个画廊缓冲区，展示每个已
- 注册调色板及其 `-fg` / `-bg` / `-fbg` / `-border` 变体（按 `q` 退出）。
-- **`tp-parse-color`** — 按当前主题解析颜色规格。接受普通颜色字符串、
- `("亮色" . "暗色")` cons（任意一侧可以为 nil），或
- `(:light L :dark D)` plist：
-
- ```elisp
- (tp-parse-color "red") ; => "red"
- (tp-parse-color '("white" . "black")) ; => 亮色主题下为 "white"，
- ; 暗色主题下为 "black"
- ```
-
-注意：`tp-layer-reset` 会清除所有属性层定义，包括 `tp-palette` 这样的
-内置属性层。
-
----
-
-## 实用示例
-
-### 多属性层语法高亮
-
-```elisp
-;; 可以在缓冲区中运行的完整示例
-(progn
- (tp-layer-reset)
- ;; 为不同高亮目的定义属性层
- (define-tp code-base ()
- '(face font-lock-keyword-face))
- (define-tp code-error ()
- '(face (:underline (:color "red" :style wave))
- help-echo "语法错误"))
- (define-tp code-debug ()
- '(face (:background "dark blue")))
- (with-temp-buffer
- (insert (make-string 100 ?x)) ; 创建 100 字符缓冲区
- ;; 应用基础高亮
- (tp-push-layer 1 100 'code-base)
- ;; 在有问题的代码上添加错误高亮
- (tp-push-layer 50 60 'code-error)
- ;; 检查位置 55 的顶层
- (tp-layer-top 50 60)))
-;; => code-error
-
-;; 切换函数（用于实际缓冲区）
-(defun toggle-error-view (start end)
- "在错误和正常视图之间切换。"
- (interactive "r")
- (tp-rotate-layer start end))
-```
-
-### 状态指示器
-
-```elisp
-;; 包含属性层组的完整示例
-(progn
- (tp-layer-reset)
- ;; 将状态属性层定义为一个组
- (define-tp status-todo () '(face (:foreground "gray")))
- (define-tp status-progress () '(face (:foreground "yellow")))
- (define-tp status-done () '(face (:foreground "green")))
- (define-tps task-status () 'status-todo 'status-progress 'status-done)
- ;; 检查组是否已定义
- (length (tp-group-props 'task-status)))
-;; => 3
-
-;; 循环切换状态（用于实际缓冲区）
-(defun cycle-task-status ()
- "循环切换当前行的任务状态属性层。"
- (interactive)
- (tp-rotate-layer (line-beginning-position) (line-end-position)))
-```
-
-### 临时高亮
-
-```elisp
-;; 定义临时高亮属性层
-(progn
- (tp-layer-reset)
- (define-tp temp-highlight ()
- '(face (:background "yellow")))
- (tp-layer-props 'temp-highlight))
-;; => (face (:background "yellow"))
-
-;; 闪烁函数（用于实际缓冲区）
-(defun flash-region (start end)
- "临时闪烁一个区域。"
- (tp-push-layer start end 'temp-highlight)
- (run-with-timer 0.5 nil
- (lambda (s e)
- (tp-delete-layer s e 'temp-highlight))
- start end))
-```
-
----
-
-## 响应式文本属性
-
-> 📖 **完整的详细指南和示例，请参阅 [响应式文本属性完全指南](docs/reactive-text-properties.md)**
->
-> 📖 **高级优化功能，请参阅 [响应式系统优化文档](docs/reactive-optimization.md)**
-
-**响应式文本属性**是 tp.el 的突破性创新，它将响应式编程范式带入了 Emacs 文本属性。受 Vue.js 等现代前端框架启发，这个功能使文本属性能够在底层变量值改变时自动更新。
-
-### 核心概念
-
-传统的文本属性操作需要在每次想要改变属性值时手动更新所有受影响的文本区域。使用响应式文本属性，你只需定义一次变量关系，tp.el 会自动处理所有更新：
-
-```elisp
-;; 传统方式（需要手动更新）
-(defvar my-color "red")
-(tp-set 1 10 '(face (:foreground "red")))
-;; 要改变颜色，你必须手动更新每个区域：
-(setq my-color "blue")
-(tp-set 1 10 '(face (:foreground "blue"))) ; 手动更新！
-
-;; 响应式方式（自动更新）
-(defvar my-color "red")
-(define-tp my-layer ()
- :props '(face (:foreground $my-color)))
-(tp-push-layer 1 10 'my-layer)
-;; 只需改变变量 - 所有文本自动更新！
-(setq my-color "blue") ;; 所有使用 my-layer 的区域立即更新！
-```
-
-### 工作原理
-
-1. **响应式变量**：`:props` 中任何以 `$` 为前缀的符号都被视为响应式变量。`$` 会被去掉以获取实际的变量名。
-
-2. **变量监听器**：tp.el 使用 Emacs 的 `add-variable-watcher` 来监控响应式变量的变化。
-
-3. **自动更新**：当响应式变量通过 `setq` 改变时，所有使用依赖该变量的层的文本区域会自动使用新的属性值更新。
-
-### 定义响应式层
-
-#### 基本响应式层
-
-```elisp
-(defvar highlight-color "yellow")
-
-(define-tp my-highlight ()
- :props '(face (:background $highlight-color)))
-
-(with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'my-highlight)
- ;; 文本以黄色高亮
-
- (setq highlight-color "cyan")
- ;; 文本现在以青色高亮 - 自动更新！
-)
-```
-
-#### 多个响应式变量
-
-```elisp
-(defvar fg-color "white")
-(defvar bg-color "black")
-
-(define-tp themed-text ()
- :props '(face (:foreground $fg-color :background $bg-color)))
-
-;; 改变任一变量都会更新文本
-(setq fg-color "yellow") ;; 更新前景色
-(setq bg-color "navy") ;; 更新背景色
-```
-
-### :data - 附加响应式状态
-
-`:data` 关键字定义不直接用于 `:props` 但可以触发计算值更新或被监听的额外响应式变量：
-
-```elisp
-(define-tp user-info ()
- :props '(help-echo $full-name)
- :data '(first-name last-name) ;; 不直接用于 props
- :compute '((full-name (lambda () (concat first-name " " last-name)))))
-```
-
-**带初始值：**
-
-你可以使用 cons cell 指定初始值：
-
-```elisp
-(define-tp user-info ()
- :props '(help-echo $full-name)
- :data '((first-name . "张") (last-name . "三"))
- :compute '((full-name (lambda () (concat first-name last-name)))))
-
-;; first-name 现在是 "张"，last-name 现在是 "三"
-```
-
-### :compute - 计算属性
-
-`:compute` 关键字创建派生值，当它们的依赖项改变时会自动重新计算：
-
-```elisp
-(define-tp progress-display ()
- :props '(display $progress-text face (:foreground $progress-color))
- :data '((current . 0) (total . 100))
- :compute '((progress-text (lambda () (format "%d%%" (/ (* current 100) total))))
- (progress-color (lambda ()
- (cond ((< current 30) "red")
- ((< current 70) "yellow")
- (t "green"))))))
-
-;; 更新进度
-(setq current 50)
-;; progress-text 变成 "50%"，progress-color 变成 "yellow"，自动更新！
-```
-
-### :watch - 副作用回调
-
-`:watch` 关键字让你在响应式变量改变时执行回调：
-
-```elisp
-(define-tp monitored-layer ()
- :props '(face (:foreground $status-color))
- :watch '((status-color
- (lambda (new-val old-val layer-name)
- (message "层 %s: 颜色从 %s 改为 %s"
- layer-name old-val new-val)))))
-
-(setq status-color "red")
-;; 消息: "层 monitored-layer: 颜色从 nil 改为 red"
-
-(setq status-color "green")
-;; 消息: "层 monitored-layer: 颜色从 red 改为 green"
-```
-
-### :transform - 值转换
-
-`:transform` 关键字允许你注册一个转换函数，在 `tp-text` 值显示之前对其进行处理。这对于格式化数字、日期或其他值非常有用：
-
-```elisp
-;; 数字格式化
-(define-tp price-display ()
- :props '(tp-text $price)
- :data '((price . "99.9"))
- :transform (lambda (text)
- (format "$%.2f" (string-to-number text))))
-;; 99.9 显示为 $99.00
-
-;; 日期格式化
-(define-tp date-display ()
- :props '(tp-text $timestamp)
- :data '((timestamp . "1703865600"))
- :transform (lambda (text)
- (format-time-string "%Y-%m-%d"
- (seconds-to-time (string-to-number text)))))
-
-;; 大写转换
-(define-tp uppercase-text ()
- :props '(tp-text $content)
- :data '((content . "hello"))
- :transform #'upcase)
-;; "hello" 显示为 "HELLO"
+ (tp-apply (current-buffer) 2 5 '(face italic)))
```
-转换函数的特点：
-- 接收原始的 `tp-text` 字符串值
-- 返回用于显示的转换后字符串
-- 在初始显示和响应式更新时都会应用
-- 必须返回字符串；失败或返回非字符串会向上传播，不会渲染陈旧输入
-
-compute 函数遵循相同的业务错误规则。watch 回调属于 observer：其失败会被
-隔离，渲染仍继续；结构化错误按 newest-first 记录在
-`tp-reactive-observer-errors`。
-
-### 匿名响应式层
+原有的 `tp-set`、`tp-reset`、`tp-add`、`tp-remove`、`tp-clear`、`tp-get`、`tp-at`、`tp-member`、match、regexp、search、navigation、interval 和 native query API 继续作为普通文本属性操作的直接 façade。
-即使不使用 `define-tp`，你也可以使用响应式变量。当你在匿名 plist 中使用 `$` 前缀的符号时，tp.el 会自动生成唯一的层名：
+## 可复用声明配方
-```elisp
-(defvar my-face-color "blue")
-
-;; 匿名响应式层 - tp-name 自动生成
-(tp-set 1 10 '(face (:foreground $my-face-color)))
-
-;; 该层现在是响应式的 - 改变变量会更新文本
-(setq my-face-color "red")
-```
-
-### API 中的层名解析
-
-所有文本属性 API（`tp-set`、`tp-match-set`、`tp-regexp-set` 等）现在可以直接接受层名：
+`define-tp` 和 `define-tps` 定义可以展开为直接 Emacs 属性的复用配方。它们只是 definition-time convenience，不是 live mounted layer，也不会把 identity 或 provenance 写入显示文本。
```elisp
-(define-tp warning-style ()
- :props '(face (:foreground "orange" :weight bold)))
-
-;; 使用层名代替 plist
-(tp-set 1 10 'warning-style)
-
-;; 适用于所有匹配函数
-(tp-match-set "TODO" 'warning-style)
-(tp-regexp-set "[0-9]+" 'warning-style)
-```
-
-对非响应式层而言，这种直接使用属于**模板展开**：定义被展开为普通文本
-属性，不保留 `tp-name`。如果需要后续按名查询、移动、隐藏、删除，或在非
-参数化层重定义后刷新，请使用 `tp-push-layer` / `tp-put-layer` 建立
-**managed mount**。参数化 mounted entry 目前没有保存实参，因此参数化层
-重定义不会自动刷新既有实例。
-
-### 响应式层组
-
-层组也可以使用响应式特性：
+(define-tp link-style (foreground)
+ `(face (:foreground ,foreground :weight bold)
+ mouse-face highlight
+ help-echo "Open item"))
-```elisp
-(define-tps status-indicators ()
- '("success" :props (face (:foreground $success-color))
- :data ((success-color . "green")))
- '("warning" :props (face (:foreground $warning-color))
- :data ((warning-color . "orange")))
- '("error" :props (face (:foreground $error-color))
- :data ((error-color . "red"))))
+(tp-set "Project" '(link-style "#58a6ff"))
```
-### 批量更新
-
-同时修改多个响应式变量时，每个 `setq` 都会触发一次缓冲区更新。使用 `tp-with-batch-updates` 可以合并所有更改，在结束时一次性应用：
+属性值需要求值时使用 `tp-computed`；任何普通函数对象仍然按 literal 保存。
```elisp
-(define-tp themed-text ()
- :props '(face (:foreground $fg-color :background $bg-color))
- :data '((fg-color . "white") (bg-color . "black")))
-
-(with-temp-buffer
- (insert "Hello World")
- (tp-set 1 12 'themed-text)
-
- ;; 不使用批量更新：每个 setq 都会触发一次缓冲区更新
- (setq fg-color "yellow") ; 第一次更新
- (setq bg-color "navy") ; 第二次更新
-
- ;; 使用批量更新：所有变化在结束时一次性应用
- (tp-with-batch-updates
- (setq fg-color "red")
- (setq bg-color "blue"))) ; 只更新一次
-```
+(defvar my-height 1.2)
-批量更新的好处：
-- 减少冗余的缓冲区修改
-- 提高同时更改多个变量时的性能
-- 当多个变量相互依赖时确保状态一致
-
-### 层-缓冲区注册表与生命周期
-
-自 0.3.0 起，响应式引擎维护一个**层→缓冲区注册表**：每条修改缓冲区并
-盖上层标记的写入路径（`tp-set` 家族、栈修改函数、match/regexp 应用函
-数）都会把目标缓冲区注册为展示该层，而一次响应式更新只访问**已注册的
-缓冲区**，不再扫描整个 `(buffer-list)`。被杀死的缓冲区会被自动清理。
-当某个层完全没有注册表条目时，会退回到旧行为做一次**学习性全量扫描**，
-并把实际发现该层的每个缓冲区都注册上。
-
-即使层被**隐藏**或**埋**在栈中其他层之下，更新也能到达它的区域：存储
-在 `tp-layers` 中的条目会被就地更新，因此 `tp-show-layer`（或上移该
-层）总是显露最新的值。
-
-#### `tp-reactive-layer-buffers` - 查看注册表
-
-```elisp
-(tp-reactive-layer-buffers LAYER-NAME)
+(define-tp sized-label ()
+ `(face ,(tp-computed (lambda () (list :height my-height)))))
```
-返回注册为展示 LAYER-NAME 的存活缓冲区 —— 一个列表（可能为空，表示
-"已知：没有缓冲区展示该层"）—— 或者符号 `unknown`，表示该层完全没有注
-册表条目：
-
-```elisp
-(progn
- (tp-layer-reset)
- (defvar reg-color "red")
- (define-tp reg-layer ()
- :props '(face (:foreground $reg-color)))
- (tp-reactive-layer-buffers 'reg-layer))
-;; => unknown ; 还从未被应用到任何缓冲区
+computed function 在当前 binding/prepare context 中执行，因此其中的 `tp-signal-read` 和 `tp-binding-read` 会建立精确依赖。返回值只 normalize/project 一次，然后作为 literal data 使用。
-(with-temp-buffer
- (rename-buffer "demo-buffer" t)
- (insert "Hello")
- (tp-push-layer 1 6 'reg-layer)
- (mapcar #'buffer-name (tp-reactive-layer-buffers 'reg-layer)))
-;; => ("demo-buffer")
-```
+## 响应式已有文本
-#### `tp-reactive-track-buffer` - 补齐字符串插入的缺口
+`tp-watch` 装饰 marker-backed host range，但不拥有或替换其中的文字：
```elisp
-(tp-reactive-track-buffer &optional BUFFER) ; interactive
+(let ((online (tp-signal-create nil)))
+ (with-current-buffer (get-buffer-create "*tp-status*")
+ (erase-buffer)
+ (insert "offline")
+ (tp-watch
+ (current-buffer) 1 8
+ (lambda ()
+ (list 'face
+ (list :foreground
+ (if (tp-signal-read online) "green" "red")))))))
```
-**已知缺口：**向缓冲区插入一个*已经带属性的字符串*会绕过注册缓冲区的
-缓冲区操作，因此在一次学习性全量扫描找到它之前，该缓冲区不在注册表中。
-在这类插入之后调用 `tp-reactive-track-buffer`：它会扫描 BUFFER（默认
-为当前缓冲区）中的层区域 —— 既包括被渲染的顶层，也包括埋在或隐藏在
-`tp-layers` 栈存储中的层 —— 为每个层注册该缓冲区，并按缓冲区顺序返回
-找到的层名：
-
-```elisp
-(let ((s (tp-set "hello" 'reg-layer))) ; 带属性的字符串，游离状态
- (with-temp-buffer
- (insert s) ; 绕过了注册
- (tp-reactive-track-buffer)))
-;; => (reg-layer) ; 缓冲区现已为 reg-layer 注册
-```
+signal 在被读取时记录真正依赖它的 binding。修改一个 signal 只会使它的订阅者失效；条件分支改变后，不再读取的 source 会自动取消订阅。相等写入是 no-op，`tp-with-transaction` 内的重复写入会让每个受影响 binding 最多重算一次。
-#### `tp-gc-anonymous-layers` - 回收未使用的匿名层
+`tp-watch` 返回底层 surface handle，可以交给 `tp-surface-inspect`、`tp-surface-report` 或 `tp-surface-unmount`。
-```elisp
-(tp-gc-anonymous-layers) ; interactive
-```
+## Retained content
-[匿名响应式层](#匿名响应式层)是被驻留（intern）的：`equal` 相同的属性
-规格会复用其注册表条目，而不是在每次 `tp-set` 时铸造一个新层。
-`tp-gc-anonymous-layers` 取消定义所有已无注册的存活缓冲区仍在展示的驻
-留匿名层（被埋住和被隐藏的层都算作存活），并返回被回收的层名：
+retained producer 接收 prepare context，在生成输出前取得稳定 object、安装 object-local binding，并返回纯 surface plan：
```elisp
-(defvar tmp-color "green")
-(let ((buf (generate-new-buffer "*gc-demo*")))
- (with-current-buffer buf
- (insert "Hello")
- (tp-set 1 6 '(face (:foreground $tmp-color)))) ; 匿名层
- (kill-buffer buf)
- (tp-gc-anonymous-layers))
-;; => (tp-anon-1) ; 被回收的层名（计数器数字会变化）
+(let* ((status (tp-signal-create "ready"))
+ (producer
+ (lambda (context)
+ (let* ((object (tp-object-ensure context nil 'status 'text))
+ (binding
+ (tp-bind object '(demo . status)
+ (lambda () (tp-signal-read status)))))
+ (tp-surface-plan-create
+ :key 'status
+ :kind 'text
+ :text (tp-binding-read binding)
+ :props '(face bold)
+ :capability 'content))))
+ (buffer (get-buffer-create "*tp-retained*"))
+ (surface
+ (tp-surface-mount buffer producer '(:capability content))))
+ (tp-signal-set status "done")
+ (tp-surface-report surface))
```
-**保守的 `unknown` 语义：**注册表状态为 `unknown` 的层 —— 从未通过任
-何注册路径出现在任何缓冲区中，例如只被游离字符串引用 —— 会被刻意
-**保留**。一个层只有在至少为一个缓冲区注册过、且所有已注册的缓冲区都不再
-展示它（例如全部被杀死）之后才可回收。在插入带属性的字符串后请调用
-`tp-reactive-track-buffer`，让它们所在的缓冲区也被注册。
+plan 字段只有 `key`、`kind`、`text`、`props`、`children`、`tags` 和 `capability`，不包含 marker、buffer position、patch operation、producer closure 或 client continuation。constructor 会防御性复制调用者持有的 string 和 property data。
-#### 最小差异的 `tp-text` 重渲染
+稳定身份只在一个 surface 内有效。`tp-object-ensure` 按 parent、sibling key 和 kind reconcile；`tp-object-resolve` 按 key path 返回 live opaque handle。`tp-surface-update-scoped` 接收完整 candidate，但只授权一个或多个 retained object 当前 mount 范围内的输出变化；除非调用者显式选择 root fallback，否则越界变化会直接失败。
-响应式 `tp-text` 替换只编辑新旧文本的**差异区段**（先插入后删除），因
-此位于未变化文本中的 point 和标记保持原位；位于被编辑区段内的 point
-落在编辑起点。值完全相同的更新是真正的空操作：不编辑文本、不搅动属
-性，也不触碰缓冲区的修改标志。
-
-```elisp
-(progn
- (tp-layer-reset)
- (defvar 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))) ; 标记在 "items" 的 "i" 上
- (setq counter-val "9") ; 只有数字被编辑
- (list (buffer-substring-no-properties 1 (point-max))
- (char-after m)))))
-;; => ("count: 9 items" ?i) ; 标记仍指向它原来的字符
+`tp-surface-materialize-string` 使用相同 producer/plan 语义生成一次性 string，但不建立 live surface。返回前会释放 ephemeral object、binding、subscription 和 anchor。
-;; 值相同的更新完全不触碰缓冲区
-(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))
-;; => nil
-```
+## Host range 与属性所有权
-### 调试模式
+`properties` capability 使用 opaque range anchor。producer 通过 `tp-range-anchor-create` 创建 anchor，再用 `tp-object-attach-range` 挂到 object 上。marker 跟随 host edit，而 plan 仍然不携带位置。
-tp.el 提供调试模式来帮助理解响应式更新流程：
+TP 为每个 property interval 保存 host baseline 和各个 TP contribution。重叠 contribution 通过已注册的 property policy 合成。如果外部代码在 TP publication 后修改同名属性，下一次更新会报告 `tp-property-conflict`，不会覆盖外部值。`tp-range-rebase` 显式接受当前 host 值作为新 baseline。unmount 只恢复仍由 TP 拥有的值，并保留冲突的 host edit。
-```elisp
-;; 启用调试模式
-(setq tp-debug-mode t)
+## 事务与失败语义
-;; 同时在 minibuffer 显示调试信息（可选）
-(setq tp-debug-echo t)
+`tp-with-transaction` 批量处理 signal writes 和所有实际受影响的 surfaces。TP 先 prepare 所有 candidate，再按稳定顺序 publish。compute、validation、buffer write、marker/index publication 或 transaction participant 任一步失败，signal values、binding values/dependencies、文本、属性、marker、index、plan、client state、revision 和 previous report 都会一起恢复。
-;; 查看调试日志
-(tp-debug-show)
+observer 只在成功提交之后运行，observer failure 只记录，不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡，rollback 不会把它重新创建。
-;; 清除调试日志
-(tp-debug-clear)
-```
+## Property policy
-调试日志包含：
-- 变量变化通知（旧值 → 新值）
-- 层更新追踪
-- 批量更新开始/结束
-- 转换应用信息
+`tp-define-property-policy` 为一个最终 Emacs text property 注册通用语义：
-调试输出示例：
-```
-[12:34:56.789] Variable my-color changed: "red" -> "blue" (where: global)
-[12:34:56.790] Updating layer test-layer (tp-text affected: no)
-```
+- normalization 与 validation；
+- no-op 判断使用的 equality；
+- contribution merge；
+- 到最终 property value 的 projection；
+- 包括 present `nil` 在内的显式 presence。
-### 重置响应式状态
+`tp-register-text-property` 为原生 property 建立默认 policy。`face` contribution 使用 merge 语义，其他属性使用各自注册的 policy。`tp-merge-declarations`、`tp-define-style` 和 `tp-style-declarations` 只处理 direct declarations，不实现 CSS cascade。
-清除所有响应式依赖和监听器：
+## 公共 runtime API 家族
-```elisp
-(tp-reactive-reset) ;; 仅清除响应式状态
+| 家族 | 主要公共 API |
+| --- | --- |
+| Property policy 与 declaration | `tp-define-property-policy`, `tp-register-text-property`, `tp-text-declarations`, `tp-computed`, `tp-resolve-value`, `tp-merge-declarations`, `tp-define-style`, `tp-style-declarations` |
+| Signal 与 binding | `tp-signal-create`, `tp-signal-read`, `tp-signal-peek`, `tp-signal-set`, `tp-bind`, `tp-binding-read`, `tp-with-transaction`, `tp-reactive-counters` |
+| Object 与 plan | `tp-object-ensure`, `tp-object-retain`, `tp-object-attach-fragment`, `tp-object-resolve`, `tp-object-mounts`, `tp-surface-plan-create`, `tp-surface-result-create` |
+| Host range | `tp-range-anchor-create`, `tp-object-attach-range`, `tp-range-rebase` |
+| Surface | `tp-surface-materialize-string`, `tp-surface-mount`, `tp-surface-update`, `tp-surface-update-scoped`, `tp-surface-unmount`, `tp-surface-at-point`, `tp-surface-report`, `tp-surface-inspect` |
+| Direct façade | `tp-propertize`, `tp-apply`, `tp-watch`, `tp-set`, `tp-reset`, `tp-add`, `tp-remove`, `tp-clear`, `tp-get`, `tp-at`, `tp-member` |
-(tp-layer-reset) ;; 清除层、组以及响应式状态
-```
+ownership、生命周期、错误和返回值合同见 [API semantics](docs/API-SEMANTICS.md)，模块边界和完整事务流程见 [architecture](docs/ARCHITECTURE.md)。
-### 完整示例：主题感知文本
+## TP 1.0 迁移
-```elisp
-;; 定义主题变量
-(defvar theme-fg "white")
-(defvar theme-bg "black")
-(defvar theme-accent "cyan")
+TP 1.0 直接删除 0.3 的 managed stack/renderer runtime，不使用隐藏兼容分支。删除的行为包括 `tp-render.el`、`tp-stack.el`、stack mutation APIs、`tp-text`、`$variable` declarations、layer-to-buffer registry、scan-driven refresh、managed attach/detach/diagnostics，以及以 `tp-name`/`tp-layers`/`tp-meta` 作为权威 runtime storage 的机制。
-;; 定义主题感知层 - 每个层都引用主题变量
-(define-tp code-text ()
- :props '(face (:foreground $theme-fg :background $theme-bg)))
+可复用静态声明使用 direct recipe；已有文本的响应式属性使用 `tp-watch`；响应式文字或结构化 UI 使用 retained content surface。TP 不会自动扫描历史 propertized text 来重建 runtime identity。
-(define-tp code-keyword ()
- :props '(face (:foreground $theme-accent :weight bold)))
+## 示例
-;; 将层应用到当前缓冲区中的代码
-(tp-set (point-min) (point-max) 'code-text)
-(tp-match-set '("defun" "defvar" "let" "if" "when") 'code-keyword)
+- [静态属性](examples/static-properties.el)
+- [响应式状态](examples/reactive-status.el)
+- [Retained dashboard](examples/retained-dashboard.el)
+- [诊断装饰](examples/diagnostic-decoration.el)
-;; 切换到浅色主题 - 只需改变变量！
-(defun switch-to-light-theme ()
- (interactive)
- (setq theme-fg "black")
- (setq theme-bg "white")
- (setq theme-accent "blue"))
+这些示例只调用 TP public API，并在没有 Ebox 或 ECSS load-path 的环境中测试。
-;; 切换到深色主题
-(defun switch-to-dark-theme ()
- (interactive)
- (setq theme-fg "white")
- (setq theme-bg "black")
- (setq theme-accent "cyan"))
+## 验证
-;; 调用 `switch-to-light-theme' 后，关键字变为蓝色，其余代码变为
-;; 白底黑字 - 每个区域都会自动重新渲染
+```sh
+make test
+make test-shuffled SHUFFLE_SEED=20260806
+make doctest
+make compile-all WERROR=t
+make checkdoc
+make package-lint
+make diff-check
```
----
+结构测试还会证明：正常 signal/surface update 不扫描 `buffer-list`，不从显示文本搜索 identity；相等结果不会发布新 revision；unmount/kill cleanup 会释放 subscriptions 和 marker-backed runtime state。
## 许可证
-本项目采用 GNU 通用公共许可证 v3 或更高版本（`GPL-3.0-or-later`）发布。
-[LICENSE](LICENSE) 包含完整的 GPLv3 条款。
-
----
-
-## 贡献
-
-欢迎贡献！请随时提交 issues 或 pull requests。
-
----
-
-
- tp.el - 让文本属性变得强大且易用
-
+GPL-3.0-or-later，详见 [LICENSE](LICENSE)。
diff --git a/docs/API-SEMANTICS.md b/docs/API-SEMANTICS.md
index 8e99b81..4992ba8 100644
--- a/docs/API-SEMANTICS.md
+++ b/docs/API-SEMANTICS.md
@@ -1,215 +1,227 @@
-# tp API 语义规范
+# TP 1.0 API Semantics
-本文档是 tp 核心 API 的当前行为契约。代码、测试、README 与 docstring 若与本文冲突，应以经过测试的代码为准并同步修正文档。
+本文记录 TP 1.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为；目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
-tp 当前定位是 **Emacs 文本属性的高层操作工具箱，以及一套受管理的命名层、层栈和响应式渲染模型**。它尚不是全部原生文本/字符属性语义的等价替代品；完整范围与路线见 [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。
+## 1. 产品边界
-TP 1.0 迁移的第一层纯计算合同已经落地在 `tp-style.el`：namespaced property schema、结构化 selector、确定性 cascade、逐属性继承、custom property、显式 `tp-computed` 和 Emacs 属性投影已经是当前 public behavior；retained object/surface/mount/transaction 尚未切换，仍以目标架构文档描述为未来合同。
+TP 负责最终 Emacs text property policy/contribution、signals/bindings、stable objects、marker-backed mounts、surface diff、transaction、rollback 和 Buffer publication。
-Stage 2 canonical façade 已完成为内部模型：`tp--native-range`、`tp--presence`、`tp--request`、`tp--match`、`tp--result` 是模块间传递的规范记录。公开入口和历史返回值保持兼容，不因内部模型收敛而改变。
+TP 不实现 selector、stylesheet、specificity、origin/importance、CSS cascade layers、CSS-wide values、custom properties 或 Box/Flex/Grid。需要 CSS cascade 的调用者先通过独立 ECSS 获得 final declarations，再交给 TP。
-Stage 3 text-only 原生语义 façade 已完成：direct/effective/source-aware lookup、property change/any/not-all 与三种 mutation policy 组合均有明确公开边界。
+## 2. 普通值、显式 nil 与 computed source
-Stage 4 managed lifecycle 已完成：managed metadata、attach/detach、diagnostics、transaction、参数化 mounted layer args/version refresh 与 theme generation diagnostics 均有公开边界。
+普通 Elisp value 始终是 literal，包括 function object、keymap command、`help-echo` callback 和 list。TP 不会因为一个值可调用就执行它。
-Stage 5 overlay-aware 字符属性查询已完成：`tp-lookup :char` / `:char-source` 报告 Emacs 选出的字符属性值、overlay 来源和获胜 overlay 身份。overlay 创建、移动、删除、priority 管理和生命周期不属于 tp 契约。
+需要求值的 declaration 必须显式使用：
-## 1. 对象、范围与坐标
+```elisp
+(tp-computed (lambda () ...))
+```
-- 所有范围均采用半开区间 `[START, END)`。
-- 字符串使用 Emacs 原生的 0-based 坐标，合法边界为 `0` 到 `(length STRING)`。
-- 缓冲区使用 Emacs 原生位置，通常从 `point-min` 开始；显式 BUFFER 和 nil（当前缓冲区）具有相同语义。
-- 范围结果原则上使用目标对象的原生坐标。当前公开兼容例外是 `tp-intervals` / `tp-intervals-map`：缓冲区默认返回相对 START 的 offset，传入 `ABSOLUTE` 才返回可直接回传给写 API 的原生坐标。内部 canonical range 使用原生坐标，但该 relative 默认作为历史兼容例外保留。
+`tp-resolve-value` 只执行这种 tagged source。compute result 只 normalize/project 一次，不会被隐式二次调用。compute error 直接终止 candidate transaction。
-## 2. 修改策略
+TP 严格区分：
-| 调用族 | 字符串 | 缓冲区 |
-| --- | --- | --- |
-| `tp-set` / `tp-reset` / `tp-add` / `tp-remove` 整串形式 | 复制后返回新字符串 | 不适用 |
-| 上述函数的 START/END 形式 | 原地修改显式字符串 OBJECT | 原地修改 |
-| `tp-match-*` / `tp-regexp-*` | 返回新字符串 | 原地修改，返回匹配范围 |
-| 层栈修改函数 | 原地修改字符串 | 原地修改 |
-| `tp-forward-do` / `tp-backward-do` / `tp-search-map` | 原地修改；替换文本必须等长 | 原地修改；替换文本可增减长度 |
+- absent：property plist 中没有该 key；
+- present nil：property key 存在，value 为 `nil`。
-普通缓冲区写入使用 Emacs 的属性修改原语，因此遵循 Emacs 的 modified、undo 和 read-only 行为；tp 不把所有修改默认包装为 silent modification。响应式重渲染和 `tp-text` 文本替换为了恢复受管理输出会在内部允许修改 read-only 文本，这是当前实现边界，不代表公开 API 已提供统一的 read-only 策略。相同值刷新会尽量避免无意义地翻转 buffer-modified 状态。
+`tp-member` 和底层 contribution ledger 使用 presence-aware 语义。properties mount 的显式 nil contribution 可以覆盖 baseline，但 unmount 仍只撤销 TP 自己拥有的 contribution。
-## 3. presence、nil 与 wildcard
+## 3. Property policy 与 direct declarations
-以下三种状态必须区分：
+`tp-define-property-policy` 为一个 canonical native property id 注册：
-1. 属性键不存在；
-2. 属性键存在，值为 nil；
-3. 属性键存在，值为非 nil。
+- normalizer；
+- validator；
+- equality；
+- merge；
+- projector。
-`tp-member` 用于判断直接属性键是否存在；`tp-at` / `plist-get` 单独使用时不能区分前两种状态。删除最后一个子属性会移除空的父属性键，不会偶然留下 `(PROPERTY nil)`。
+注册是原子的：无效 options 或 function 会报 `tp-invalid-property-policy`，旧 definition 保持不变。
-搜索 API 的规则是：
+`tp-register-text-property` 为原生 Emacs property 建立默认 policy，并返回 policy record。`tp-text-property-id` 把原生 property 映射到 canonical `text/PROPERTY` id；`tp-text-declarations` 把普通 property plist 转换为 canonical declarations。
-- 省略 VALUE：匹配该直接属性的任意已存在值；
-- 显式传入 nil：只匹配“键存在且值为 nil”；
-- 需要继续提供 OBJECT、次数或范围等后续位置参数时，传入公共唯一哨兵 `tp-any-value` 表示任意值；
-- 自定义 PREDICATE 总是优先执行，并接收请求 VALUE（可能是 `tp-any-value`）和实际属性值。
+`tp-merge-declarations` 按输入顺序合并 direct declaration groups，并防御性复制 caller-owned value。它只做 TP contribution composition，不实现 CSS winner selection。
-属性缺失的范围不属于搜索结果，即使搜索值是 nil。
+`tp-define-style`、`tp-style-declarations` 和 `tp-undefine-style` 管理 named direct declarations。registry getter 返回防御性副本。
-## 4. 搜索结果
+## 4. Declaration recipes
-- `tp-search` 对字符串和缓冲区范围都返回 `(START END VALUE)` 列表。
-- `tp-forward` / `tp-backward` 的字符串路径返回前/后 N 个 `(START END VALUE)`；缓冲区路径移动 point，并返回第 N 次搜索的 `prop-match`。
-- `tp-forward-do` / `tp-backward-do` 只在第 N 个匹配上调用函数；匹配不足 N 个时不调用函数，返回实际找到的数量。
-- `tp-search-map` 处理全部匹配并返回处理数量。
+`define-tp` 定义一个返回 native property plist 的 recipe；`define-tps` 定义一组有序 recipe elements。`tp-define-layer`、`define-tp-group` 与 `tp-define-group` 是同一静态 declaration workflow 的命名入口。
-`tp-forward` / `tp-backward` 的对象相关结果差异是现存公开兼容契约。内部搜索路径已收敛到 canonical match/result 记录；公开返回结构暂不改变。
+Recipe 可以是静态或参数化的，可以组合其他 recipes。展开结果经过同一 direct property policy/projector。Recipe application 不建立 live identity，不写 `tp-name`、`tp-layers` 或 `tp-meta`。
-## 5. 原生文本查询与修改策略
+旧 `$variable` syntax 会报 `tp-invalid-layer-definition`。响应式值必须使用 `tp-computed` 加 signal/binding，不能建立第二套 watcher runtime。
-Stage 3/5 查询 façade 已完成：text modes 保持 text-only，char modes 委托 Emacs 的 overlay-aware 字符属性查询。
+Recipe/group definition 与 redefinition 是原子的：definition body、generated named elements 或 compiled style 任一步失败时，不留下半个新 definition，已有 definition 保持可用。
-`tp-lookup` 返回 `tp-lookup-result` 记录，字段为 property、value、present-p、source、mode、object、position、overlay。text modes 中 overlay 始终为 nil；`:char` / `:char-source` 中 overlay 为 Emacs 选出的获胜 overlay，若文本 fallback 获胜则为 nil。
+## 5. 一次性 façade
-| MODE | 语义 |
+### 5.1 `tp-propertize`
+
+```elisp
+(tp-propertize STRING DECLARATIONS)
+```
+
+返回新的 propertized string，不修改输入 STRING，不创建 object、binding、anchor、mount 或 surface。
+
+### 5.2 `tp-apply`
+
+```elisp
+(tp-apply BUFFER START END DECLARATIONS)
+```
+
+只修改 BUFFER 的 `[START, END)` 文本属性，不替换文字，成功返回 `(START . END)`。无效 buffer 不会退回 current buffer；无效 range 直接报错。
+
+### 5.3 Direct operations
+
+`tp-set`、`tp-reset`、`tp-add`、`tp-remove`、`tp-clear`、`tp-get`、`tp-at` 与 `tp-member` 保留既有 string/buffer 调用形状，但统一经过 direct property resolution。
+
+- whole-string `tp-set`/`tp-reset`/`tp-add` 返回新 string；
+- 带 range 的 string 操作按各函数 docstring 的 mutation contract 执行；
+- buffer 坐标使用 Emacs 原生 1-based position；
+- string 坐标使用 0-based index；
+- direct buffer write 遵循 Emacs read-only、undo 和 modified semantics。
+
+Search/match/regexp/navigation/query API 继续委托 Emacs 原生 text-property interval 语义，不创建 retained runtime。
+
+## 6. Signals 与 bindings
+
+`tp-signal-create` 返回 global 或 buffer-scoped signal。`tp-signal-read` 在当前 binding computation 中登记依赖；`tp-signal-peek` 只读值而不登记依赖；`tp-signal-set` 在 transaction 中设置 candidate value。
+
+相等写入按 signal equality 返回 no-op，不 invalidates subscribers。buffer-scoped signal 随 buffer kill 自动 dispose；global signal 使用 `tp-signal-dispose` 显式释放。
+
+`tp-bind` 的 identity 是 owner 加 caller-namespaced key。相同 owner/key 幂等复用 binding。binding 保存 last successful value、dynamic dependencies、dirty/revision state 和 lifecycle policy。
+
+`tp-binding-read` 读取 memoized binding value并登记 binding-to-binding dependency。每次 recompute 成功后，本次实际读取集合替换旧 dependencies；条件分支因此自动断开旧 source。cycle 报 `tp-binding-cycle` 并包含 dependency path。
+
+删除 owner 会释放 bindings、subscriptions 和下游 edges。`tp-reactive-counters` 只读报告 invalidated、recomputed、skipped、subscription-added 和 subscription-removed，用于结构性性能验收，不暴露内部 hash tables。
+
+## 7. Surface plan 与 object identity
+
+`tp-surface-plan-create` 的公共字段是：
+
+| Field | Contract |
| --- | --- |
-| `:text-direct` | 只读取直接文本属性；显式 nil 与缺失通过 present-p/source 区分 |
-| `:text-effective` | 值使用 `get-text-property`；source 使用 text-only 来源解释 |
-| `:text-source` | 返回 direct/category/alias/default/absent 来源和值，不查看 overlay |
-| `:char` | 使用 `get-char-property-and-overlay` 的值，按 Emacs overlay/text 优先级解析 |
-| `:char-source` | 同 `:char`，并在 overlay 获胜时把 source 设为 `:overlay`、overlay 设为获胜 overlay |
+| `key` | sibling-local stable key；同一 parent 下不可重复 |
+| `kind` | opaque comparable discriminator |
+| `text` | optional plain/propertized string leaf |
+| `props` | final direct Emacs properties |
+| `children` | ordered child plans |
+| `tags` | opaque indexed metadata，TP 不解释其业务含义 |
+| `capability` | `content` 或 `properties` |
-source 取值为 `:text-direct`、`:category`、`:alias`、`:default`、`:overlay` 或 `:absent`。direct 显式 nil 的结果是 present-p 为 t、value 为 nil、source 为 `:text-direct`；alias nil 与 Emacs 原生语义一致，会继续寻找后续 alias/default；缺失属性的结果是 present-p 为 nil、value 为 nil、source 为 `:absent`。
+Plan 不允许 marker、buffer position、patch op、producer closure 或 binding closure。Constructor 防御性复制 string、props、children 与 tags，使 caller 后续 mutation 不改变 committed plan。
-`tp-property-change` 是 Emacs property change 原语的显式封装：`:direction :next` / `:previous` 选择 next/previous，传入 `:property` 时使用 single-property change，省略时使用 all-property change。
+producer 在 prepare 阶段接收 context，并在产生 plan 前调用：
-`tp-property-any` / `tp-property-not-all` 是 `text-property-any` / `text-property-not-all` 的薄封装，保留 Emacs 对显式 nil、边界和对象的行为。
+```elisp
+(tp-object-ensure CONTEXT PARENT KEY KIND)
+```
-`tp-with-mutation-policy` 只接受三种有效组合：
+Object identity 只在所属 surface 中有效。显式 key 按 parent/key/kind reconcile；unkeyed object 按 position/kind reconcile。duplicate sibling key、stale parent、orphan object 或 cross-surface handle 在 prepare 中失败。
-| POLICY | 语义 |
-| --- | --- |
-| `(:modified :ordinary :read-only :respect)` | 普通修改，尊重 read-only |
-| `(:modified :ordinary :read-only :inhibit)` | 绑定 `inhibit-read-only`，普通 modified/undo 行为 |
-| `(:modified :silent :read-only :inhibit)` | 绑定 `inhibit-read-only` 并使用 `with-silent-modifications` |
+Candidate object 只有成功 publication 后才变为 live。失败 candidate handle 必须不可解析。`tp-object-resolve` 按 surface/key path 查询 live handle，不创建 identity。
-`(:modified :silent :read-only :respect)` 明确拒绝，因为 silent modification 与尊重 read-only 不能同时满足。
+无可见字符但需要保留的 logical object 使用 `tp-object-retain`。一个 logical object 可以通过 `tp-object-attach-fragment` 关联多个离散 plan fragments；attachment 保存在 prepare side state，不进入 plan。
-insert、copy、yank、stickiness、narrowing 和 indirect buffer 行为直接委托 Emacs；tp 不为这些原生操作提供 wrapper。
+## 8. Surface lifecycle
-## 6. 直接模板展开与 managed mount
+### 8.1 Materialize
-层名有两种不同用途：
+```elisp
+(tp-surface-materialize-string PLAN-OR-PRODUCER)
+```
-### 6.1 直接模板展开
+以 ephemeral prepare context 生成 propertized string，不建立 live surface。函数返回前释放 candidate objects、bindings、subscriptions 和 anchors。
-把非响应式层名传给 `tp-set`、`tp-reset`、`tp-add`、`tp-match-*` 或 `tp-regexp-*` 时，层定义展开为普通属性，通常不保留 `tp-name`。结果不能依赖层名进行后续移动、隐藏、按名删除或静态重定义刷新。
+### 8.2 Mount/update
-匿名响应式属性和响应式层需要保留 `tp-name` 才能登记与刷新，这是直接路径中的受管理例外。
+```elisp
+(tp-surface-mount BUFFER PLAN-OR-PRODUCER OPTIONS)
+(tp-surface-update SURFACE PLAN-OR-PRODUCER)
+(tp-surface-update-scoped SURFACE OBJECTS PLAN-OR-PRODUCER OPTIONS)
+```
-### 6.2 managed mount
+Mount options 支持 `:capability`、`:start`、`:end`、`:inhibit-read-only`、`:client-state` 和 `:observers`。
-`tp-push-layer` / `tp-put-layer` 明确保留 `tp-name` 和必要的 `tp-layers` 状态。mounted layer 可以被查询、移动、隐藏、显示、删除和响应式刷新。
+`content` surface 拥有其 span 的 text 和 properties，可以插入、删除、替换或移动输出。`properties` surface 只能贡献声明的 properties，不能替换 host text。
-非参数化层重新定义后，已挂载区域按 old/new 所有权协调：
+`tp-surface-update-scoped` 仍接收完整 candidate。TP 从 object-to-mount index 得到授权范围，验证 candidate 没有改变范围外输出，再在同一 transaction 发布。默认 mismatch 报 `tp-scope-mismatch`；`(:on-mismatch root)` 显式允许 full-root fallback。
-- 新定义写入其拥有的键；
-- 旧定义拥有、但新定义不再拥有的键，仅在当前值仍等于旧值时移除；
-- 外部已经改写的值不会被当作旧层残留删除。
+相等 candidate 不产生 publication，surface revision 和 buffer modified state 保持不变。
-所有 managed mount 都携带 lifecycle metadata。即使只有单个 managed layer，只要存在 `tp-meta`，权威存储也使用 `tp-layers`；直接渲染属性和 `tp-layer-stack-at` 等 public stack query 不暴露 `tp-meta`。
+### 8.3 Unmount
-参数化层的已挂载 entry 保存调用实参、形参表和 definition version；重新定义参数化层后，既有 managed entry 会按保存的 args 刷新。历史无 metadata 的 entry 按 legacy entry 保守处理。
+`tp-surface-unmount` 释放 surface、objects、bindings、mounts、markers、subscriptions、indexes 和 opaque client state，并返回 generic report。content surface 删除自己拥有的 span；properties surface 只撤销仍由 TP 拥有的 contributions。
-`tp-attach-managed-layers` 扫描已经进入缓冲区的 managed storage，补齐/规范化 metadata，登记发现的层，并返回层名列表。`tp-detach-managed-layers` 移除 managed storage；KEEP-RENDERED 非 nil 时保留当前可见渲染属性为普通文本属性。
+kill-buffer cleanup 以 buffer 死亡为权威结果，释放 runtime state，不尝试复活 buffer。
-`tp-managed-layer-diagnostics`、`tp-managed-buffer-diagnostics` 和 `tp-managed-diagnostics` 是只读诊断入口，报告 entries、args、registry、errors 与 theme diagnostics。`tp-managed-diagnostics` 的 theme 部分报告 generation、last hook source、refresh mode、refreshed ranges 和 errors；这是 lifecycle 诊断，不是性能基准。
+## 9. Range anchors 与 property conflicts
-`tp-layer-transaction` 在给定范围内执行 managed stack 修改。成功返回结构化 plist，其中 `:status` 为 `ok`、`:ok` 为 t，`:result` 保留 FUNCTION 的返回值；失败时恢复事务前文本/属性快照并默认发出 `tp-layer-transaction-error`，NOERROR 非 nil 时返回结构化失败 plist。
+`tp-range-anchor-create` 接受 buffer、start/end、marker insertion policy 与 `stale`/`shorten`/`remove` boundary policy，返回 opaque handle。raw marker 和 position 不进入 surface plan。
-## 7. `tp-text` 替换
+producer 使用 `tp-object-attach-range` 把 object 绑定到 anchor。一个 properties surface 的重叠 mounts 通过 property policy 合成 contributions。
-- 初次应用和响应式更新都按内嵌字符串的真实属性 interval 处理，不从位置 0 采样后扩散到整段。
-- 调用者显式属性覆盖内嵌属性；显式 nil 也是有效覆盖值。
-- 未被调用者覆盖的内嵌属性按各自 interval 保留。
-- 每个 interval 算出待写属性后，`tp-set` 只覆盖这些键并保留其他目标属性，`tp-reset` 替换目标的完整属性集合，`tp-add` 则对目标已有的 face-family 与嵌套 plist 继续合并；文本内容相同和发生替换时遵守同一规则。
-- 字符串和缓冲区路径遵守相同的 per-interval 属性计算；对象的复制/原地策略仍按第 2 节执行。
+TP 为每个 interval 保存：
-## 8. 错误边界
+- host baseline presence/value；
+- ordered TP contributions；
+- last published presence/value。
-- 未定义或无法解析的层使用 `tp-unresolved-layer` 表达。
-- 栈 API 的 NOERROR 只抑制 `tp-unresolved-layer`；参数化层 body、计算、属性结构和其他内部错误必须传播。
-- 隐藏层存储发生所有权冲突时使用 `tp-layer-conflict`。
-- transform 失败或返回非字符串、compute 失败都属于业务输出失败，必须传播。
-- watcher 属于 observer：单个 watcher 失败不会阻断 managed update；失败会记录到 `tp-reactive-observer-errors`（newest first）并输出消息。
-- 公开边界不应把内部失败转换为默认值后继续写入。
+如果当前 host value 与 TP last published value 不同，update 报 `tp-property-conflict`，不会覆盖外部值。`tp-range-rebase` 显式把当前 host state 接受为新 baseline。Unmount 只在当前值仍等于 last published value 时恢复 baseline，否则保留 host value并在 report 中列出 conflict。
-## 9. 隐藏层与外部直接修改
+## 10. `tp-watch`
-存在隐藏层时，`tp-layers` 保存完整 managed stack，其他直接属性是第一个可见层的渲染缓存。两类调用采用不同但明确的策略：
+```elisp
+(tp-watch BUFFER START END COMPUTE)
+```
-- definition/reactive refresh 知道正在刷新哪个定义，也知道直接属性对应哪个可见 entry；它先把原生直接编辑协调进该可见 entry，再执行 old/new 所有权刷新，因此外部改写值不会被当作旧定义残留删除；
-- 普通 stack decode/write 缺少这次 definition refresh 的所有权上下文，缓存不一致时会在写入前发出 `tp-layer-conflict`，且不修改层栈；
-- 所有层都隐藏时没有可接收直接属性的可见 entry，此时出现直接属性始终发出 `tp-layer-conflict`。
+`COMPUTE` 返回 native direct declarations。`tp-watch` 组合 range anchor、properties surface、stable object 和 binding，返回 underlying surface handle。COMPUTE 中读取的 signals/bindings进入正常 dependency graph；更新与 unmount 使用同一 conflict和rollback合同。
-tp 不会把外部属性收编成新的匿名层，也不会静默覆盖它。
+## 11. Transactions
-## 10. 返回值现状
+`tp-with-transaction` 的顺序是：
-核心写 API 的返回值仍保留历史差异：
+1. 保存 candidate signal writes 并去重 dirty bindings；
+2. 为所有实际受影响 surfaces 建立 prepare contexts；
+3. 运行 binding graph 与 producers；
+4. 校验 object、plan、capability、range、conflict 与 lifecycle；
+5. 为所有 surfaces 准备 text/property operations 与 inverse journals；
+6. 按稳定 surface id publish；
+7. 原子切换 signals、bindings、plans、mount/index、client state 和 revisions；
+8. 全部成功后运行 observers。
-- buffer/region `tp-set` / `tp-reset` / `tp-add`：`(START . END)`；
-- 整串复制式写入：新字符串；
-- buffer `tp-remove` / `tp-clear`：nil；
-- stack mutator：修改的 property-run 数量；
-- `tp-put-layer` / `tp-push-layer`：显式 OBJECT 或 `(START . END)`。
+嵌套 transaction 加入最外层。一个 global signal 可以原子触达多个 buffers；任一 surface 失败时，已发布 surfaces 和 source/binding state 全部回滚。
-这些返回值是当前兼容契约。property-run 数量会受无关 interval 边界影响，不应被当成稳定业务标识。内部 request/result 模型已建立，但不会改变这些历史 public returns。
+`tp-transaction-participate` 允许 client side state 在 surfaces 发布后、source commit 前加入同一 rollback boundary。participant key 在一个 outer transaction 中必须唯一。它不是 observer；失败会回滚 transaction。Observer failure 只记录，不回滚已提交结果。
-## 11. 明确不在当前完整契约内
+## 12. Diagnostics 与 reports
-以下能力仍需设计或补齐，不能据现有 API 推断：
+`tp-surface-report` 返回最近一次成功 publication 的防御性 report；equal/no-op update 不替换 report。字段包括 transaction/surface/revision、candidate source writes、binding counters、object reconcile counts、text/property operation counts、touched characters、scope/full-root 和 failure-related slots。
-- overlay lifecycle（创建、移动、删除、priority 管理）；
-- insert/copy/yank/stickiness 的 tp wrapper 或 managed workflow；
-- mutation policy 三种组合之外的统一 read-only、silent modification、undo 策略；
-- 字符串/缓冲区完全一致的搜索结果结构；
-- observer 错误的清理、重试与汇总策略。
+`tp-surface-inspect` 返回 surface id、buffer、capability、revision、object/mount count、opaque client state 与 report。`tp-surface-at-point` 从 side index 返回 mounted objects；它不扫描显示文本寻找 identity。`tp-object-mounts` 返回 defensive numeric range/tag snapshots，不暴露 live markers。
-## 12. Schema-driven cascade
+## 13. Error ownership
-- `tp-define-property` 只接受带 namespace 的 symbol id，例如 `text/face` 或 `ebox/width`；schema replacement 在完整验证后一次写入，失败不会破坏旧 definition。
-- structured selector 原生支持 type/id/class/attribute/state、compound、descendant/child/adjacent/general sibling，以及 `:is`、`:where` 和 `:not`；`tp-selector-specificity` 与 rule matching 使用同一 AST。
-- cascade 顺序固定为 importance、origin、layer、specificity、scope proximity、source order；normal 与 important declaration 的 layer 顺序按 CSS 规则相反，unlayered normal 高于 layered normal。
-- `tp-stylesheet-create` 建立相互隔离的 rule、layer order 与 source order domain；`tp-stylesheet-add-rule :stylesheet SHEET` 只写入该实例，`tp-compute-style :rules SHEET` 只读取该实例，避免不同 consumer 通过默认全局 stylesheet 相互污染。
-- 独立 stylesheet 的生命周期归创建者所有；`tp-style-reset` 只清理 TP 的全局 schema、named style 与 default stylesheet，调用方必须用 `tp-style-reset-rules SHEET` 显式清理自己的实例。
-- `initial`、`inherit`、`unset`、`revert` 和 `revert-layer` 必须由 `tp-wide-value` 显式构造，普通同名 Elisp symbol 保持 literal。
-- 普通 function value 永远不执行；只有 `tp-computed` 包装的 function 在计算时执行一次，其返回值不二次调用。
-- `--name` custom property 默认继承；`tp-var` 支持 fallback 和 cycle invalidation。属性 schema 的 normalizer/validator 在变量与 wide value 求值后执行。
-- `tp-compute-style` 返回 `tp-computed-style`，保存 canonical values、resolved custom properties 和可选 provenance；`tp-project-style` 是把 schema projector 汇总为最终 Emacs text properties 的唯一纯投影入口。
-- 静态 `define-tp` 和静态 `define-tps` 生成层会同步编译为同名 canonical style；参数化或旧 `$var` 响应式定义不会冻结当前值为 style，待新的 signal/binding runtime 接管其动态 source。
+主要错误类型：
-## 13. Signals、bindings 与 transaction
+- property/declaration：`tp-property-error`、`tp-invalid-property-policy`、`tp-invalid-declaration`、`tp-invalid-layer-definition`、`tp-unresolved-layer`；
+- reactive：`tp-reactive-error`、`tp-invalid-signal-scope`、`tp-disposed-signal`、`tp-disposed-binding`、`tp-binding-cycle`；
+- retained surface：`tp-invalid-surface-plan`、`tp-duplicate-object-key`、`tp-invalid-prepare-context`、`tp-stale-object`、`tp-cross-surface-object`、`tp-orphan-object`、`tp-capability-error`、`tp-stale-mount`、`tp-property-conflict`、`tp-dead-surface`、`tp-invalid-range-anchor`、`tp-scope-mismatch`。
-- `tp-signal-create` 创建 global 或 buffer-scoped source；`tp-signal-read` 仅在 binding compute context 中登记依赖，`tp-signal-peek` 永不登记依赖。buffer kill 会 dispose scoped signal；global signal 可用 `tp-signal-dispose` 显式结束 lifecycle，两者都会移除 subscriptions。
-- `tp-bind` 的 identity 是 owner object identity 加 caller-namespaced key；重复安装复用同一 binding，compute definition 变化才使它 dirty。`tp-binding-read` 读取 memoized value 并建立 binding→binding edge。
-- 每次成功 compute 以本次实际读取的依赖替换旧依赖；条件分支切换后旧 signal 不再触发。binding value 经其 equality comparator 判等，相等结果不 invalidates downstream。
-- signal write 先写入 transaction-local candidate state。最外层 `tp-with-transaction` 只遍历 exact dirty closure，去重并按 binding dependency 拓扑惰性求值；compute 内嵌 write 排队稳定，不递归执行。
-- `tp-transaction-participate KEY PUBLISH ROLLBACK` 只允许在 outer transaction 内登记。所有 surface candidate 发布并切换 client state 后，participant 按登记顺序执行 `PUBLISH`；任一后续步骤失败时，已经进入 publication 的 participant 按逆序执行 `ROLLBACK`。KEY 在同一 transaction 内唯一，两个函数均不得接收参数，rollback 必须能够撤销 publish 已经开始后的部分副作用。
-- 任一 compute 或 cycle 失败会恢复 committed signal values、last successful binding values、dependencies、dirty state、owner registry 和 scheduler counters。cycle condition 携带 namespaced binding-key path。
-- `tp-variable-signal` 是 global/buffer-local Elisp variable（包括后续 `$var` compiler）的 source adapter；它只转发精确 scope 的 write，不调用 legacy layer renderer。
-- `tp-reactive-counters` 只公开 invalidated、recomputed、skipped、subscription-added、subscription-removed 五个工作量计数，不暴露 internal hash shape。
+内部 computation 不吞错或返回貌似合理的 fallback。只有用户入口和 batch test runner等外层边界负责把错误转换为展示信息。
-## 14. Retained surface、range ownership 与 publication
+## 14. 1.0 删除项
-- `tp-surface-plan-create` 只接受 key/kind/text/props/children/tags/capability 纯数据；text 与 children 互斥，同一 parent 的显式 key 不可重复，constructor 与每次 prepare 都做 defensive copy。普通 function property value 保持 literal identity，plan 不携带 marker、position、binding 或 producer closure。
-- producer 在 active prepare context 中先用 `tp-object-ensure` 取得 candidate handle，再返回 plan 或 `tp-surface-result-create`。成功 publication 才使新 handle live；失败、materialize 返回或 orphan/cross-surface validation 失败都会释放 candidate bindings、anchors 与 subscriptions。`tp-object-resolve` 只读 live key path，不创建 identity。
-- `tp-object-retain` 显式声明一个没有可见字符也应随 candidate 晋升的 logical object；未进入 plan、未 retain、也未 attachment 的 touched object 仍以 `tp-orphan-object` 拒绝。content producer 可用 `tp-object-attach-fragment` 把同一 logical object 挂到多个 plan fragment；attachment 只存在 prepare/side state，不进入 pure plan。`tp-object-mounts` 通过 object-keyed index 返回当前数值 start/end 与 opaque tags 的防御性快照，不暴露 live marker。
-- `content` capability 拥有一个 disjoint text span，使用 character common-prefix/suffix 与 direct-property run diff；外部字符编辑使其 stale。`properties` capability 不能携带 text，只能通过 `tp-object-attach-range` 写 attached anchor。host edit 位于 anchor 前方时 marker 正常移动；跨入 owned range 时按 boundary policy shorten/remove/stale。
-- `tp-surface-update-scoped` 接受同 surface 的 live object handles 和一个完整 candidate。scope 只在当前 transaction 内有效；TP 通过 object→mount index 得到授权范围，支持一个 logical object 的多个离散 mounts，并在 prepare 阶段证明 candidate 没有改变范围外输出。默认 mismatch 发出 `tp-scope-mismatch` 且零发布；只有显式 `(:on-mismatch root)` 才允许 full-root fallback。后续普通 reactive recompute 或 `tp-surface-update` 不继承这次 scope。
-- properties ledger 保存 baseline、last-published value 与 contribution anchors。prepare compare-before-write；外部 property override 触发 `tp-property-conflict` 且保持旧 revision。`tp-range-rebase` 显式接受当前 host runs 为新 baseline；unmount 只恢复仍等于 TP last-published value 的子区间，冲突子区间保持外部值并进入 report。
-- 同一 surface 的 overlapping properties contributions 按 plan order 和 native property schema merge；独立 surfaces 当前不得重叠字符 ownership。这个限制把 journal owner 保持为唯一 surface，避免两套 baseline 静默覆盖。
-- 最外层 transaction 先完成所有 producer/plan/conflict validation，再按 surface id publish，随后执行 transaction participants，最后提交 source values。multi-buffer change group 负责 text rollback，TP 的精确 property journal 覆盖 `with-silent-modifications`；失败先逆序撤销已经进入 publication 的 participants，再恢复 buffer direct properties、markers/index、objects、plan、client state、revision、bindings 与 signal values。publish 中 killed buffer 不复活，其他 surfaces 与 sources 回滚。
-- `tp-surface-report` 的字段只使用 transaction/surface/source/binding/object/text/property/conflict/observer/timing 通用词汇。observer 在成功 commit 且 publishing transaction 的动态范围退出后执行，因此 observer 中的 signal write 会开启新 transaction；observer error 只写入 report，不回滚。
+TP 1.0 删除了不能诚实映射到统一 retained runtime 的 0.3 managed behavior：
-## 15. 简单与响应式便利入口
+- `tp-render.el` 和 `tp-stack.el`；
+- stack push/pop/move/hide/show/merge/flatten workflow；
+- `tp-text` 双向内容替换；
+- `$variable` declaration syntax；
+- layer-to-buffer registry、buffer-list/identity scan refresh；
+- managed attach/detach/diagnostics/transaction；
+- 以 `tp-name`、`tp-layers`、`tp-meta` 作为字符上权威 runtime database 的机制。
-- `tp-propertize STRING DECLARATIONS` 接受 Emacs 原生 property plist，把它转换为 canonical `text/` declarations，经 schema/cascade/projector 后应用到 STRING 的防御性副本；它不建立 object、binding、anchor 或 surface。
-- `tp-apply BUFFER START END DECLARATIONS` 使用同一 projection 与现有 range mutation primitive，只修改声明过的 direct properties，保留文本和未声明 property，并返回 `(START . END)`。
-- `tp-watch BUFFER START END COMPUTE` 创建一个 properties-only surface。COMPUTE 是返回原生 property plist 的零参数函数；其 signal/binding dependencies 由 exact graph 收集。返回值就是可传给 `tp-surface-inspect`、`tp-surface-report` 和 `tp-surface-unmount` 的 opaque surface。首次 publication 失败会释放 convenience 层创建的 anchor。
+TP 不提供 hidden compatibility engine，也不根据文本是否含旧 metadata 自动切换执行语义。静态 recipe、`tp-watch` 和 retained surface 分别承担复用声明、已有文本响应式属性与 retained content 的清晰职责。
diff --git a/docs/ARCHITECTURE.md b/docs/ARCHITECTURE.md
index 468cf97..45f52b4 100644
--- a/docs/ARCHITECTURE.md
+++ b/docs/ARCHITECTURE.md
@@ -1,723 +1,230 @@
-# tp 代码架构文档
+# TP 1.0 Current Architecture
-> 未来主版本目标：TP 将重构为独立 retained/reactive text runtime，并可作为 Ebox 等高级 consumer 的通用底层执行器。TP 自身完整、可独立阅读的已批准目标见 [TP Retained/Reactive Text Runtime 目标架构](retained-runtime-target-architecture.md)（[English](retained-runtime-target-architecture-en.md)）；它不依赖 sibling Ebox checkout。本文描述当前已经落地的实现，并明确标出仍处于迁移期的旧 runtime 与 TP 1.0 功能切片。
+本文描述 TP 1.0 当前实现的模块边界、权威状态、数据流和事务模型。公共行为合同见 [API semantics](API-SEMANTICS.md)，设计背景见 [retained runtime architecture](retained-runtime-target-architecture.md)。
-本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。TP 1.0 的纯 style/cascade kernel、exact signal/binding graph 与 retained surface publication 已分别在 `tp-style.el`、`tp-reactive.el`、`tp-surface.el` 落地；旧 managed façade 尚未切换。
+## 1. 定位
-当前 API 的规范契约见 [API-SEMANTICS.md](API-SEMANTICS.md)；Emacs 原生
-文本属性覆盖范围、已确认问题与演进路线见
-[REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。
+TP 是通用 retained/reactive text runtime：
-自 0.2.0 起，原来的单文件 tp.el 已拆分为分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。0.3.0 进一步收紧了模块边界：`tp-text` 处理链下沉至 tp-ops、批量更新上收至 tp-render、层栈存储编解码与匿名层机制归位 tp-layer，钩子变量从四个减少到两个。Stage 3 新增 tp-query，承载原生文本查询/change 封装与修改策略。各变更的缘由见 [CHANGELOG.md](../CHANGELOG.md)。
-
-## 目录
-
-- [架构概述](#架构概述)
-- [模块分层](#模块分层)
- - [Canonical records 与 dataflow](#canonical-records-与-dataflow)
- - [tp-core.el：基础工具](#tp-coreel基础工具)
- - [tp-reactive.el：响应式基础设施](#tp-reactiveel响应式基础设施)
- - [tp-layer.el：层定义、解析与层栈存储](#tp-layerel层定义解析与层栈存储)
- - [tp-ops.el：核心属性操作与 tp-text 处理链](#tp-opsel核心属性操作与-tp-text-处理链)
- - [tp-search.el：模式匹配与搜索](#tp-searchel模式匹配与搜索)
- - [tp-render.el：响应式渲染引擎](#tp-renderel响应式渲染引擎)
- - [tp-stack.el：属性层栈操作](#tp-stackel属性层栈操作)
- - [tp-query.el：原生文本查询与修改策略](#tp-queryel原生文本查询与修改策略)
- - [tp-palette.el：调色板数据](#tp-paletteel调色板数据)
- - [tp-builtins.el：内置层与辅助工具](#tp-builtinsel内置层与辅助工具)
-- [钩子变量：唯一许可的反向调用](#钩子变量唯一许可的反向调用)
-- [可变状态清单](#可变状态清单)
-- [函数调用关系图](#函数调用关系图)
-- [设计原则](#设计原则)
-
----
-
-## 架构概述
-
-tp 采用严格的线性分层：**每个模块只允许 `require` 并调用排在它前面的模块**，字节编译器强制检查这一依赖顺序。加载顺序即依赖顺序：
-
-```
-tp-core → tp-style → tp-reactive → tp-layer → tp-ops → tp-search
- → tp-render → tp-stack → tp-query → tp-palette → tp-builtins
+```text
+application state
+ → signals/bindings
+ → prepare context + stable objects
+ → pure surface plan
+ → reconcile/diff
+ → atomic Buffer publication
```
-注意加载顺序是依赖顺序的**上界**：并非每个模块都依赖它前面的全部模块。各模块实际 `require` 的 tp- 模块如下（逐一核对自源码头部）：
+TP 负责文本属性 contribution、响应式依赖、身份、位置、变化和提交。调用者负责业务含义以及期望显示结果。
-| 模块 | require 的 tp- 模块 |
-|------|--------------------|
-| tp-core | —（仅 cl-lib、dash、seq） |
-| tp-style | tp-core |
-| tp-reactive | tp-core |
-| tp-layer | tp-core、tp-style、tp-reactive |
-| tp-ops | tp-core、tp-reactive、tp-layer |
-| tp-search | tp-core、tp-reactive、tp-layer、tp-ops |
-| tp-render | tp-core、tp-reactive、tp-layer、tp-ops、tp-search |
-| tp-stack | tp-core、tp-reactive、tp-layer（**不依赖 tp-ops / tp-search / tp-render**） |
-| tp-query | tp-core |
-| tp-palette | —（不依赖任何 tp- 模块，仅 subr-x） |
-| tp-builtins | tp-core、tp-layer、tp-ops、tp-palette |
+TP 不依赖 Ebox 或 ECSS，不包含 selector、stylesheet、CSS cascade、Box/Flex/Grid、measurement、layout owner 或 viewport dirty semantics。
-```
-┌────────────────────────────────────────────────────────────────┐
-│ tp.el —— 总入口，按序 require 全部模块 │
-└────────────────────────────────────────────────────────────────┘
-┌────────────────────────────────────────────────────────────────┐
-│ tp-builtins.el 内置层（tp-link, tp-space, tp-headline …）、 │
-│ tp-palette-show、显示缓冲辅助宏 │
-├────────────────────────────────────────────────────────────────┤
-│ tp-palette.el 明/暗主题调色板数据、tp-parse-color │
-│ （独立叶模块，不依赖任何 tp- 模块） │
-├────────────────────────────────────────────────────────────────┤
-│ tp-query.el 原生文本 lookup/change 封装、mutation policy │
-├────────────────────────────────────────────────────────────────┤
-│ tp-stack.el 层栈操作（push/pop/move/hide/show/merge …） │
-├────────────────────────────────────────────────────────────────┤
-│ tp-render.el 响应式重渲染引擎、最小差异 tp-text 编辑、 │
-│ 批量更新（tp-with-batch-updates + flush）──┐ │
-├─────────────────────────────────────────────────────────── │ ──┤
-│ tp-search.el tp-match-*/tp-regexp-*、tp-search、导航 │ │
-├─────────────────────────────────────────────────────────── │ ──┤
-│ tp-ops.el tp-set/reset/add/get/at/remove/clear、 │ │
-│ tp-text 处理链（0.3.0 起在此，直接调用） │ │
-├─────────────────────────────────────────────────────────── │ ──┤
-│ tp-layer.el define-tp/define-tps、层注册表与解析、 │ │
-│ 层栈存储编解码、匿名层机制与 GC │ │
-│ ◁╌╌ tp--layer-refresh-function ╌╌╌╌╌╌╌╌╌╌┤ │
-├─────────────────────────────────────────────────────────── │ ──┤
-│ tp-reactive.el 响应式依赖注册表、变量监听、批量队列、 │ │
-│ 层→缓冲区注册表 │ │
-│ ◁╌╌ tp--reactive-update-function ╌╌╌╌╌╌╌╌╌┘ │
-├────────────────────────────────────────────────────────────────┤
-│ tp-style.el property schema、structured selector、 │
-│ cascade、custom property、computed value │
-├────────────────────────────────────────────────────────────────┤
-│ tp-core.el 区间遍历、plist/face 合并引擎、 │
-│ 调试日志、$var 符号工具（无可变状态） │
-└────────────────────────────────────────────────────────────────┘
+## 2. 模块图
-实线层级：上层模块调用下层模块（require 依赖）。
-虚线（◁╌╌）：钩子变量 —— 下层模块预留的函数变量，
-由 tp-render.el 在加载时安装实现（见下文）。
+```text
+tp-core
+ ├─ tp-style
+ │ └─ tp-reactive
+ │ └─ tp-surface
+ ├─ tp-layer
+ ├─ tp-ops
+ ├─ tp-search
+ ├─ tp-query
+ ├─ tp-palette
+ └─ tp-builtins
+
+tp.el loads the public package surface
```
-需要"向上调用"的逻辑全部收拢在 `tp-render.el`（位于 `tp-search.el` 之上，可以直接调用它）。0.2.0 时这类反向调用靠四个钩子变量实现；0.3.0 把其中两个消除在了代码层面——`tp-text` 处理链整体下沉进 tp-ops（`tp-set` 等直接调用，不再需要 `tp--tp-text-handler-function`；只加载到 tp-ops 的部分加载也能得到可用的 `tp-text` 文本替换），批量刷新整体上收进 tp-render（`tp--flush-batch-updates` 直接调用 `tp--reactive-flush-entry`，不再需要 `tp--reactive-flush-function`）。剩下的两个钩子对应真正源自下层的事件：变量监听器触发（tp-reactive）与层重定义触发（tp-layer）。
-
----
-
-## 模块分层
-
-### Canonical records 与 dataflow
-
-Stage 2 canonical façade 是内部模型，不改变公开入口和历史返回值。五个记录承担模块间的规范数据边界：
-
-| 记录 | 所有者 | 用途 |
-|------|--------|------|
-| `tp--native-range` | tp-core | 目标对象的原生 `[START, END)` 范围；字符串使用 0-based，缓冲区使用原生 buffer position |
-| `tp--presence` | tp-core | 区分属性缺失、present nil、present non-nil |
-| `tp--request` | tp-ops | 公开重载参数解析后的规范请求：对象、范围、操作、属性/值/谓词、修改策略 |
-| `tp--match` | tp-search | 搜索内部匹配结果，统一字符串与缓冲区路径 |
-| `tp--result` | tp-search | 搜索内部结果载体；最终按公开 API 的历史契约适配返回 |
-
-数据流为：公开入口解析成 `tp--request`，tp-core 提供对象、native range、presence 与 adapter，tp-ops/tp-search/tp-stack 只在 I/O 边界按对象类型分支。内部搜索先产生 canonical `tp--match` / `tp--result`，再由公开入口保留旧返回结构；`tp-intervals` / `tp-intervals-map` 的缓冲区 relative 默认是显式保留的兼容例外。
-
-### tp-core.el：基础工具
-
-最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。0.3.0 起 tp-core **不再持有任何可变状态**（匿名层计数器已迁至 tp-layer；仅剩 `tp-debug-mode` / `tp-debug-echo` 两个 defcustom 用户选项）。
-
-#### 区间操作
-| 函数 | 描述 | 主要调用者 |
-|------|------|--------|
-| `tp-intervals` | 获取区域内文本属性区间列表（裁剪到 [START, END)；可选 ABSOLUTE 参数返回缓冲区原生坐标，默认仍为相对坐标） | tp-intervals-map, tp-get |
-| `tp-intervals-map` | 对区间应用函数（同样支持 ABSOLUTE） | 多个属性/层操作函数 |
-| `tp--map-intervals` | 共享的裁剪式区间遍历引擎 | tp-intervals-map, tp-ops/tp-stack 的区域操作, tp-reactive 的缓冲区扫描 |
-| `tp-plist` | 获取区域中合并后的所有属性 | 用户 API |
-| `tp-empty-p` | 检查对象是否没有文本属性 | 用户 API |
-
-#### plist / face 合并引擎
-| 函数 | 描述 | 主要调用者 |
-|------|------|--------|
-| `tp--deep-merge-plist` | 深度合并两个 plist | tp-add, tp--prepend-face 等 |
-| `tp--prepend-face` | face 家族属性的合并逻辑 | tp-add, tp-match-add |
-| `tp--merge-face-values` | 合并两个 face 值 | 合并引擎内部 |
-| `tp--merge-duplicate-keys` | 合并 plist 中的重复键 | tp--parse-args |
-| `tp--parse-face-list` | 解析 face 列表 | 合并引擎内部 |
-| `tp--get-nested` | 按路径获取嵌套属性值 | tp-get, tp-at |
-
-`tp-face-properties`（常量，`'(face font-lock-face mouse-face)`）定义参与 face 感知合并的属性家族。
-
-#### `$var` 符号工具
-| 函数 | 描述 |
-|------|------|
-| `tp--reactive-symbol-p` | 检查是否为 `$var` 响应式符号 |
-| `tp--reactive-var-symbol` | `$var` 符号转变量符号 |
-| `tp--collect-reactive-symbols` | 收集表达式中所有 `$var` 符号 |
-| `tp--resolve-reactive-symbols` | 将 `$var` 解析为当前值（支持覆盖表） |
-| `tp--extract-reactive-props` | 提取引用特定变量的属性 |
-
-#### 调试工具
-| 变量/函数 | 描述 |
-|-----------|------|
-| `tp-debug-mode` | 启用/禁用调试模式 |
-| `tp-debug-echo` | 是否在 minibuffer 显示调试信息 |
-| `tp-debug-log` | 记录调试信息 |
-| `tp-debug-show` | 显示 *tp-debug* 缓冲区 |
-| `tp-debug-clear` | 清除调试日志 |
-
-另有辅助宏 `tp-with-current-buffer`。
-
----
-
-### tp-style.el：纯 schema 与 cascade kernel
-
-只依赖 tp-core，不接触 buffer、marker、mount 或订阅。它拥有 namespaced property schema、structured subject/selector、origin/importance/layer/specificity/scope/source-order cascade、逐属性继承、tagged CSS-wide values、custom property/`tp-var`、显式 `tp-computed`、named style、provenance 和最终 Emacs property projection。默认 stylesheet 只服务便利入口；独立 consumer 使用 `tp-stylesheet-create` 持有隔离的 rule、layer 与 source-order domain。
-
-普通 function value 保持 literal；只有 `tp-computed` 才会求值一次。schema/rule 注册先完整校验再原子替换。shorthand 在进入候选集前展开一次，计算结果随后经过 variable/wide-value resolution、normalizer 和 validator。该模块提供后续 signal/binding 与 retained surface 共用的唯一 style 语义，不建立第二套 renderer。
-
----
-
-### tp-reactive.el：响应式基础设施
-
-只依赖 tp-core。文件上半部是 TP 1.0 的唯一新响应式执行语义：global/buffer-scoped signal、owner+key binding identity、dynamic dependency collection、binding→binding graph、transaction-local candidate signal values、dirty dedupe/topological lazy flush、nested write stabilization、rollback-capable transaction participant、cycle path、owner disposal、variable adapter 和 public counters。participant 在全部 surface side state 发布后、source commit 前晋升 client-owned opaque state，失败时按逆序撤销；它不解释 client state。正常新热路径只从 source subscriber set 到 dirty binding，不读取 `buffer-list`、文本上的 `tp-name`/`tp-layers` 或 layer→buffer registry。
-
-文件下半部仍暂存 0.3 façade 所需的变量→layer watcher、batch queue 和 layer→buffer registry，以保持旧测试在 retained surface 建成前可运行；它们没有被新 graph 调用，并将在最终 cutover phase 与 `tp-render.el` 扫描路径一起删除。这个暂存区不是第二套长期 public runtime。
-
-### tp-surface.el：retained publication owner
-
-该模块拥有 surface/object identity、marker-backed mount index、range anchor、properties ledger、buffer diff、publication journal 与 revision。`tp-surface-update-scoped` 复用同一完整 candidate prepare 和同一事务发布器，只把 live object handles 解析成当前事务的授权范围；它不是子树 renderer，也不接受 Ebox owner、dirty kind、layout patch 或 raw marker。范围外输出变化在 prepare 阶段拒绝，显式 root fallback 除外。
-
-只依赖 `tp-core`、`tp-style` 与 `tp-reactive`。它集中拥有 prepare context、candidate/live object identity、pure surface plan、content/properties capability、range anchor、logical object→多个 marker-backed mounts、object-keyed mount index、position→object side index、properties contribution ledger、text/property diff、multi-buffer change group、silent-property inverse journal、opaque client state、revision、generic report 和 buffer-kill lifecycle。没有可见字符的 logical object 必须显式 retain；不连续输出通过 prepare-only object→plan-fragment attachment 建立，plan 本身仍没有 handle 或 position。normal update 从 binding owner 直接取得 prepared surface，再从 object 直接取得 mounts；不读取 `buffer-list`，也不按 `tp-name`、`tp-layers` 或显示文本反查 identity。
-
-`content` mount 可以替换其拥有的 disjoint span；外部字符编辑会使 mount stale。`properties` mount 只能修改 attached anchor 上声明的 direct properties；同一 surface 内重叠 contribution 通过 native property schema 合成。外部值与 TP last-published value 不同时，prepare 报 `tp-property-conflict`，调用者必须 `tp-range-rebase` 或 unmount。独立 surfaces 的字符范围当前必须不重叠，以保持单一、可证明的 ownership journal。
-
-`tp-propertize` 与 `tp-apply` 是 `tp-style` projection 加 `tp-ops` mutation primitive 的 one-shot 组合，不创建 runtime state。`tp-watch` 只把 range anchor、object binding 和 properties surface 组合成普通用户入口；它没有独立 scheduler、diff 或 publication path。
-
-#### 依赖注册与管理
-| 函数/变量 | 描述 |
-|------|------|
-| `tp-reactive-deps` | 变量 → 依赖它的层及属性 的注册表 |
-| `tp--register-reactive-deps` | 注册响应式依赖 |
-| `tp--unregister-reactive-deps` | 取消注册依赖（含 watchers/computed/data，并移除该层的缓冲区注册表条目） |
-| `tp--layer-has-reactive-deps-p` | 层是否有响应式依赖 |
-| `tp--register-layer-watchers` / `tp--unregister-layer-watchers` | 注册/清除 `:watch` 回调 |
-| `tp--register-layer-computed` / `tp--unregister-layer-computed` | 注册/清除 `:compute` 计算属性 |
-| `tp--register-layer-data` / `tp--unregister-layer-data` | 注册/清除 `:data` 变量 |
-| `tp--apply-initial-computed` | 计算 `:compute` 的初始值 |
-| `tp--ensure-reactive-variables` | 确保 `$var` 对应的变量已定义 |
-| `tp-reactive-reset` | 重置全部响应式注册表（含批量队列与层→缓冲区注册表） |
-
-#### 层→缓冲区注册表（0.3.0）
-响应式更新不再全量扫描 `(buffer-list)`：每条会写入 `tp-name` 的缓冲区路径（tp-set 家族、栈变更函数、match/regexp 应用器）都把目标缓冲区登记到注册表，更新时只访问登记过的缓冲区。
-
-| 函数/变量 | 描述 |
-|------|------|
-| `tp--layer-buffers` | 哈希表（`:test equal`）：层名 → 展示该层的缓冲区列表。键存在但值为空表示"已知：无缓冲区展示该层"，与键不存在（`unknown`）严格区分 |
-| `tp-reactive--register-layer-buffer` | 幂等登记（公开写入口，tp-ops/tp-search/tp-stack 各自的注册助手最终都调用它）；首次使用时安装 `kill-buffer-hook` 清理器 |
-| `tp-reactive-layer-buffers` | 查询某层的已登记存活缓冲区，或返回符号 `unknown`；惰性剔除已死缓冲区 |
-| `tp-reactive--buffer-layer-names` | 栈感知的缓冲区扫描：直接 `tp-name` 与 `tp-layers` 栈存储内的层（被覆盖或被隐藏）都算在场。`tp-reactive-track-buffer` 与匿名层 GC 的存活检查共用它 |
-| `tp-reactive-track-buffer` | 交互命令：扫描缓冲区并登记其中的全部层。用于弥补"插入已带属性的字符串"绕过登记路径的已知缺口 |
-| `tp-reactive--prune-killed-buffer` / `tp-reactive--install-kill-buffer-hook` | kill-buffer 时从注册表剔除死缓冲区（条目保留为空列表，即"已知：无"） |
-
-对 `unknown` 层，tp-render 的更新走一次**学习性**全扫描并登记实际找到的缓冲区；一处都没找到的层刻意保持 `unknown`，以便之后经非登记路径（如字符串插入）出现时仍能被下次扫描发现。
-
-#### 变量监听与批量队列
-| 函数 | 描述 |
-|------|------|
-| `tp--reactive-variable-watcher` | `add-variable-watcher` 回调；调用 `:watch` 后经 `tp--reactive-update-function` 委托重渲染 |
-| `tp--invoke-layer-watchers` | 调用层的 `:watch` 回调 |
-| `tp--queue-batch-update` | 将更新加入待处理队列 `tp--batch-update-pending`（刷新在 tp-render） |
-
-钩子变量：`tp--reactive-update-function`（定义于此，由 tp-render.el 安装）。
-
----
-
-### tp-layer.el：层定义、解析与层栈存储
-
-依赖 tp-core、tp-reactive。提供 `define-tp` / `define-tps` 宏、层注册表、层名解析，以及 0.3.0 归位至此的**层栈存储编解码**与**匿名层完整生命周期**（铸造、驻留、注销、GC）。
-
-#### 层定义
-| 函数/宏 | 描述 | 依赖 |
-|---------|------|------|
-| `define-tp` | 定义单个自定义文本属性（层）；别名 `tp-define-layer` | tp--define-layer-internal |
-| `define-tps` | 定义自定义文本属性组（层组）；别名 `define-tp-group`、`tp-define-group` | tp--define-layer-group-internal |
-| `tp--define-layer-internal` | 层定义的运行时实现 | tp--parse-define-layer-args, tp--collect-reactive-symbols, tp--ensure-reactive-variables, tp--register-*, tp--layer-refresh |
-| `tp--parse-define-layer-args` | 解析 `:props` / `:data` / `:compute` / `:watch` / `:transform` | - |
-| `tp--parse-layer-group-element` | 解析层组元素 | tp--layer-group-element-format |
-| `tp--define-layer-from-parsed` | 从解析结果定义层 | （与 define-tp 类似的依赖） |
-| `tp--check-layer-cycle` | 检测循环层引用并报错 | tp--layer-expansion-stack |
-
-0.3.0 起参数化层/层组的 ARGLIST 可以声明**任意个**参数（此前仅限一个）；`(LAYER ARG1 ... ARGN)` 与包裹形式 `(LAYER (ARG1 ... ARGN))` 在 `tp-set` 与 `tp-put-layer` 规格中均可用，实参数量不匹配会报出点名该层与两个数量的清晰错误。
-
-#### 注册表与查询
-| 函数/变量 | 描述 |
-|------|------|
-| `tp-layer-alist` / `tp-layer-groups` / `tp-layer-transforms` | 层、层组、转换函数注册表 |
-| `tp--group-generated-layers` | 层组 → 其定义生成的层 的注册表（组重定义/注销时随之清理） |
-| `tp--set-layer-props` / `tp--set-group-layers` | 写入注册表 |
-| `tp-layer-props` / `tp-group-props` | 获取层/层组属性（`&optional INCLUDE-TP-NAME`，默认不含 `tp-name`；返回副本） |
-| `tp-layer-props-with-arg` / `tp-group-props-with-arg` | 单参数形式（0.3.0 起是 -with-args 的薄封装） |
-| `tp-layer-props-with-args` / `tp-group-props-with-args` | 多参数形式：ARGS 按位置绑定到层参数 |
-| `tp-layer-arglist` | 返回参数化层的形参表副本（非参数化层返回 nil） |
-| `tp-layer-parameterized-p` / `tp-group-parameterized-p` | 是否参数化 |
-| `tp-describe-layer` | 交互命令：在 help 缓冲区展示层的存储格式、形参表、原始定义体、展开属性、响应式依赖、transform 与所属层组（数据采集在 `tp--describe-layer-data`） |
-| `tp-layer-reset` | 重置层系统（连带调用 `tp-reactive-reset`；见[可变状态清单](#可变状态清单)） |
-| `tp-undefine-layer` / `tp-undefine-group` | 删除层/层组（含其响应式依赖、转换与匿名层注册表条目） |
-
-#### 属性解析
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp--resolve-props` | 解析属性（展开层名、多参数规格、`$var`、注册依赖、驻留匿名层） | tp-layer-props(-with-args), tp--collect-reactive-symbols, tp--resolve-reactive-symbols, tp--anonymous-layer-name-for, tp--register-reactive-deps |
-| `tp--expand-layer-in-plist` | 展开 plist 中的层名键 | tp--is-layer-name-p |
-
-#### 匿名层机制与 GC（0.3.0 归位/新增）
-| 函数/变量 | 描述 |
-|------|------|
-| `tp--anonymous-layer-counter` | 匿名层名计数器。**刻意不被任何 reset 清零**：脱离缓冲区的字符串可能仍携带旧的 `tp-anon-N` 属性值，计数器单调递增保证新铸名字永不与之混淆 |
-| `tp--generate-anonymous-layer-name` | 生成唯一的 `tp-anon-N` 符号 |
-| `tp--anonymous-layer-registry` | 匿名响应式层驻留表：`equal` 的 props 规格复用既有注册项 |
-| `tp--anonymous-layer-name-for` | 驻留查询/铸造入口 |
-| `tp--buffer-has-layer-region-p` | 栈感知的存活检查：直接 `tp-name` 或 `tp-layers` 内（被覆盖/被隐藏）皆算存活 |
-| `tp-gc-anonymous-layers` | 交互命令：回收已无任何已登记存活缓冲区展示的匿名层；注册表状态为 `unknown` 的层（可能仅被游离字符串引用）保守保留 |
-
-#### 层栈存储编解码
-层栈在原始文本属性上的编码/解码知识集中在这里，tp-stack（栈操作）与 tp-render（响应式写穿）都向下调用它，互不 require。
-
-| 函数 | 描述 |
-|------|------|
-| `tp--normalize-layer-spec` | 规范化层规格（含多参数 `(LAYER ARG1 ... ARGN)`） |
-| `tp--build-layer-props` / `tp--layer-stack-to-list` | 旧式编解码原语（无隐藏层语义） |
-| `tp--stack-hidden-p` | 层 plist 是否带 `tp-hidden` 标志 |
-| `tp--plist-equivalent-p` / `tp--assert-hidden-render-cache` | 普通栈解码时验证完整存储的直接渲染缓存；无刷新上下文的不一致在改写前发出 `tp-layer-conflict` |
-| `tp--stack-props-to-list` | 原始属性 → 有序层列表（顶层在前，含隐藏层）。完整存储模式下 `tp-layers` 持有完整栈，直接属性只是最顶可见层的渲染缓存，并在普通解码时执行冲突检查；definition/reactive refresh 由 tp-render 在明确可见 entry 上协调外部编辑 |
-| `tp--stack-build-props` | 有序层列表 → 原始属性。单层栈不携带 `tp-layers`；含隐藏层时切换为"完整栈 + 渲染缓存"存储模式（全部隐藏时不渲染任何层属性） |
-| `tp--get-layer-by-idx-or-name` | 通过索引或名称查找层 |
-
-钩子变量：`tp--layer-refresh-function`（定义于此，由 tp-render.el 安装为
-`tp--update-layer-regions`）；`tp--layer-refresh` 是它的调用入口，非参数化
-层重定义后把 old props 一并传给渲染层，触发已挂载区域的 old/new 所有权协调。
-
----
-
-### tp-ops.el：核心属性操作与 tp-text 处理链
-
-依赖 tp-core、tp-reactive、tp-layer。面向用户的核心属性读写函数，直接调用 Emacs 原生文本属性 API。0.3.0 起 `tp-text` 处理链从 tp-render 下沉至此，`tp-set` 等**同模块直接调用**它（不再经钩子变量）——因此只加载到 tp-ops 的部分加载也能得到可用的 `tp-text` 文本替换。
-
-#### 参数解析
-| 函数 | 描述 | 调用者 |
-|------|------|--------|
-| `tp--parse-args` | 解析灵活的调用格式（整串/区域/层名/多参数层） | tp-set, tp-reset, tp-add |
-| `tp--apply-props-to-string` | 字符串路径的属性应用 | tp-set, tp-reset, tp-add |
-| `tp--ops-register-layer-buffer` | 应用带 `tp-name` 的属性到缓冲区后，登记到层→缓冲区注册表 | tp-set, tp-reset, tp-add |
-
-#### tp-text 处理链（0.3.0 自 tp-render 迁入）
-| 函数 | 描述 |
-|------|------|
-| `tp--handle-tp-text-property` | `tp-text` 属性的总入口：初始化/替换文本、双向同步响应式变量 |
-| `tp--tp-text-replace` | 执行文本替换（缓冲区与字符串两条路径） |
-| `tp--tp-text-transform` | 应用层的 `:transform`（首次渲染同样生效） |
-| `tp--find-tp-text-reactive-var` | 找到层 `tp-text` 绑定的响应式变量 |
-| `tp--merge-embedded-props` | 合并 tp-text 字符串内嵌属性与外部属性 |
-| `tp--apply-reactive-text-props` | 把结果属性应用到替换文本（值未变的区段跳过写入，保持 buffer-modified 状态） |
-| `tp--put-text-property-unless-equal` | 仅在值确实变化时写属性 |
-
-#### 设置属性
-| 函数 | 描述 | 依赖 | 被依赖 |
-|------|------|------|--------|
-| `tp-set` | 设置文本属性（保留其他属性） | tp--parse-args, tp--handle-tp-text-property, tp--ops-register-layer-buffer | tp-match-set, 层操作 |
-| `tp-reset` | 完全替换所有文本属性 | 同上 | tp-match-reset |
-| `tp-add` | 深度合并属性 | 同上 + tp--deep-merge-plist, tp--prepend-face | tp-match-add |
-
-#### 获取属性
-| 函数 | 描述 | 依赖 | 被依赖 |
-|------|------|------|--------|
-| `tp-get` | 获取范围内的属性值（返回区间列表） | tp--get-nested | 搜索函数 |
-| `tp-at` | 获取单个位置的属性值 | tp--get-nested | 大多数高层函数 |
-| `tp-member` | 区分"属性值为 nil"与"属性不存在"（plist-member 风格） | - | 用户 API |
-
-#### 删除属性
-| 函数 | 描述 | 依赖 | 被依赖 |
-|------|------|------|--------|
-| `tp-remove` | 移除属性或子属性 | tp--remove-property, tp--remove-sub, tp--remove-*-from-string | 用户 API |
-| `tp-clear` | 清除所有属性（显式返回 nil） | - | 用户 API |
-
----
-
-### tp-search.el：模式匹配与搜索
-
-依赖 tp-core、tp-reactive、tp-layer、tp-ops（0.3.0 新增 tp-reactive 依赖：应用器写入缓冲区后经 `tp--search-register-layer-buffer` 登记层→缓冲区注册表）。提供模式匹配式属性应用、属性搜索与导航。
-
-#### 模式匹配
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp-match-set` / `tp-match-reset` / `tp-match-add` | 在字符串匹配处设置/重置/合并属性；0.3.0 起接受 START/END 界限（视同只存在该部分；颠倒的界限自动交换） | tp--match-apply |
-| `tp-regexp-set` / `tp-regexp-reset` / `tp-regexp-add` | 在正则匹配处设置/重置/合并属性；0.3.0 起额外接受 SUBEXP（属性作用于每个匹配的该捕获组；超出组数报清晰错误） | tp--regexp-apply |
-| `tp--match-apply` / `tp--regexp-apply` | 字面/正则匹配的入口（含多模式支持） | tp--pattern-apply |
-| `tp--pattern-apply` / `tp--pattern-apply-single` | 共享的模式匹配引擎（空模式/零宽模式安全；承载 START/END/SUBEXP） | tp-set/tp-reset/tp-add 风格的 apply-fn |
-| `tp--deep-merge-apply` / `tp--reset-apply` | 传给引擎的合并/重置回调（缓冲区路径顺带登记注册表） | tp--deep-merge-plist, tp--search-register-layer-buffer |
-| `tp--search-register-layer-buffer` | 登记助手，转发到 `tp-reactive--register-layer-buffer` | tp-reactive |
-
-#### 搜索和导航
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp-forward` | 向前搜索 N 次并移动点；省略 VALUE 匹配任意直接存在值，显式 nil 精确匹配 present-nil | tp--property-search-forward |
-| `tp-backward` | 向后搜索 N 次并移动点（与向前语义对称，同样新增 PREDICATE/NOT-CURRENT） | tp--property-search-backward |
-| `tp--property-search-forward` / `tp--property-search-backward` | 基于统一直接属性 run 的单步搜索引擎 | tp--property-matches |
-| `tp--property-match-p` | 谓词归一化（函数优先；否则 `tp-any-value` 通配，其他值用 `equal`） | - |
-| `tp--property-matches` | 字符串/缓冲区共用、presence-aware 的直接属性 run 收集器 | text-properties-at, next-property-change |
-| `tp-search` | 收集所有 `(START END VALUE)` 匹配区间 | tp--property-matches |
-| `tp-search-forward` / `tp-search-backward` | **已废弃（0.3.0，make-obsolete）**：裸封装原语，nil-PREDICATE 默认语义与库内 `equal` 匹配相悖；请改用 `tp-forward` / `tp-backward`，或直接用 Emacs 原语 | text-property-search-* |
-
-#### 遍历与替换
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp-forward-do` / `tp-backward-do` | 向前/向后搜索并在第 TIMES 个匹配处执行函数（同样透传 PREDICATE/NOT-CURRENT） | tp--forward-do / tp--backward-do |
-| `tp--forward-do` / `tp--backward-do` | 单方向遍历的内部实现 | tp--replace-match-text |
-| `tp-search-map` | 对所有匹配应用函数（FUNCTION 接收 TEXT &optional START END IDX） | tp--search-do |
-| `tp--search-do` | 搜索遍历的内部实现 | tp--replace-match-text |
-| `tp--replace-match-text` | 共享的匹配文本替换助手（缓冲区支持变长替换；字符串变长时报错） | - |
-
----
-
-### tp-render.el：响应式渲染引擎
-
-依赖 tp-core、tp-reactive、tp-layer、tp-ops、tp-search。这是唯一"知道"渲染如何进行的模块：它直接调用 `tp-search-map`、`tp--tp-text-transform`、`tp--apply-reactive-text-props`（后两者位于 tp-ops——这条 require 是真实的下行调用，不只是加载顺序），并在加载末尾把自己的入口函数**安装**进下层模块预留的两个钩子变量。0.3.0 起批量更新宏与刷新逻辑也位于此。
-
-#### 缓冲区遍历（0.3.0：注册表驱动）
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp--render-visit-buffer` | 单缓冲区访问接缝（测试可包裹它统计访问次数） | tp-with-current-buffer |
-| `tp--map-layer-buffers` | 在可能展示该层的缓冲区中执行更新：WHERE 为缓冲区（setq-local）时只走它；否则查注册表只访问已登记缓冲区；`unknown` 层回退为一次学习性 `(buffer-list)` 全扫描并登记实际命中的缓冲区 | tp-reactive-layer-buffers, tp--buffer-has-layer-region-p |
-
-#### 重渲染
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp--update-layer-regions` | 用 old/new 所有权协调重渲染已挂载区域，并**写穿**到 `tp-layers` 栈存储 | tp--layer-render-props, tp-search-map, tp--write-layer-through-stack-storage |
-| `tp--write-layer-through-stack-storage` | 先按旧定义移除仍由该层拥有的键，再写入新定义；被覆盖或隐藏的副本也保持最新 | tp--stack-props-to-list, tp--stack-build-props [tp-layer] |
-| `tp--reconcile-layer-props` / `tp--reconcile-layer-region` | 计算和写入 old/new 属性协调；保留不属于旧层或已被外部改写的值 | - |
-| `tp--update-layer-computed` | 更新 `:compute` 计算属性（nil 可传播；错误向上抛出） | tp--store-computed-value |
-| `tp--layer-render-props` / `tp--layer-reactive-props` | 求取层的渲染属性 | tp-layer-props |
-
-#### 响应式文本（tp-text）
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp--update-reactive-text` | 变量变化后更新响应式文本 | tp--replace-reactive-text-in-buffer, tp--map-layer-buffers |
-| `tp--replace-reactive-text-in-buffer` | 在缓冲区中替换响应式文本（0.3.0：**最小差异编辑**——修剪公共前后缀只编辑差异区段，且先插入后删除，未变文本内的点位与标记不动；文本相同的更新完全不触碰缓冲区） | tp--edit-region-minimal-diff |
-| `tp--edit-region-minimal-diff` | 最小差异编辑原语 | - |
-| `tp--pos-holds-layer-in-storage-only-p` | 某位置的层是否只存在于栈存储（隐藏/被覆盖，跳过可见文本替换） | - |
-
-#### 批量更新（0.3.0 自 tp-reactive 迁入）
-| 函数/宏 | 描述 |
-|------|------|
-| `tp-with-batch-updates` | 批量更新宏：BODY 内的多次变量修改合并为一次刷新（队列变量仍在 tp-reactive，宏向下 let 绑定它们） |
-| `tp--flush-batch-updates` | 刷新队列，按层去重后**直接调用** `tp--reactive-flush-entry`（不再经钩子） |
-| `tp--reactive-flush-entry` | 单条刷新的工作函数（属性更新或 tp-text 替换） |
-
-#### 引擎入口与钩子安装
-| 函数 | 描述 |
-|------|------|
-| `tp--reactive-apply-update` | 变量变化的完整处理：更新 computed、合并层定义、重渲染或入批量队列（嵌套写入经队列而非递归）。尾部刷新置于 `unwind-protect` 清理段中，重渲染抛错也不会把队列条目困死。安装为 `tp--reactive-update-function` |
-
-加载末尾执行安装（与源码逐字一致）：
-
-```elisp
-(setq tp--reactive-update-function #'tp--reactive-apply-update)
-(setq tp--layer-refresh-function #'tp--update-layer-regions)
+真实 require 关系按源码为准；上图表达责任层次，不要求每个 consumer 经过所有中间模块。
+
+| Module | Owns | Must not own |
+| --- | --- | --- |
+| `tp-core.el` | canonical ranges/requests/results、interval traversal、plist/face merge、native property facts | runtime identity、reactivity、publication |
+| `tp-style.el` | native property policies、direct declarations、explicit computed source、projection | selector、stylesheet、specificity、CSS winner |
+| `tp-reactive.el` | signals、bindings、dynamic dependency graph、scheduler、candidate source state、transaction participants | buffer scans、mount positions、layout impact |
+| `tp-surface.el` | prepare context、objects、plans、anchors、mount/index、contribution ledger、diff、publication、rollback、reports | stylesheet/cascade、consumer layout decisions |
+| `tp-layer.el` | `define-tp`/`define-tps` declaration recipes and registry | live layer stack、inline runtime metadata、watcher engine |
+| `tp-ops.el` | direct set/reset/add/get/at/remove/clear plus one-shot `tp-propertize`/`tp-apply` | retained identity、scan refresh |
+| `tp-search.el` | match/regexp application、property search/navigation | runtime identity |
+| `tp-query.el` | native lookup/change wrappers and mutation policy | retained publication |
+| `tp-palette.el` | theme-aware palette data | runtime scheduling |
+| `tp-builtins.el` | built-in direct recipes and display helpers | managed refresh hooks |
+| `tp.el` | package metadata and public module loading | business logic |
+
+There is no `tp-render.el` or `tp-stack.el`. The 0.3 scan renderer and managed stack runtime were deleted rather than wrapped.
+
+## 3. Property data flow
+
+Direct declarations are native property/value pairs. `tp-style.el` resolves them through one policy pipeline:
+
+```text
+native declarations
+ → canonical text/PROPERTY ids
+ → explicit computed-source resolution
+ → normalize
+ → validate
+ → merge contributions
+ → project to final Emacs properties
```
----
+Ordinary functions are literal. Only a tagged `tp-computed` source runs. Explicit nil remains distinguishable from absence throughout projection and retained contribution ownership.
-### tp-stack.el：属性层栈操作
+The policy registry is generic. It knows how final Emacs properties compose; it does not decide which stylesheet declaration wins. CSS selection belongs to ECSS outside TP.
-依赖 tp-core、tp-reactive、tp-layer——**不依赖 tp-ops**（0.2.0 的幻影依赖已在 0.3.0 移除，独立字节编译无警告）。所有栈变更函数建立在共享的裁剪式区域遍历之上，区域操作不会影响 [START, END) 之外的文本；栈的存储编解码在 tp-layer（向下调用）。0.3.0 起所有栈变更函数**返回实际修改的属性段数量**（0 表示无匹配；`tp-put-layer`/`tp-push-layer` 例外，仍返回 OBJECT 或 `(START . END)`），每次改写后经 `tp--stack-register-layers` 登记层→缓冲区注册表。字符串形式**原地修改**字符串（与 `tp-set` 的复制语义不同，各函数 docstring 均有警示）。
+## 4. Static façade and declaration recipes
-#### 内部助手
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp--parse-layer-args` | 解析层操作的灵活参数 | - |
-| `tp--plist-remove` | 返回去掉某键的 plist 副本 | - |
-| `tp--stack-map-region` | 按区间遍历区域内层栈的共享引擎（解码经 tp--stack-props-to-list，含隐藏层） | tp--map-intervals [tp-core], tp--stack-props-to-list [tp-layer] |
-| `tp--stack-register-layers` | 把新栈中每个带 `tp-name` 的层（含被覆盖与隐藏的）登记到缓冲区注册表 | tp-reactive--register-layer-buffer [tp-reactive] |
-| `tp--put-layer-specs` | 展开层规格（层名/内联 plist/层名列表/参数化/层组） | tp--normalize-layer-spec, tp-group-props(-with-arg) [tp-layer] |
-| `tp--move-layer-in-stack` | 在栈中移动层 | tp--get-layer-by-idx-or-name |
-| `tp--raise-layer-in-stack` | 在栈中上下移动层 | tp--move-layer-in-stack |
-| `tp--switch-layers-in-stack` | 交换两个层的位置 | tp--get-layer-by-idx-or-name |
+`tp-propertize` and `tp-apply` use the same direct projection core but do not create live state. `tp-set/reset/add/remove` and the search/query families share canonical range, presence, and mutation primitives from `tp-core.el`.
-#### 层操作（公开 API）
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp-put-layer` | 在指定索引放置层（区域局部；0.3.0 新增尾参 NOERROR：未定义层名返回 nil 而非报错） | tp--put-layer-specs, tp--stack-map-region |
-| `tp-push-layer` | 将层推到顶部（同样支持 NOERROR） | tp-put-layer |
-| `tp-delete-layer` | 删除层 | tp--stack-map-region |
-| `tp-pop-layer` | 弹出顶层 | tp-delete-layer |
-| `tp-move-layer` | 移动层到指定位置 | tp--move-layer-in-stack, tp--stack-map-region |
-| `tp-raise-layer` | 上移层 | tp--raise-layer-in-stack, tp--stack-map-region |
-| `tp-lower-layer` | 下移层（0.3.0 新增，tp-raise-layer 的镜像） | tp--raise-layer-in-stack, tp--stack-map-region |
-| `tp-rotate-layer` | 轮换层（0.3.0：规范顺序 `(START END DIRECTION [COUNT] [OBJECT])`，凭 `up`/`down` 符号无歧义分派；旧顺序永久兼容；单趟栈旋转实现） | tp--stack-map-region |
-| `tp-pin-layer` | 将层一次性移到栈顶（不阻止后续 push 覆盖） | tp-move-layer |
-| `tp-switch-layer` | 交换两个层 | tp--switch-layers-in-stack, tp--stack-map-region |
-| `tp-hide-layer` | 隐藏层（0.3.0 新增）：层留在栈中、继续接收响应式更新但不渲染；隐藏可见顶层则显露下一可见层；全部隐藏时文本仅剩 `tp-layers` 记账属性 | tp--stack-map-region, tp--stack-build-props [tp-layer] |
-| `tp-show-layer` | 取消隐藏（0.3.0 新增） | 同上 |
-| `tp-merge-layers` | 合并多个层（显式 nil 值保留；隐藏的匹配层不贡献属性，全部匹配层均隐藏时合并结果保持隐藏） | tp--merge-layer-props, tp--stack-map-region |
-| `tp-flatten-layers` | 扁平化所有层（只合并可见层；全部隐藏时得到裸文本） | tp--merge-layer-props, tp--stack-map-region |
+`define-tp` and `define-tps` store recipe arglists and body forms. Application expands a recipe into ordinary direct properties. Static recipes are also compiled into the named style registry. Parameterized recipes stay evaluable recipes rather than frozen declarations.
-#### 层查询
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp-layer-list` | 列出所有层名称（含隐藏层） | tp--stack-map-region |
-| `tp-layer-count` | 计算层数量（含隐藏层） | tp--stack-map-region |
-| `tp-layer-exists-p` | 检查层是否存在 | tp-layer-list |
-| `tp-layer-top` | 获取顶层名称（覆盖整个请求区域；按栈序报告最顶层，即使它被隐藏） | tp--stack-map-region |
-| `tp-layer-stack-at` | 单个位置的完整有序层栈：`(NAME . PROPS)` 列表，顶层在前，隐藏层以 PROPS 中的 `tp-hidden t` 标识（0.3.0 新增） | tp--stack-props-to-list [tp-layer] |
-| `tp-region-layer-props` | 获取区域中特定层的属性 | tp--stack-map-region |
+Recipe and group redefinition uses candidate registry state and commits only after body expansion, generated element creation, and named-style compilation succeed. Failure restores the previous registry state.
-#### 层属性操作
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp-add-to-layers` | 向特定层添加属性 | tp--deep-merge-plist, tp--stack-map-region |
-| `tp-add-to-all-layers` | 向所有层添加属性 | tp-add-to-layers |
+No recipe application writes `tp-name`, `tp-layers`, or `tp-meta` to text. No `$variable` parser remains.
-#### Managed lifecycle（Stage 4）
-| 函数/状态 | 描述 | 依赖 |
-|------|------|------|
-| `tp-meta` | lifecycle metadata，保存在 `tp-layers` 权威存储中；直接渲染属性和 public stack query 会剥离它 | tp--managed-render-props, tp--managed-public-layer-props |
-| `tp--managed-operation-counter` | transaction/entry id 的单调计数器 | tp--managed-next-operation-id |
-| `tp-attach-managed-layers` | 扫描已有 managed storage、规范化 metadata、登记发现的层并返回层名 | tp--managed-normalize-stack, tp-reactive--register-layer-buffer |
-| `tp-detach-managed-layers` | 移除 managed storage；KEEP-RENDERED 时保留当前可见渲染属性 | tp--managed-detached-props |
-| `tp-managed-layer-diagnostics` | 只读层诊断：entries、args、registry、buffers、errors | tp--managed-buffer-diagnostic-data |
-| `tp-managed-buffer-diagnostics` | 只读缓冲区诊断 | tp--managed-buffer-diagnostic-data |
-| `tp-managed-diagnostics` | 全局只读诊断，含 theme diagnostics | tp--managed-theme-diagnostics |
-| `tp-layer-transaction` | managed transaction；失败恢复原文本/属性快照，默认发出 `tp-layer-transaction-error` | tp--transaction-* |
+## 5. Reactive graph
-只要 layer stack entry 携带 `tp-meta`，即使只有一个 managed layer，也使用 `tp-layers` 保存权威 stack storage。参数化 mounted entry 保存 args、arglist 与 definition-version；层重定义后通过保存的 args 刷新既有 entry。历史无 metadata entry 作为 legacy entry 保守处理。
+The authoritative graph lives in `tp-reactive.el`:
----
-
-### tp-query.el：原生文本查询与修改策略
-
-只依赖 tp-core。提供 Stage 3/5 原生 façade：直接/effective/source-aware text lookup、overlay-aware char lookup、property change/any/not-all 封装，以及显式 modified/read-only 修改策略。overlay lifecycle（创建、移动、删除、priority 管理）不属于 tp-query。
-
-#### 查询记录与 lookup
-| 函数/记录 | 描述 | 依赖 |
-|------|------|------|
-| `tp-lookup-result` | `cl-defstruct` 结果记录：property、value、present-p、source、mode、object、position、overlay | - |
-| `tp-lookup` | 按 MODE 查询属性；支持 `:text-direct`、`:text-effective`、`:text-source`、`:char`、`:char-source` | tp--lookup-direct, tp--lookup-effective, tp--lookup-char, tp--lookup-source-cell |
-| `tp--lookup-direct` | 只检查 `text-properties-at` 的直接 plist，区分 explicit nil 与 absent | plist-member |
-| `tp--lookup-effective` | 值使用 `get-text-property`，source 使用 text-only 解释 | tp--lookup-source-cell |
-| `tp--lookup-char` | 使用 `get-char-property-and-overlay`，overlay 获胜时 source 为 `:overlay` 且记录 overlay 对象 | get-char-property-and-overlay |
-| `tp--lookup-source-cell` | 按 direct → category → alias → default → absent 解释来源 | text-properties-at, symbol-plist, char-property-alias-alist, default-text-properties |
-| `tp--lookup-alias-cell` | 查找 `char-property-alias-alist` 中第一个直接存在的 alias 属性 | plist-member |
-
-#### property change 与区域谓词
-| 函数 | 描述 | 依赖 |
-|------|------|------|
-| `tp-property-change` | `:direction :next` / `:previous`；传入 PROPERTY 时走 single-property change，省略时走 all-property change | next/previous-property-change, next/previous-single-property-change |
-| `tp-property-any` | `text-property-any` 薄封装 | text-property-any |
-| `tp-property-not-all` | `text-property-not-all` 薄封装 | text-property-not-all |
-
-#### 修改策略
-| 函数/宏 | 描述 |
-|------|------|
-| `tp--mutation-policy-modes` | 校验并归一化 `:modified` 与 `:read-only`；拒绝 `(:modified :silent :read-only :respect)` |
-| `tp-with-mutation-policy` | 三种有效组合：ordinary+respect、ordinary+inhibit、silent+inhibit |
-
-insert/copy/yank/stickiness/narrowing/indirect buffer 均不在 tp-query 中封装，行为直接委托 Emacs 原生操作。
-
----
-
-### tp-palette.el：调色板数据
-
-**不依赖任何 tp- 模块**（仅 subr-x），是独立的叶模块。明/暗主题双值调色板系统，`tp-palette-alist` 是唯一数据源。
-
-| 函数/宏/变量 | 描述 |
-|------|------|
-| `define-tp-palette` | 定义调色板（重定义立即生效）；别名 `tp-define-palette` |
-| `tp-palette-alist` | 调色板注册表（唯一数据源） |
-| `tp-theme-generation` / `tp-theme-last-*` | theme lifecycle diagnostics：generation、last hook source、refresh mode、refreshed ranges、errors |
-| `tp-theme-change-hook` | `enable-theme` / `disable-theme` 后运行的 hook；palette 只负责事件检测，managed renderer 可订阅 |
-| `tp--palette-after-enable-theme` / `tp--palette-after-disable-theme` | theme lifecycle advice，递增 generation 并记录来源 |
-| `tp-parse-color` | 解析颜色规格（支持 `("light" . "dark")` 及单边 cons） |
-| `tp-theme-dark-p` / `tp-theme-light-p` | 当前主题判断 |
-| `tp-palette-color` | 通用的主题解析取色器（0.3.0 新增的首选查询入口） |
-| `tp-palette-has-p` | 谓词整合入口：KIND 取 `:fg`/`:bg`/`:border`/nil（0.3.0 新增） |
-| `tp-palette-fg-color` / `tp-palette-bg-color` / `tp-palette-border-color` | 取前景/背景/边框色（兼容便捷函数） |
-| `tp-palette-p` / `tp-palette-fg-p` / `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p` | 调色板谓词（兼容便捷函数） |
-| `tp-palette-pure` | 取纯色值 |
-
----
-
-### tp-builtins.el：内置层与辅助工具
-
-最上层模块，依赖 tp-core、tp-layer、tp-ops、tp-palette。提供开箱即用的内置层与展示/缓冲辅助。
-
-| 定义 | 描述 |
-|------|------|
-| 内置层 | `tp-palette`、`tp-fg`、`tp-bg`、`tp-button`、`tp-underline`、`tp-delete`、`tp-link`、`tp-space`、`tp-headline`、`tp-action` 等（`define-tp` 定义；`tp-link` 的颜色在应用时解析，主题切换即时生效） |
-| `tp-pop-to-buffer` / `tp-switch-to-buffer` | 显示带属性文本的缓冲辅助宏（q 绑定在缓冲区局部 minor-mode keymap 中） |
-| `tp-palette-show` | 展示所有调色板 |
-| `tp--suffix-symbol` | 符号加后缀助手（0.3.0 起转为私有；`tp-suffix-symbol` 保留为废弃兼容别名） |
-
----
-
-## 钩子变量：唯一许可的反向调用
-
-分层规则的唯一例外是两个**钩子变量**：下层模块声明变量并在需要时 `funcall`，实现由 tp-render.el 在加载时安装。这样下层模块不必 `require` 上层模块，依赖图保持严格单向；而在未加载 tp-render 时，下层模块依然可用（钩子为 nil 时优雅降级：层可以定义与应用，只是没有自动重渲染）。
-
-| 钩子变量 | 声明于 | 安装的实现（tp-render.el） | 用途 |
-|----------|--------|---------------------------|------|
-| `tp--reactive-update-function` | tp-reactive.el | `tp--reactive-apply-update` | 变量监听器触发的重计算与重渲染 |
-| `tp--layer-refresh-function` | tp-layer.el | `tp--update-layer-regions` | 层重定义后刷新已应用区域 |
-
-0.2.0 时钩子有四个；0.3.0 删掉了其中两个，代之以真实的模块内/下行调用：
-
-- `tp--tp-text-handler-function`（原声明于 tp-ops）：整条 `tp-text` 处理链移入 tp-ops，`tp-set` 等直接调用 `tp--handle-tp-text-property`。副产品：只加载 tp-ops 的部分加载也能完成 `tp-text` 文本替换。
-- `tp--reactive-flush-function`（原声明于 tp-reactive）：`tp-with-batch-updates` 与 `tp--flush-batch-updates` 移入 tp-render，刷新直接调用 `tp--reactive-flush-entry`。副产品：部分加载下批量刷新不再被静默丢弃，而是诚实地报 void-function。
-
-留下的两个钩子对应真正**源自下层的事件**（变量被 set、层被重定义），无法在不打破分层的前提下改写为下行调用。
-
----
-
-## 可变状态清单
-
-各模块持有的可变运行时状态及其清理入口（0.3.0 全面核对）：
-
-| 模块 | 状态 | 描述 | 清理 |
-|------|------|------|------|
-| tp-core | —— | **无可变状态**（仅 `tp-debug-mode`/`tp-debug-echo` 两个用户选项；调试日志写入 *tp-debug* 缓冲区，由 `tp-debug-clear` 清除） | - |
-| tp-style | schema、named style、default stylesheet 与调用方持有的独立 stylesheet instances | 纯 style definition 和 rule/layer/source-order 状态；不保存 object、buffer 或 mount；独立实例不被全局 reset 暗中清理 | `tp-style-reset` / `tp-style-reset-rules` |
-| tp-reactive | signals、owner bindings、dependency subscriber sets、variable adapters、transaction-local scheduler state、public counters | TP 1.0 exact reactive graph；normal update 不扫描 buffer | `tp-reactive-reset`；buffer-scoped signal 随 buffer kill |
-| tp-surface | buffer-local surfaces、object/mount/index、range anchors、property ledgers、root/scoped publication、plan/client-state/revision/report | TP 1.0 retained publication；global registry 仅 weak-reference | `tp-surface-unmount`；buffer kill authoritative teardown |
-| tp-reactive | `tp-reactive-deps` | 变量 → 依赖层 注册表 | `tp-reactive-reset` |
-| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` / `tp-reactive-observer-errors` | `:watch` / `:compute` / `:data` 注册表与结构化 observer 错误 | `tp-reactive-reset` |
-| tp-reactive | `tp--batch-update-pending` | 批量更新队列（0.3.0 起也被 reset 清空，防止残留条目对新定义的层重放） | `tp-reactive-reset` |
-| tp-reactive | `tp--layer-buffers` | 层→缓冲区注册表（哈希表，0.3.0 新增） | `tp-reactive-reset`（clrhash）；单层条目随 `tp-undefine-layer`/层重定义移除；死缓冲区经 kill-buffer-hook 与惰性访问剔除 |
-| tp-reactive | `tp--batch-update-active` / `tp--reactive-updating` | 动态标志（let 绑定，非持久状态） | 随作用域退出 |
-| tp-layer | `tp-layer-alist` / `tp-layer-groups` / `tp-layer-transforms` | 层、层组、转换注册表 | `tp-layer-reset` |
-| tp-layer | `tp--group-generated-layers` | 层组生成的层 | `tp-layer-reset` |
-| tp-layer | `tp--anonymous-layer-registry` | 匿名层驻留表 | `tp-layer-reset`；单条随 `tp-undefine-layer` / `tp-gc-anonymous-layers` |
-| tp-layer | `tp--anonymous-layer-counter` | 匿名层名计数器——**刻意不清零**（任何 reset 都不动它）：游离字符串上残留的 `tp-anon-N` 名字永远不能与新铸层重名 | 从不 |
-
-`tp-reactive-reset` 移除全部变量监听器并清空上表 tp-reactive 各行；`tp-layer-reset` 先调用 `tp-reactive-reset`，再清空 tp-layer 各注册表（计数器除外）。
-
----
-
-## 函数调用关系图
-
-（标注 `[模块]` 表示函数所在文件；`╌╌▷` 表示经钩子变量的间接调用。）
-
-### tp-set 调用链
-```
-tp-set [tp-ops]
- ├── tp--parse-args [tp-ops]
- │ ├── tp--merge-duplicate-keys [tp-core]
- │ └── tp--resolve-props [tp-layer]
- │ ├── tp-layer-props / tp-layer-props-with-args [tp-layer]
- │ ├── tp--collect-reactive-symbols [tp-core]
- │ ├── tp--resolve-reactive-symbols [tp-core]
- │ ├── tp--anonymous-layer-name-for [tp-layer]（$var 匿名层驻留）
- │ └── tp--register-reactive-deps [tp-reactive]
- ├── tp--handle-tp-text-property [tp-ops]（0.3.0 起同模块直接调用，不再经钩子）
- │ └── tp--tp-text-transform / tp--tp-text-replace [tp-ops]
- ├── tp--apply-props-to-string [tp-ops]（整串形式，返回新字符串）
- ├── set-text-properties / put-text-property（Emacs 原生，区域形式）
- └── tp--ops-register-layer-buffer [tp-ops]（缓冲区目标）
- └── tp-reactive--register-layer-buffer [tp-reactive]
+```text
+signal ──subscribers──> binding ──subscribers──> binding
+ │
+ └── owner object/surface
```
-### tp-add 调用链
-```
-tp-add [tp-ops]
- ├── tp--parse-args [tp-ops]
- ├── tp--handle-tp-text-property [tp-ops]（直接调用）
- ├── text-properties-at（Emacs 原生）
- ├── tp--prepend-face [tp-core]（face 家族属性）
- │ └── tp--deep-merge-plist [tp-core]
- ├── tp--deep-merge-plist [tp-core]（其他嵌套属性）
- ├── put-text-property（Emacs 原生）
- └── tp--ops-register-layer-buffer [tp-ops]
- └── tp-reactive--register-layer-buffer [tp-reactive]
+A binding is identified by owner plus caller-namespaced key. While its compute function runs, `tp-signal-read` and `tp-binding-read` record the exact dependencies used in that execution. On success, the new dependency set replaces the old set. A conditional branch therefore removes obsolete subscriptions automatically.
+
+Signal writes enter transaction-local candidate state. Dirty bindings are deduplicated and evaluated by dependency order. Equal signal writes and equal binding results stop propagation. Nested writes queue another stabilization pass rather than recursively mutating output. Cycle detection reports the path.
+
+The graph contains no layer-to-buffer registry. A source reaches surfaces through binding owners, not by scanning `buffer-list` or searching text properties.
+
+## 6. Prepare context and identity
+
+Every materialize/mount/update creates a short-lived prepare context. A producer calls `tp-object-ensure` before producing the corresponding plan node.
+
+Object identity is scoped to one surface and derived from:
+
+- parent object identity;
+- sibling-local explicit key, or unkeyed position;
+- opaque kind.
+
+Candidate objects exist only inside the context. Successful publication promotes them to live objects; failed contexts dispose them and their bindings/anchors. `tp-object-resolve` queries live identity by key path without creating state.
+
+The context records touched objects/bindings. Omitted objects are removed. Omitted bindings default to deletion unless an explicit lifecycle says retain. A logical object with no direct plan node must call `tp-object-retain`; disjoint physical output is attached through `tp-object-attach-fragment`.
+
+## 7. Pure surface plans
+
+A plan is a defensive immutable-semantics tree of key/kind/text/props/children/tags/capability. It contains desired output only.
+
+It deliberately excludes:
+
+- buffer/position/marker;
+- patch operation or inverse journal;
+- producer/binding closure;
+- client continuation;
+- consumer-specific layout identity.
+
+TP validates sibling keys, legal text/children combinations, property shape, and capability before publication. Tags remain opaque; they are indexed for callers but never interpreted by TP.
+
+`tp-surface-materialize-string` creates an ephemeral surface/context, renders the plan, then releases all candidate runtime state. `tp-surface-mount` creates a live surface and stores the producer or plan for later reactive preparation.
+
+## 8. Mounts and side indexes
+
+Every live surface owns:
+
+- key path to live object table;
+- object to bindings;
+- object to marker-backed mounts;
+- position/tag query index;
+- retained plan and producer;
+- properties contribution ledger;
+- opaque client state;
+- revision and last report.
+
+The displayed text contains only properties needed by Emacs display or interaction. Identity, provenance, dependencies, marker metadata, revisions, and client state stay in side state.
+
+`content` mounts own their text and properties. `properties` mounts attach objects to opaque range anchors and can only contribute properties to host-owned text.
+
+One object may have multiple disjoint mounts. Public queries expose numeric range/tag snapshots, never live markers.
+
+## 9. Properties contribution ledger
+
+For every relevant anchor/property interval, the surface keeps:
+
+- host baseline presence/value;
+- ordered TP contributions;
+- last published presence/value;
+- contributing anchors.
+
+Candidate preparation collects interval boundaries from old ledger entries, current mounts, and current host property runs. It verifies that a previously published value has not been replaced externally, composes the baseline with current contributions through the property policy, and emits an operation only when the resulting presence/value changes.
+
+An external mismatch raises `tp-property-conflict`. `tp-range-rebase` replaces the baseline with current host state. Unmount restores a baseline only when the current value is still TP's last published value; otherwise it preserves the host edit and reports the conflict.
+
+## 10. Reconcile and diff
+
+TP reconciles object identity by the prepare tree and compares old/new plans for:
+
+- created, removed, retained, and moved keyed objects;
+- minimal character replacement using common prefix/suffix;
+- exact property-run differences;
+- mount/index changes;
+- scoped output authorization.
+
+`tp-surface-update-scoped` maps requested objects directly through the object-to-mount index. For content surfaces it proves old/new changes stay within those mounted ranges; properties surfaces perform the equivalent contribution-range proof. A mismatch is an error unless root fallback is explicitly selected.
+
+An equal candidate produces no prepared publication. It preserves revision, report, buffer modified state, markers, and client state.
+
+## 11. Transaction and publication
+
+The outer transaction owns candidate source values, dirty bindings, prepared surfaces, participants, inverse journals, view state, and final observer scheduling.
+
+```text
+freeze candidate writes
+ → recompute exact dependency closure
+ → prepare every affected surface
+ → validate all candidates
+ → capture inverse journals
+ → publish surfaces in stable id order
+ → publish transaction participants
+ → commit signals/bindings/surface state/revisions
+ → run observers
```
-### define-tp 调用链
-```
-define-tp [tp-layer]（宏）
- └── tp--define-layer-internal [tp-layer]
- ├── tp--parse-define-layer-args [tp-layer]
- ├── tp--collect-reactive-symbols [tp-core]
- ├── tp--unregister-reactive-deps [tp-reactive]（连带移除旧的缓冲区注册表条目）
- ├── tp--ensure-reactive-variables [tp-reactive]
- ├── tp--register-layer-data [tp-reactive]
- │ └── add-variable-watcher（Emacs 原生）
- ├── tp--register-layer-computed [tp-reactive]
- ├── tp--apply-initial-computed [tp-reactive]
- ├── tp--register-reactive-deps [tp-reactive]
- ├── tp--register-layer-watchers [tp-reactive]
- ├── tp--resolve-reactive-symbols [tp-core]
- ├── tp--set-layer-props [tp-layer]
- └── tp--layer-refresh [tp-layer]
- ╌╌▷ tp--update-layer-regions [tp-render]（经钩子）
- └── tp-search-map [tp-search]
- └── put-text-property
-```
+Content publication edits the minimal text span and then exact property runs. Properties publication writes only prepared contribution operations. Marker mounts, indexes, plans, producer, bindings, opaque client state and report switch with the same revision.
-### tp-push-layer 调用链
-```
-tp-push-layer [tp-stack]
- ├── tp--parse-layer-args [tp-stack]
- └── tp-put-layer [tp-stack]
- ├── tp--put-layer-specs [tp-stack]
- │ ├── tp--normalize-layer-spec [tp-layer]
- │ │ └── tp-layer-props [tp-layer]
- │ └── tp-group-props / tp-group-props-with-arg [tp-layer]
- └── tp--stack-map-region [tp-stack]（裁剪到 [START, END)）
- ├── tp--stack-props-to-list [tp-layer]（解码既有栈，含隐藏层）
- ├── tp--stack-build-props [tp-layer]（编码新栈/渲染缓存）
- ├── set-text-properties（Emacs 原生）
- └── tp--stack-register-layers [tp-stack]
- └── tp-reactive--register-layer-buffer [tp-reactive]
-```
+Rollback restores text, properties, marker/index state, plans, producer, client state, signal values, binding values/dependencies, dirty queues, revisions and reports. Property journals are explicit because `atomic-change-group` alone does not cover every silent property mutation path.
-### 响应式更新调用链
-```
-(setq some-reactive-var new-value)
- └── tp--reactive-variable-watcher [tp-reactive]
- ├── tp--invoke-layer-watchers [tp-reactive]（:watch 回调）
- └── ╌╌▷ tp--reactive-apply-update [tp-render]（经钩子）
- ├── tp--update-layer-computed [tp-render]
- │ ├── tp--resolve-reactive-symbols [tp-core]
- │ └── tp--set-layer-props [tp-layer]
- ├── tp--set-layer-props [tp-layer]（深合并回层定义；setq-local 不写全局）
- ├── tp--update-layer-regions [tp-render]（属性更新）
- │ └── tp--map-layer-buffers [tp-render]
- │ │（只访问注册表登记的缓冲区；unknown 层回退为
- │ │ 一次学习性全扫描并登记命中缓冲区）
- │ ├── tp-reactive-layer-buffers [tp-reactive]
- │ ├── tp--buffer-has-layer-region-p [tp-layer]（回退路径）
- │ └── 每缓冲区：
- │ ├── tp-search-map [tp-search] → put-text-property
- │ └── tp--write-layer-through-stack-storage [tp-render]
- │ └── tp--stack-props-to-list /
- │ tp--stack-build-props [tp-layer]
- │ （隐藏/被覆盖的层副本同步刷新）
- └── tp--update-reactive-text [tp-render]（tp-text 文本替换）
- └── tp--replace-reactive-text-in-buffer [tp-render]
- └── tp--edit-region-minimal-diff [tp-render]
- （最小差异、先插入后删除；文本相同则完全不动缓冲区）
+`tp-transaction-participate` lets a consumer promote rollback-capable opaque state inside this boundary. Observers are different: they run only after the transaction commits, and observer failure is recorded rather than rolled back.
-批量模式（tp-with-batch-updates [tp-render]）/ 更新中的嵌套写入：
- └── tp--queue-batch-update [tp-reactive]（入队，不递归）
- └── tp--flush-batch-updates [tp-render]（退出批量/最外层更新结束时；
- 置于 unwind-protect 清理段，重渲染抛错也会排空队列）
- └── tp--reactive-flush-entry [tp-render]（0.3.0 起同模块直接调用，不再经钩子）
- ├── tp--update-layer-regions
- └── tp--update-reactive-text
-```
+If publication kills a target buffer, kill teardown is authoritative. Other surfaces and source state roll back; TP never recreates the killed buffer.
----
+## 12. Lifecycle
-## 设计原则
+Surfaces are buffer-local lifecycle owners. A weak global registry supports lookup without keeping dead buffers alive. Mount installs local change/kill hooks; unmount and kill remove hooks, markers, ledger entries, objects, bindings, subscriptions, indexes, client state and weak registrations.
-1. **严格分层**：模块只允许 `require` 并调用排在它前面的模块，字节编译器强制检查依赖顺序；且只声明真实存在的依赖（0.3.0 移除了 tp-stack→tp-ops 的幻影依赖，tp-palette 不依赖任何 tp- 模块）
-2. **钩子反转**：唯一许可的"向上调用"是两个钩子变量（`tp--reactive-update-function`、`tp--layer-refresh-function`），由 tp-render.el 统一安装实现；能改写为下行调用的反转（tp-text 链、批量刷新）已在 0.3.0 改写掉
-3. **单一职责**：每个模块（和函数）只负责一件事；一个子系统的完整生命周期住在一个模块里（匿名层的铸造/驻留/注销/GC 全在 tp-layer，层栈存储格式知识全在 tp-layer 的编解码器）
-4. **复用优先**：共享引擎（`tp--map-intervals`、`tp--stack-map-region`、`tp--pattern-apply`、`tp--replace-match-text`、`tp-reactive--buffer-layer-names`）承载重复逻辑，高层函数复用而非复制
-5. **统一接口**：所有核心属性函数支持相同的调用约定（整串/区域形式、层名、`$var`、多参数层）
-6. **响应式解耦**：tp-reactive/tp-layer/tp-ops 不依赖渲染引擎；不加载 tp-render 时钩子为 nil，各模块优雅降级（`tp-text` 替换自 0.3.0 起随 tp-ops 即可用）；重渲染只访问层→缓冲区注册表登记的缓冲区，未知层才回退全扫描
+Global signals are explicitly disposable. Buffer-scoped signals are disposed by their buffer kill hook. Owner disposal detaches both dependency directions so no downstream subscriber keeps a dead object alive.
+
+## 13. Diagnostics
+
+Public diagnostics are defensive snapshots:
+
+- `tp-reactive-counters` reports graph work;
+- `tp-surface-report` reports the last publication;
+- `tp-surface-inspect` reports surface lifecycle/state counts;
+- `tp-surface-at-point` queries side indexes;
+- `tp-object-mounts` returns numeric range/tag snapshots.
+
+Reports use generic terms such as bindings, objects, text/property operations, touched characters, scope and rollback. They contain no Ebox paint/layout vocabulary.
+
+## 14. Architectural invariants
+
+- TP source/tests/examples/package metadata do not require or name Ebox/ECSS runtime APIs.
+- TP contains no CSS selector/stylesheet/specificity/origin/winner engine.
+- There is one signal/binding/surface/mount/diff/transaction runtime; no embedded mode exists.
+- TP is the only writer for live TP surfaces.
+- Normal source-to-output flow is signal to binding to object to mount; it does not scan buffers or displayed text for identity.
+- `tp-name`, `tp-layers`, and `tp-meta` are not runtime storage.
+- Plans contain no raw positions or lifecycle closures.
+- Ordinary functions are literal; only `tp-computed` executes.
+- Candidate failure leaks no object, binding, anchor, subscription or revision.
+- Every successful publication advances Buffer state and side state together; every failure preserves the previous committed revision.
diff --git a/docs/BENCHMARKS.md b/docs/BENCHMARKS.md
index 2e48ff7..0998bf7 100644
--- a/docs/BENCHMARKS.md
+++ b/docs/BENCHMARKS.md
@@ -1,5 +1,7 @@
# Reproducible benchmark evidence
+> **Historical TP 0.3 benchmark snapshot; obsolete for TP 1.0.** These results measure the removed managed stack, `tp-text`, layer registry, scan-driven renderer, and 0.3 benchmark runner. They are preserved as historical evidence only and are neither TP 1.0 performance baselines nor current release gates. Current runtime structure and verification expectations are documented in the [README](../README.md), [current architecture](ARCHITECTURE.md), and [API contract](API-SEMANTICS.md).
+
## Command and environment
```sh
diff --git a/docs/CODE-ANALYSIS.md b/docs/CODE-ANALYSIS.md
index 48f8dca..2694236 100644
--- a/docs/CODE-ANALYSIS.md
+++ b/docs/CODE-ANALYSIS.md
@@ -1,14 +1,6 @@
# tp.el 代码分析报告
-> **历史文档说明（2026-07 更新）**：本报告分析的是拆分前的单文件 tp.el（0.1.0）。
-> 自 0.2.0 起，代码库已模块化为九个分层模块（tp-core.el → tp-reactive.el → tp-layer.el →
-> tp-ops.el → tp-search.el → tp-render.el → tp-stack.el → tp-palette.el → tp-builtins.el，
-> tp.el 仅作总入口），并修复了大量已确认的 bug。当前架构请以
-> [ARCHITECTURE.md](ARCHITECTURE.md) 为准，本次变更明细见 [CHANGELOG.md](../CHANGELOG.md)。
-> 下文的调用堆栈与问题分析保留为历史分析；"文件结构"与"关键代码位置"表已更新为当前模块位置。
-> 当前 0.3.0 的 API 语义、原生兼容能力、已确认缺陷与扩展路线，请参阅
-> [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)；修复后的规范契约见
-> [API-SEMANTICS.md](API-SEMANTICS.md)。
+> **历史 TP 0.1/0.3 分析，TP 1.0 已废弃。** 本报告混合记录拆分前的单文件 TP 0.1 与后续 TP 0.3 模块状态，其中的 `tp-render.el`、`tp-stack.el`、`tp-text`、inline `tp-name`/`tp-layers` 和扫描式响应更新均已从 TP 1.0 删除。下文的文件结构、调用堆栈、代码位置、API 与“当前”状态只属于历史快照，不适用于现行实现；正文保持原样作为设计证据。当前事实见 [README](../README_CN.md)、[当前架构](ARCHITECTURE.md)、[API 合同](API-SEMANTICS.md) 与 [1.0 变更记录](../CHANGELOG.md)。
本报告旨在帮助想要参与 tp.el 开发的开发者快速了解项目结构、核心功能实现、以及潜在的优化方向。
diff --git a/docs/REPOSITORY-AUDIT.md b/docs/REPOSITORY-AUDIT.md
index 42b395b..1ec1566 100644
--- a/docs/REPOSITORY-AUDIT.md
+++ b/docs/REPOSITORY-AUDIT.md
@@ -1,5 +1,7 @@
# tp 仓库系统审计与“文本属性操作替代层”能力评估
+> **历史 TP 0.3 审计，TP 1.0 已废弃。** 本文固定记录提交 `a65d799` 的审计证据和当时完成的 0.3 路线，不描述 TP 1.0 当前架构。下文的 managed layer/stack、`tp-render.el`、`tp-stack.el`、`tp-text`、inline `tp-name`/`tp-layers`/`tp-meta`、扫描刷新、阶段状态和代码链接均应按历史快照阅读，不应作为现行 API 或实现依据；正文语义保持原样。当前事实见 [README](../README_CN.md)、[当前架构](ARCHITECTURE.md)、[API 合同](API-SEMANTICS.md) 与 [1.0 变更记录](../CHANGELOG.md)。
+
> 审计日期：2026-07-28
> 审计快照：`a65d799`（tp 0.3.0）
> 结论置信度：高
@@ -446,10 +448,10 @@ FINAL-TEXT:
- 缓冲区初次应用把 `bold` 扩散到整个替换范围。
而后续响应式更新已有按 interval 保留属性的专门路径
-([`tp-render.el`](../tp-render.el#L339-L427))。这说明当前同一功能的“初次应用”
+([`tp-render.el`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-render.el#L339-L427))。这说明当前同一功能的“初次应用”
和“更新应用”使用了两套不完全一致的合并引擎。
-现有 [`tp-render-tests.el`](../tests/tp-render-tests.el#L318-L334) 覆盖了后续响应式更新，
+现有 [`tp-render-tests.el`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-render-tests.el#L318-L334) 覆盖了后续响应式更新，
没有覆盖初次应用的这个状态。
**根因：**
@@ -504,9 +506,9 @@ stack=((audit-static face italic help-echo "new"))
#### B. 已触发 refresh 时，只更新新键，不删除旧键
响应式层重定义会触发 refresh，但
-[`tp--merge-props-into-stack-entry`](../tp-render.el#L142-L152)
+[`tp--merge-props-into-stack-entry`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-render.el#L142-L152)
只复制旧 entry 后写入新 plist 出现的键；
-[`tp--update-layer-regions`](../tp-render.el#L190-L233)
+[`tp--update-layer-regions`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-render.el#L190-L233)
也只遍历新 props 做 `put-text-property`。
复现把响应式层从：
@@ -636,7 +638,7 @@ stack=((audit-reactive face (:background "blue") help-echo "old"))
**状态：已确认。**
-[`tp-put-layer`](../tp-stack.el#L279-L342) 的 `NOERROR` 路径使用宽泛的
+[`tp-put-layer`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L279-L342) 的 `NOERROR` 路径使用宽泛的
`condition-case nil ... (error ...)`。本次定义一个解析成功但求值时主动报错的
参数化层后，`NOERROR=t` 返回 nil，内部的真实错误也被吞掉。
@@ -711,7 +713,7 @@ stack=((audit-reactive face (:background "blue") help-echo "old"))
- 缓冲区原地修改。
层栈的大多数字符串形式又是原地修改
-([`tp-stack.el`](../tp-stack.el#L494-L524))。
+([`tp-stack.el`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L494-L524))。
这意味着仅从函数名或 OBJECT 类型无法判断是否修改原对象，还必须记住调用形式。
@@ -971,9 +973,9 @@ tp 内部体系是自洽的，但熟悉 Emacs 的用户看到 `set` 往往会联
### 7.5 区域查询的标量返回值存在信息损失
-[`tp-layer-list`](../tp-stack.el#L117-L126) 返回区域中出现过的层名 union；
-[`tp-layer-count`](../tp-stack.el#L128-L136) 返回所有 run 的最大深度；
-[`tp-layer-top`](../tp-stack.el#L143-L157) 返回第一个带名字的 top。
+[`tp-layer-list`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L117-L126) 返回区域中出现过的层名 union；
+[`tp-layer-count`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L128-L136) 返回所有 run 的最大深度；
+[`tp-layer-top`](https://github.com/Kinneyzhang/tp/blob/a65d799/tp-stack.el#L143-L157) 返回第一个带名字的 top。
这些定义不是错误，但函数名看起来像在描述“整个区域的统一状态”。当区域内部
异质时，调用者无法从标量结果判断：
diff --git a/docs/reactive-optimization-en.md b/docs/reactive-optimization-en.md
index f1f59bc..9a20d7e 100644
--- a/docs/reactive-optimization-en.md
+++ b/docs/reactive-optimization-en.md
@@ -1,5 +1,7 @@
# tp.el Reactive System Optimization Documentation
+> **Historical TP 0.3 document; obsolete for TP 1.0.** This document evaluates the removed `$variable`, `tp-text`, inline `tp-name`, `tp-render.el`, and scan-driven batching model and remains only as design history. None of the implementation-status claims, function names, or examples below describe TP 1.0. The current optimization model uses an exact signal/binding dependency graph, transaction batching, and retained-surface diffing; see the [README](../README.md), [current architecture](ARCHITECTURE.md), and [API contract](API-SEMANTICS.md).
+
This document describes the optimizations and enhancements made to the tp.el reactive system based on practical experience from the [twidget](https://github.com/Kinneyzhang/twidget.git) project.
## Optimization Suggestions Evaluation
diff --git a/docs/reactive-optimization.md b/docs/reactive-optimization.md
index 25fc81e..6be333c 100644
--- a/docs/reactive-optimization.md
+++ b/docs/reactive-optimization.md
@@ -1,5 +1,7 @@
# tp.el 响应式系统优化文档
+> **历史 TP 0.3 文档，TP 1.0 已废弃。** 本文评估的是已经删除的 `$variable`、`tp-text`、inline `tp-name`、`tp-render.el` 与扫描式批处理模型，仅作为设计历史保留；下文的实现状态、函数名和示例均不适用于 TP 1.0。当前优化模型建立在精确 signal/binding 依赖图、事务批处理和 retained surface diff 上，详见 [README](../README_CN.md)、[当前架构](ARCHITECTURE.md) 和 [API 合同](API-SEMANTICS.md)。
+
本文档基于 [twidget](https://github.com/Kinneyzhang/twidget.git) 项目的实践经验，对 tp.el 的响应式系统进行了优化和增强。
## 优化建议评估
diff --git a/docs/reactive-text-properties-en.md b/docs/reactive-text-properties-en.md
index 247f6ca..d9b0469 100644
--- a/docs/reactive-text-properties-en.md
+++ b/docs/reactive-text-properties-en.md
@@ -1,5 +1,7 @@
# tp.el Complete Guide to Reactive Text Properties
+> **Historical TP 0.3 document; obsolete for TP 1.0.** This document records the removed `$variable`, `tp-text`, inline `tp-name`, and scan-driven reactive-update model and remains only as migration and design history. None of the APIs, examples, or “current behavior” claims below describe TP 1.0. The current reactive model uses signals, bindings, `tp-computed`, `tp-watch`, and retained surfaces; see the [README](../README.md), [current architecture](ARCHITECTURE.md), and [API contract](API-SEMANTICS.md).
+
> Bringing modern frontend framework reactive programming paradigms to the Emacs text properties world
## Introduction
diff --git a/docs/reactive-text-properties.md b/docs/reactive-text-properties.md
index 313c9ca..db1101a 100644
--- a/docs/reactive-text-properties.md
+++ b/docs/reactive-text-properties.md
@@ -1,5 +1,7 @@
# tp.el 响应式文本属性完全指南
+> **历史 TP 0.3 文档，TP 1.0 已废弃。** 本文记录已经删除的 `$variable`、`tp-text`、inline `tp-name` 和扫描式响应更新模型，仅作为迁移与设计历史保留；下文的 API、示例和“当前行为”声明均不适用于 TP 1.0。当前响应式模型使用 signal、binding、`tp-computed`、`tp-watch` 与 retained surface，详见 [README](../README_CN.md)、[当前架构](ARCHITECTURE.md) 和 [API 合同](API-SEMANTICS.md)。
+
> 将现代前端框架的响应式编程范式带入 Emacs 文本属性世界
## 引言
diff --git a/docs/retained-runtime-target-architecture-en.md b/docs/retained-runtime-target-architecture-en.md
index df199cd..9e395c7 100644
--- a/docs/retained-runtime-target-architecture-en.md
+++ b/docs/retained-runtime-target-architecture-en.md
@@ -2,7 +2,7 @@
Chinese version: [TP Retained/Reactive Text Runtime 目标架构](retained-runtime-target-architecture.md).
-Status: approved TP 1.0 target, not yet implemented. [ARCHITECTURE.md](ARCHITECTURE.md) and [API-SEMANTICS.md](API-SEMANTICS.md) remain authoritative for TP 0.3.x current behavior.
+Status: implemented TP 1.0 architecture contract. This document records the target boundaries now implemented and protected by tests; [ARCHITECTURE.md](ARCHITECTURE.md) and [API-SEMANTICS.md](API-SEMANTICS.md) are authoritative for current module and public-behavior facts. The `target-architecture` filename remains stable for existing links.
## 1. Product position
@@ -193,10 +193,10 @@ TP 1.0 is a major-version transition. Stateless public APIs that map directly to
An explicit one-shot legacy import may scan historical propertized text and construct a surface. Normal signal/property/update hot paths never invoke it automatically.
-The final system deletes the layer-to-buffer registry, scan-driven refresh hooks, old inline managed codec, duplicate transactions, and old batch renderer. TP 1.0 package, tests, examples, and this document all work without an Ebox repository.
+The current implementation has deleted the layer-to-buffer registry, scan-driven refresh hooks, old inline managed codec, duplicate transactions, and old batch renderer. The TP 1.0 package, tests, examples, and this document all work without an Ebox repository.
-## 13. Contracts frozen before implementation
+## 13. Implemented, frozen contracts
-Executable contract tests must define prepare-context/object timing; binding identity and lifecycle; literal/computed values; range anchors and property conflicts; single/multi-surface rollback; the three convenience levels; error taxonomy; report shape; explicit nil versus absence; and read-only, undo, narrowing, indirect-buffer, and kill-buffer behavior before implementation begins.
+TP 1.0 executable contract tests define and continuously protect prepare-context/object timing; binding identity and lifecycle; literal/computed values; range anchors and property conflicts; single/multi-surface rollback; the three convenience levels; error taxonomy; report shape; explicit nil versus absence; and read-only, undo, narrowing, indirect-buffer, and kill-buffer behavior.
If implementation requires an Ebox/ECSS-specific branch, a CSS selector/cascade winner, a post-commit identity scan, raw position/closure in a plan, a second renderer, or cannot safely remove a properties contribution, integration stops for ownership review rather than adding an adapter mode.
diff --git a/docs/retained-runtime-target-architecture.md b/docs/retained-runtime-target-architecture.md
index 7d50f0e..e2588d2 100644
--- a/docs/retained-runtime-target-architecture.md
+++ b/docs/retained-runtime-target-architecture.md
@@ -2,7 +2,7 @@
英文版见 [TP Retained/Reactive Text Runtime Target Architecture](retained-runtime-target-architecture-en.md)。
-状态：TP 1.0 已批准目标，尚未实现。TP 0.3.x 当前事实仍以 [ARCHITECTURE.md](ARCHITECTURE.md) 和 [API-SEMANTICS.md](API-SEMANTICS.md) 为准。
+状态：TP 1.0 已实现的架构合同。本文记录已经落地并由测试保护的目标边界；当前模块和公共行为事实分别以 [ARCHITECTURE.md](ARCHITECTURE.md) 与 [API-SEMANTICS.md](API-SEMANTICS.md) 为准。文件名保留 `target-architecture` 以维持既有链接稳定。
## 1. 产品定位
@@ -193,10 +193,10 @@ TP 1.0 是主版本切换。能直接映射到统一 core 的静态 public API
允许显式 one-shot legacy import 扫描历史 propertized text 并建立 surface；normal signal/property/update 热路径禁止自动调用它。
-最终删除 layer→buffer registry、scan-driven refresh hooks、旧 inline managed codec、重复 transaction 和旧 batch renderer。TP 1.0 package、tests、examples 和本文档都能在没有 Ebox repository 的环境中独立工作。
+当前实现已经删除 layer→buffer registry、scan-driven refresh hooks、旧 inline managed codec、重复 transaction 和旧 batch renderer。TP 1.0 package、tests、examples 和本文档均可在没有 Ebox repository 的环境中独立工作。
-## 13. 实施前必须冻结的合同
+## 13. 已冻结并实现的合同
-实现开始前的 executable contract tests 必须确定：prepare-context/object 时序；binding identity/lifecycle；literal/computed value；range anchor 和 property conflict；single/multi-surface rollback；三层便利 API；error taxonomy；report shape；explicit nil/absence；read-only、undo、narrowing、indirect-buffer 和 kill-buffer 行为。
+TP 1.0 的 executable contract tests 已确定并持续保护：prepare-context/object 时序；binding identity/lifecycle；literal/computed value；range anchor 和 property conflict；single/multi-surface rollback；三层便利 API；error taxonomy；report shape；explicit nil/absence；read-only、undo、narrowing、indirect-buffer 和 kill-buffer 行为。
任何实现若要求 Ebox/ECSS-specific branch、CSS selector/cascade winner、post-commit identity scan、plan 中的 raw position/closure、第二套 renderer 或无法安全撤销 properties contribution，应停止接入并重新评审 ownership model，而不是增加 adapter mode。
diff --git a/examples/diagnostic-decoration.el b/examples/diagnostic-decoration.el
new file mode 100644
index 0000000..de39741
--- /dev/null
+++ b/examples/diagnostic-decoration.el
@@ -0,0 +1,117 @@
+;;; diagnostic-decoration.el --- TP diagnostics decorations example -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;;; Commentary:
+
+;; Demonstrates properties-only diagnostics with explicit ownership boundaries:
+;; - create marker anchors directly with `tp-range-anchor-create`
+;; - mount a properties surface with `tp-surface-mount`
+;; - update it from a signal
+;; - handle external host overrides and cleanup.
+
+;;; Code:
+
+(require 'tp)
+
+(defun tp-example-diagnostic-decoration-mount (buffer)
+ "Mount a diagnostics decoration on BUFFER and return its control plist.
+
+The decoration tracks a signal-controlled color on the word \"DIAG\"."
+ (let* ((target (get-buffer-create buffer))
+ (palette '((ok . "DarkGreen") (warn . "DarkOrange") (busy . "Purple")))
+ (mode-signal (tp-signal-create 'ok))
+ (range (cons 2 6))
+ (anchor nil)
+ (producer nil)
+ (surface nil))
+ (with-current-buffer target
+ (erase-buffer)
+ (insert "xDIAG")
+ (setq anchor
+ (tp-range-anchor-create target 2 6 :boundary-policy 'stale))
+ (setq producer
+ (lambda (context)
+ (let* ((root (tp-object-ensure context nil 'diag 'column))
+ (node (tp-object-ensure
+ context root 'diagnostic 'range))
+ (mode (tp-signal-read mode-signal))
+ (color (alist-get mode palette)))
+ (tp-object-attach-range context node anchor)
+ (tp-surface-plan-create
+ :key 'diag
+ :kind 'column
+ :capability 'properties
+ :children
+ (list
+ (tp-surface-plan-create
+ :key 'diagnostic
+ :kind 'range
+ :props (list 'help-echo
+ (format "mode=%s" mode)
+ 'face `(:foreground ,color))
+ :capability 'properties))))))
+ (setq surface
+ (tp-surface-mount target producer '(:capability properties :inhibit-read-only t))))
+ (list :buffer target
+ :range range
+ :anchor anchor
+ :producer producer
+ :surface surface
+ :mode-signal mode-signal)))
+
+(defun tp-example-diagnostic-decoration-object (state)
+ "Return the retained diagnostic object from STATE."
+ (tp-object-resolve (plist-get state :surface) '(diag diagnostic)))
+
+(defun tp-example-diagnostic-decoration-range (state)
+ "Return STATE's active diagnostic range as `(START . END)`."
+ (let ((mount (car (tp-object-mounts (tp-example-diagnostic-decoration-object state)))))
+ (cons (plist-get mount :start) (plist-get mount :end))))
+
+(defun tp-example-diagnostic-decoration-set-mode (state mode)
+ "Set diagnostics MODE in STATE and return the resulting report.
+
+MODE should be one of `ok`, `warn`, or `busy`."
+ (tp-signal-set (plist-get state :mode-signal) mode)
+ (tp-surface-report (plist-get state :surface)))
+
+(defun tp-example-diagnostic-decoration-repaint-range (state properties)
+ "Apply external PROPERTIES on the diagnostic range in STATE's buffer.
+
+This simulates host edits that are outside TP ownership."
+ (let* ((buffer (plist-get state :buffer))
+ (range (tp-example-diagnostic-decoration-range state)))
+ (with-current-buffer buffer
+ (add-text-properties (car range) (cdr range) properties))))
+
+(defun tp-example-diagnostic-decoration-insert-host-text (state position text)
+ "Insert TEXT at POSITION in STATE buffer."
+ (with-current-buffer (plist-get state :buffer)
+ (save-excursion
+ (goto-char position)
+ (insert text))))
+
+(defun tp-example-diagnostic-decoration-delete-host-range (state start end)
+ "Delete host text in STATE buffer between START and END."
+ (with-current-buffer (plist-get state :buffer)
+ (delete-region start end)))
+
+(defun tp-example-diagnostic-decoration-rebase (state)
+ "Rebase diagnostics anchors for STATE."
+ (tp-range-rebase (plist-get state :anchor)))
+
+(defun tp-example-diagnostic-decoration-unmount (state)
+ "Unmount diagnostic decoration in STATE and dispose its signal."
+ (let* ((surface (plist-get state :surface))
+ (signal (plist-get state :mode-signal))
+ (report (when (tp-surface-live-p surface)
+ (tp-surface-unmount surface))))
+ (when (tp-signal-live-p signal)
+ (tp-signal-dispose signal))
+ report))
+
+(provide 'diagnostic-decoration)
+
+;;; diagnostic-decoration.el ends here
diff --git a/examples/reactive-status.el b/examples/reactive-status.el
new file mode 100644
index 0000000..4d508a3
--- /dev/null
+++ b/examples/reactive-status.el
@@ -0,0 +1,178 @@
+;;; reactive-status.el --- Public TP reactive status watch example -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;;; Commentary:
+
+;; Reactive status example built only from public APIs:
+;; - `tp-signal-create`
+;; - `tp-signal-set`
+;; - `tp-watch`
+;;
+;; The watch surface only owns a fixed range and updates properties when the
+;; status signal changes.
+
+;;; Code:
+
+(require 'tp)
+
+(defconst tp-example-reactive-status-tag "STATUS"
+ "Fixed status label shown by this example.")
+
+(defun tp-example-reactive-status-mount (buffer)
+ "Mount a status watch on BUFFER and return its control state plist.
+
+The returned state has keys:
+
+- `:buffer` target buffer
+- `:surface` retained properties surface returned by `tp-watch`
+- `:status` status signal controlling foreground color
+- `:noise` unrelated signal used to demonstrate sparse updates
+- `:range` watched region"
+ (let* ((target (get-buffer-create buffer))
+ (status (tp-signal-create 'ready))
+ (noise (tp-signal-create 0))
+ (surface nil))
+ (with-current-buffer target
+ (erase-buffer)
+ (insert "STATUS")
+ (setq surface
+ (tp-watch target 1 7
+ (lambda ()
+ (list
+ 'face
+ (if (eq (tp-signal-read status) 'ready)
+ '(:foreground "ForestGreen")
+ '(:foreground "IndianRed"))
+ 'help-echo
+ (tp-computed
+ (lambda ()
+ (format "status=%s"
+ (tp-signal-read status))))))))
+ (list :buffer target
+ :surface surface
+ :status status
+ :noise noise
+ :range '(1 . 7)))))
+
+(defun tp-example-reactive-status-dispose (state)
+ "Unmount reactive status STATE and dispose internal signals."
+ (when-let ((surface (plist-get state :surface)))
+ (when (tp-surface-live-p surface)
+ (tp-surface-unmount surface))
+ (setf (plist-get state :surface) nil))
+ (when-let ((status (plist-get state :status)))
+ (when (tp-signal-live-p status)
+ (tp-signal-dispose status))
+ (setf (plist-get state :status) nil))
+ (when-let ((noise (plist-get state :noise)))
+ (when (tp-signal-live-p noise)
+ (tp-signal-dispose noise))
+ (setf (plist-get state :noise) nil)))
+
+(defun tp-example-reactive-status-set (state value)
+ "Set status STATE to VALUE.
+
+STATE must come from `tp-example-reactive-status-mount`."
+ (tp-signal-set (plist-get state :status) value))
+
+(defun tp-example-reactive-status-poke (state value)
+ "Set an unrelated signal in STATE to VALUE.
+
+This must not affect watched STATUS rendering."
+ (tp-signal-set (plist-get state :noise) value))
+
+(defun tp-example-reactive-status-clear-reactive-counters ()
+ "Reset TP reactive scheduler counters.
+
+Useful before measuring sparse update behavior."
+ (tp-reactive-reset-counters))
+
+(defun tp-example-reactive-status-watch-report (state)
+ "Return `tp-surface-report` for STATE."
+ (tp-surface-report (plist-get state :surface)))
+
+(defun tp-example-reactive-status-color (state)
+ "Return the effective face color on STATE's watched range.
+
+If called outside STATE's buffer, returns nil."
+ (with-current-buffer (plist-get state :buffer)
+ (plist-get (tp-at 1 'face) :foreground)))
+
+(defun tp-example-reactive-content--producer (state)
+ "Return a retained content producer bound to STATE."
+ (lambda (context)
+ (let* ((object (tp-object-ensure context nil 'status 'text))
+ (branch
+ (tp-bind
+ object '(example . branch)
+ (lambda ()
+ (if (tp-signal-read (plist-get state :enabled))
+ (cons 'primary
+ (tp-signal-read (plist-get state :primary)))
+ (cons 'fallback
+ (tp-signal-read (plist-get state :fallback)))))))
+ (label
+ (tp-bind
+ object '(example . label)
+ (lambda ()
+ (pcase-let ((`(,source . ,value) (tp-binding-read branch)))
+ (format "%s:%s" source value))))))
+ (tp-surface-plan-create
+ :key 'status :kind 'text :text (tp-binding-read label)
+ :props '(face bold) :capability 'content))))
+
+(defun tp-example-reactive-content-mount (buffer)
+ "Mount a conditional retained status in BUFFER and return its state."
+ (let* ((target (get-buffer-create buffer))
+ (state (list :buffer target
+ :enabled (tp-signal-create t)
+ :primary (tp-signal-create "ready")
+ :fallback (tp-signal-create "offline")))
+ (producer (tp-example-reactive-content--producer state))
+ (surface (tp-surface-mount
+ target producer '(:capability content))))
+ (setf (plist-get state :producer) producer
+ (plist-get state :surface) surface)
+ state))
+
+(defun tp-example-reactive-content-set-enabled (state enabled)
+ "Set STATE's conditional branch to ENABLED and return its report."
+ (tp-signal-set (plist-get state :enabled) enabled)
+ (tp-surface-report (plist-get state :surface)))
+
+(defun tp-example-reactive-content-set-primary (state value)
+ "Set STATE's primary status to VALUE and return its report."
+ (tp-signal-set (plist-get state :primary) value)
+ (tp-surface-report (plist-get state :surface)))
+
+(defun tp-example-reactive-content-set-fallback (state value)
+ "Set STATE's fallback status to VALUE and return its report."
+ (tp-signal-set (plist-get state :fallback) value)
+ (tp-surface-report (plist-get state :surface)))
+
+(defun tp-example-reactive-content-batch-primary (state values)
+ "Set STATE's primary status through VALUES in one transaction."
+ (tp-with-transaction
+ (dolist (value values)
+ (tp-signal-set (plist-get state :primary) value)))
+ (tp-surface-report (plist-get state :surface)))
+
+(defun tp-example-reactive-content-text (state)
+ "Return plain retained status text from STATE."
+ (with-current-buffer (plist-get state :buffer)
+ (buffer-substring-no-properties (point-min) (point-max))))
+
+(defun tp-example-reactive-content-dispose (state)
+ "Unmount STATE and dispose all signals it owns."
+ (when (tp-surface-live-p (plist-get state :surface))
+ (tp-surface-unmount (plist-get state :surface)))
+ (dolist (key '(:enabled :primary :fallback))
+ (let ((signal (plist-get state key)))
+ (when (tp-signal-live-p signal)
+ (tp-signal-dispose signal)))))
+
+(provide 'reactive-status)
+
+;;; reactive-status.el ends here
diff --git a/examples/retained-dashboard.el b/examples/retained-dashboard.el
new file mode 100644
index 0000000..24f6049
--- /dev/null
+++ b/examples/retained-dashboard.el
@@ -0,0 +1,160 @@
+;;; retained-dashboard.el --- Public TP retained content dashboard example -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;;; Commentary:
+
+;; A compact retained dashboard example with additive/removable/reordered
+;; keyed entries. It uses:
+;; - `tp-surface-mount`
+;; - `tp-surface-update`
+;; - `tp-surface-unmount`
+;; - `tp-surface-inspect`
+;; - `tp-object-resolve`
+;;
+;; No stack/render/managed runtime APIs are used.
+
+;;; Code:
+
+(require 'tp)
+
+(defun tp-example-dashboard--entry-label (entry)
+ "Return a display label for ENTRY.
+
+ENTRY is a plist with keys `:id` and `:label`."
+ (concat " " (or (plist-get entry :label) (prin1-to-string (plist-get entry :id))) " "))
+
+(defun tp-example-dashboard--entry-face (entry theme)
+ "Return a native face declaration for ENTRY.
+
+ENTRY may include `:active` (`t` / nil).
+THEME is symbol `light` or `dark`."
+ (let* ((light-active '(:weight bold :foreground "#0f6fff"))
+ (light-idle '(:foreground "#657b83"))
+ (dark-active '(:weight bold :foreground "#83a598"))
+ (dark-idle '(:foreground "#d3d3d3"))
+ (palette (if (eq theme 'dark) (cons dark-active dark-idle)
+ (cons light-active light-idle))))
+ (if (plist-get entry :active)
+ (car palette)
+ (cdr palette))))
+
+(defvar tp-example-dashboard-entry-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "RET") #'ignore)
+ map)
+ "Keymap installed on each retained dashboard entry.")
+
+(defun tp-example-dashboard--entry-button (entry)
+ "Return a BUTTON property for ENTRY."
+ (format "entry:%s" (or (plist-get entry :id) "item")))
+
+(defun tp-example-dashboard--entry-theme (state)
+ "Return the active dashboard theme symbol from STATE."
+ (tp-signal-read (plist-get state :theme)))
+
+(defun tp-example-retained-dashboard--build-producer (state entries)
+ "Return a dashboard producer function bound to STATE and ENTRIES.
+
+STATE owns the theme signal. ENTRIES is candidate content captured by the
+producer and becomes committed state only after publication succeeds."
+ (lambda (context)
+ (let* ((theme (tp-example-dashboard--entry-theme state))
+ (root (tp-object-ensure context nil 'dashboard 'group))
+ (children
+ (mapcar
+ (lambda (entry)
+ (let ((id (plist-get entry :id)))
+ (tp-object-ensure context root id 'entry)
+ (when (plist-get entry :force-failure)
+ (error "Dashboard update failure"))
+ (tp-surface-plan-create
+ :key id
+ :kind 'entry
+ :text (tp-example-dashboard--entry-label entry)
+ :props (list
+ 'face (tp-example-dashboard--entry-face entry theme)
+ 'keymap tp-example-dashboard-entry-keymap
+ 'button (tp-example-dashboard--entry-button entry))
+ :capability 'content)))
+ entries)))
+ (tp-surface-plan-create
+ :key 'dashboard
+ :kind 'column
+ :children children
+ :capability 'content))))
+
+(defun tp-example-retained-dashboard-mount (buffer &optional entries)
+ "Mount a retained dashboard in BUFFER and return its control plist.
+
+ENTRIES defaults to three sample entries and is expected to be a list of
+plist records `(:id :label :active )`."
+ (let* ((target (get-buffer-create buffer))
+ (state (list :entries (or entries
+ '((:id alpha :label "Alpha" :active t)
+ (:id beta :label "Beta")
+ (:id gamma :label "Gamma"))
+ )
+ :theme (tp-signal-create 'light)
+ :buffer target))
+ (producer (tp-example-retained-dashboard--build-producer
+ state (plist-get state :entries)))
+ (surface (tp-surface-mount target producer
+ '(:capability content))))
+ (list :buffer target
+ :surface surface
+ :producer producer
+ :state state)))
+
+(defun tp-example-retained-dashboard-update (dashboard entries)
+ "Update DASHBOARD with ENTRIES and run a scoped mount publication.
+
+Return `tp-surface-report`."
+ (let ((surface (plist-get dashboard :surface))
+ (state (plist-get dashboard :state)))
+ (let* ((producer (tp-example-retained-dashboard--build-producer
+ state entries))
+ (report (tp-surface-update surface producer)))
+ (setf (plist-get state :entries) entries)
+ (setf (plist-get dashboard :producer) producer)
+ report)))
+
+(defun tp-example-retained-dashboard-set-theme (dashboard theme)
+ "Set DASHBOARD to THEME and return its resulting surface report.
+
+THEME must be `light` or `dark`."
+ (let ((state (plist-get dashboard :state)))
+ (tp-signal-set (plist-get state :theme) theme)
+ (tp-surface-report (plist-get dashboard :surface))))
+
+(defun tp-example-retained-dashboard-report (dashboard)
+ "Return DASHBOARD's current surface report."
+ (tp-surface-report (plist-get dashboard :surface)))
+
+(defun tp-example-retained-dashboard-remove (dashboard)
+ "Unmount DASHBOARD, dispose its signal, and return the commit report."
+ (let* ((surface (plist-get dashboard :surface))
+ (state (plist-get dashboard :state))
+ (theme (plist-get state :theme))
+ (report (when (tp-surface-live-p surface)
+ (tp-surface-unmount surface))))
+ (when (tp-signal-live-p theme)
+ (tp-signal-dispose theme))
+ report))
+
+(defun tp-example-retained-dashboard-entry-handle (dashboard id)
+ "Resolve retained object HANDLE for dashboard ID in DASHBOARD.
+
+Return nil when ID has no committed object."
+ (tp-object-resolve (plist-get dashboard :surface)
+ (list 'dashboard id)))
+
+(defun tp-example-retained-dashboard-text (dashboard)
+ "Return DASHBOARD's plain text from its host buffer."
+ (with-current-buffer (plist-get dashboard :buffer)
+ (buffer-substring-no-properties (point-min) (point-max))))
+
+(provide 'retained-dashboard)
+
+;;; retained-dashboard.el ends here
diff --git a/examples/static-properties.el b/examples/static-properties.el
new file mode 100644
index 0000000..8aeab02
--- /dev/null
+++ b/examples/static-properties.el
@@ -0,0 +1,56 @@
+;;; static-properties.el --- Public API static TP property examples -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;;; Commentary:
+
+;; Examples that use only the one-shot public TP APIs: `tp-propertize` and
+;; `tp-apply`. They do not rely on layer stacks, retained runtimes, or
+;; managed state.
+
+;;; Code:
+
+(require 'tp)
+
+(defconst tp-example-static-properties-caption-buffer-width 28
+ "Fixed width used by static diagnostics in this example set.")
+
+(defvar tp-example-static-properties-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "RET") #'ignore)
+ map)
+ "Keymap stored literally on the static title string.")
+
+(defun tp-example-static-properties-help (_window _object _position)
+ "Return help text for a static title.
+WINDOW, OBJECT, and POSITION are supplied by Emacs help display."
+ "Static TP title")
+
+(defun tp-example-static-properties-format-title (label)
+ "Return LABEL padded and styled as a static title.
+
+LABEL is shown using native Emacs properties only.
+
+The returned value is a propertized string (no surface, no anchor, no object)."
+ (let ((text (format (format "%%-%ds" tp-example-static-properties-caption-buffer-width)
+ label)))
+ (tp-propertize text
+ `(face ((:weight bold)
+ (:foreground "white" :background "#3c4656"))
+ keymap ,tp-example-static-properties-keymap
+ help-echo ,#'tp-example-static-properties-help
+ mouse-face nil))))
+
+(defun tp-example-static-properties-mark-range (buffer start end &optional color)
+ "Apply a one-shot property run on BUFFER [START, END).
+
+COLOR defaults to a light neutral background and preserves all existing
+properties outside [START, END)."
+ (tp-apply buffer start end
+ `(face (:background ,(or color "#f0e6cc"))
+ help-echo "Static range marker")))
+
+(provide 'static-properties)
+
+;;; static-properties.el ends here
diff --git a/tests/tp-architecture-tests.el b/tests/tp-architecture-tests.el
new file mode 100644
index 0000000..84a0e59
--- /dev/null
+++ b/tests/tp-architecture-tests.el
@@ -0,0 +1,93 @@
+;;; tp-architecture-tests.el --- TP 1.0 boundary tests -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;;; Commentary:
+
+;; Structural contracts for the single retained/reactive TP runtime.
+
+;;; Code:
+
+(require 'ert)
+(require 'tp)
+
+(defconst tp-architecture-tests--root
+ (file-name-directory
+ (directory-file-name
+ (file-name-directory (or load-file-name buffer-file-name))))
+ "Absolute path to the TP repository root.")
+
+(ert-deftest tp-architecture-test-legacy-runtime-modules-are-absent ()
+ "The removed scan renderer and inline stack runtime are not shipped."
+ (dolist (file '("tp-render.el" "tp-stack.el"))
+ (should-not
+ (file-exists-p (expand-file-name file tp-architecture-tests--root))))
+ (should-not (featurep 'tp-render))
+ (should-not (featurep 'tp-stack)))
+
+(ert-deftest tp-architecture-test-legacy-runtime-symbols-are-absent ()
+ "The public runtime exposes no scan registry or inline identity API."
+ (dolist (symbol '(tp-reactive-deps
+ tp-layer-watchers
+ tp-layer-computed
+ tp-layer-data
+ tp--layer-buffers))
+ (should-not (boundp symbol)))
+ (dolist (symbol '(tp-reactive-layer-buffers
+ tp-reactive-track-buffer
+ tp--map-layer-buffers
+ tp-push-layer
+ tp-put-layer
+ tp-hide-layer
+ tp-show-layer
+ tp-move-layer
+ tp-merge-layers))
+ (should-not (fboundp symbol))))
+
+(ert-deftest tp-architecture-test-production-has-no-legacy-scan-path ()
+ "Production sources contain no scan registry or inline identity access."
+ (let ((forbidden
+ (regexp-opt '("(buffer-list)"
+ "tp-reactive-deps"
+ "tp--layer-buffers"
+ "tp--map-layer-buffers"
+ "'tp-name"
+ "'tp-layers"
+ "'tp-meta"))))
+ (dolist (file (directory-files tp-architecture-tests--root t
+ "\\`tp-.*\\.el\\'"))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (should-not (re-search-forward forbidden nil t))))))
+
+(ert-deftest tp-architecture-test-recipes-do-not-publish-runtime-metadata ()
+ "Named declaration recipes expand without inline runtime identity."
+ (unwind-protect
+ (progn
+ (define-tp tp-architecture-test-recipe ()
+ '(face bold help-echo "recipe"))
+ (let ((value (tp-set "text" 'tp-architecture-test-recipe)))
+ (dolist (property '(tp-name tp-layers tp-meta tp-hidden tp-text))
+ (should-not (plist-member (text-properties-at 0 value) property)))))
+ (tp-undefine-layer 'tp-architecture-test-recipe)))
+
+(ert-deftest tp-architecture-test-stateless-facade-does-not-touch-runtime-counters ()
+ "One-shot public property APIs do not create retained/reactive work."
+ (with-temp-buffer
+ (insert "text")
+ (let ((counters (tp-reactive-counters))
+ (surfaces tp--buffer-surfaces))
+ (tp-set 1 5 '(face bold))
+ (should (equal (tp-reactive-counters) counters))
+ (should (eq tp--buffer-surfaces surfaces)))))
+
+(ert-deftest tp-architecture-test-loading-tp-does-not-advise-theme-lifecycle ()
+ "Loading TP does not install global theme lifecycle advice."
+ (dolist (symbol '(tp--palette-after-enable-theme
+ tp--palette-after-disable-theme))
+ (should-not (fboundp symbol))))
+
+(provide 'tp-architecture-tests)
+;;; tp-architecture-tests.el ends here
diff --git a/tests/tp-binding-tests.el b/tests/tp-binding-tests.el
index 9244618..53c1ca5 100644
--- a/tests/tp-binding-tests.el
+++ b/tests/tp-binding-tests.el
@@ -207,6 +207,36 @@
(should-not (eq failed replacement))
(should (= (tp-binding-read replacement) 42))))))
+(ert-deftest tp-binding-test-key-owns-data-and-preserves-opaque-identities ()
+ "A retained binding key copies data containers but not identity objects."
+ (tp-binding-test--isolated
+ (with-temp-buffer
+ (let* ((caller-string (copy-sequence "binding"))
+ (caller-vector (vector (copy-sequence "key")))
+ (record (tp--make-native-range (current-buffer) :buffer 1 1))
+ (calls 0)
+ (callback (lambda () (cl-incf calls)))
+ (table (make-hash-table :test #'equal))
+ (marker (copy-marker (point-min)))
+ (key (list 'test caller-string caller-vector record callback
+ table marker (current-buffer)))
+ (binding (tp-bind 'owner key (lambda () 1)))
+ (stored (tp-binding-key binding)))
+ (should-not (eq stored key))
+ (should-not (eq (nth 1 stored) caller-string))
+ (should-not (eq (nth 2 stored) caller-vector))
+ (should-not (eq (aref (nth 2 stored) 0) (aref caller-vector 0)))
+ (should (eq (nth 3 stored) record))
+ (should (eq (nth 4 stored) callback))
+ (should (eq (nth 5 stored) table))
+ (should (eq (nth 6 stored) marker))
+ (should (eq (nth 7 stored) (current-buffer)))
+ (should (= calls 0))
+ (aset caller-string 0 ?B)
+ (aset (aref caller-vector 0) 0 ?K)
+ (should (equal (nth 1 stored) "binding"))
+ (should (equal (nth 2 stored) ["key"]))))))
+
(ert-deftest tp-binding-test-cycle-error-reports-binding-path ()
"A binding dependency cycle reports the keys in cycle order."
(tp-binding-test--isolated
@@ -230,6 +260,58 @@
(should (= (tp-binding-read first) 1))
(should (= (tp-binding-read second) 2)))))
+(ert-deftest tp-binding-test-cycle-error-cannot-mutate-retained-keys ()
+ "Cycle diagnostics return data copies instead of retained binding keys."
+ (tp-binding-test--isolated
+ (let* ((switch (tp-signal-create nil))
+ (first-key
+ (list 'test (copy-sequence "first")
+ (vector (copy-sequence "path"))))
+ (second-key
+ (list 'test (copy-sequence "second")
+ (vector (copy-sequence "path"))))
+ first second)
+ (setq first
+ (tp-bind 'first-owner first-key
+ (lambda ()
+ (if (tp-signal-read switch)
+ (tp-binding-read second)
+ 1))))
+ (setq second
+ (tp-bind 'second-owner second-key
+ (lambda () (1+ (tp-binding-read first)))))
+ (let* ((failure
+ (should-error (tp-signal-set switch t)
+ :type 'tp-binding-cycle))
+ (reported-first (car (cadr failure))))
+ (aset (nth 1 reported-first) 0 ?F)
+ (aset (aref (nth 2 reported-first) 0) 0 ?P)
+ (should (equal (nth 1 (tp-binding-key first)) "first"))
+ (should (equal (nth 2 (tp-binding-key first)) ["path"]))))))
+
+(ert-deftest tp-binding-test-participant-key-is-owned-by-transaction ()
+ "Transaction participant keys cannot follow caller container mutation."
+ (tp-binding-test--isolated
+ (let* ((caller-string (copy-sequence "participant"))
+ (caller-vector (vector (copy-sequence "key")))
+ (key (list 'test caller-string caller-vector)))
+ (tp-with-transaction
+ (tp-transaction-participate key #'ignore #'ignore)
+ (let ((stored (tp--transaction-participant-key
+ (car tp--transaction-participants))))
+ (should-not (eq (nth 1 stored) caller-string))
+ (should-not (eq (nth 2 stored) caller-vector))
+ (should-not (eq (aref (nth 2 stored) 0)
+ (aref caller-vector 0)))
+ (aset caller-string 0 ?P)
+ (aset (aref caller-vector 0) 0 ?K)
+ (should (equal (nth 1 stored) "participant"))
+ (should (equal (nth 2 stored) ["key"]))
+ (should-error
+ (tp-transaction-participate
+ (list 'test "participant" ["key"]) #'ignore #'ignore)
+ :type 'tp-reactive-error))))))
+
(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge ()
"A dirty target rewires before cycle validation examines its old edges."
(tp-binding-test--isolated
diff --git a/tests/tp-core-tests.el b/tests/tp-core-tests.el
index 0b825dc..9b7ffb0 100644
--- a/tests/tp-core-tests.el
+++ b/tests/tp-core-tests.el
@@ -133,6 +133,34 @@
(setf (tp--request-public-return request) :native)
(should (eq (tp--result-public-value result) 'native-value))))
+(ert-deftest tp-core-test-property-value-copy-has-explicit-identity-rules ()
+ "Property copies own data containers and preserve opaque identities."
+ (with-temp-buffer
+ (let* ((caller-string (copy-sequence "value"))
+ (caller-vector (vector (copy-sequence "nested")))
+ (record (tp--make-native-range (current-buffer) :buffer 1 1))
+ (calls 0)
+ (callback (lambda () (cl-incf calls)))
+ (table (make-hash-table :test #'equal))
+ (marker (copy-marker (point-min)))
+ (value (list caller-string caller-vector record callback table
+ marker (current-buffer)))
+ (copy (tp--copy-property-value value)))
+ (should-not (eq copy value))
+ (should-not (eq (nth 0 copy) caller-string))
+ (should-not (eq (nth 1 copy) caller-vector))
+ (should-not (eq (aref (nth 1 copy) 0) (aref caller-vector 0)))
+ (should (eq (nth 2 copy) record))
+ (should (eq (nth 3 copy) callback))
+ (should (eq (nth 4 copy) table))
+ (should (eq (nth 5 copy) marker))
+ (should (eq (nth 6 copy) (current-buffer)))
+ (should (= calls 0))
+ (aset caller-string 0 ?V)
+ (aset (aref caller-vector 0) 0 ?N)
+ (should (equal (nth 0 copy) "value"))
+ (should (equal (nth 1 copy) ["nested"])))))
+
;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map
(ert-deftest tp-core-test-intervals-buffer-relative-default ()
@@ -172,20 +200,19 @@
(should (equal (tp-intervals-map #'list 3 9 nil t)
'((3 4 nil nil) (4 8 (face bold) nil) (8 9 nil nil))))))
-(ert-deftest tp-core-test-intervals-map-splits-layer-stack ()
- "tp-intervals-map hands the tp-layers stack to FUNCTION separately."
+(ert-deftest tp-core-test-intervals-map-returns-direct-properties ()
+ "tp-intervals-map returns direct properties and a nil reserved slot."
(with-temp-buffer
(insert "hello")
- (set-text-properties
- 1 6 '(face bold tp-layers ((face italic tp-name below))))
+ (set-text-properties 1 6 '(face bold help-echo "direct"))
(let ((res (tp-intervals-map #'list 1 6 nil t)))
(should (= (length res) 1))
- (pcase-let ((`(,beg ,end ,top ,below) (car res)))
+ (pcase-let ((`(,beg ,end ,props ,reserved) (car res)))
(should (= beg 1))
(should (= end 6))
- (should (eq (plist-get top 'face) 'bold))
- (should-not (plist-member top 'tp-layers))
- (should (equal below '((face italic tp-name below))))))))
+ (should (eq (plist-get props 'face) 'bold))
+ (should (equal (plist-get props 'help-echo) "direct"))
+ (should-not reserved)))))
(ert-deftest tp-core-test-intervals-map-drops-nil-results ()
"nil results from FUNCTION are removed from the returned list."
diff --git a/tests/tp-doctest.el b/tests/tp-doctest.el
index b5db87e..4ee46bd 100644
--- a/tests/tp-doctest.el
+++ b/tests/tp-doctest.el
@@ -1,929 +1,196 @@
-;;; tp-doctest.el --- executable README examples -*- lexical-binding: t -*-
+;;; tp-doctest.el --- Executable TP 1.0 examples -*- lexical-binding: t; -*-
;; Copyright (C) 2024-2026 Geekinney
-
-;; Author: Geekinney (kinneyzhang666@gmail.com)
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 3 of
-;; the License, or (at your option) any later version.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
-;; Executable documentation tests: each assertion reproduces an example
-;; from README.md / README_CN.md (the code blocks are identical across
-;; the two files) and compares the result against the exact output the
-;; docs claim. Run with `make doctest'; the batch process exits
-;; non-zero if any assertion fails. When changing a README example,
-;; update the matching assertion here in the same commit.
+;; Executable counterparts of the public examples in README.md and
+;; README_CN.md. Run with `make doctest'.
;;; Code:
+(require 'cl-lib)
(require 'tp)
-(tp-layer-reset)
-(defvar tp-doctest--fails 0)
-(defvar tp-doctest--total 0)
-(defmacro chk (label expected &rest body)
- `(let* ((exp ,expected)
- (got (condition-case err (progn ,@body) (error (list :ERROR err)))))
- (setq tp-doctest--total (1+ tp-doctest--total))
- (if (equal got exp)
+(defvar tp-doctest--failures 0
+ "Number of failed TP documentation examples.")
+
+(defvar tp-doctest--total 0
+ "Number of executed TP documentation examples.")
+
+(defvar tp-doctest--computed-calls 0
+ "Number of explicit computed-value calls in the doctest.")
+
+(defvar tp-doctest--height 7
+ "Height returned by the doctest's explicit computed value.")
+
+(defmacro tp-doctest--check (label expected &rest body)
+ "Run BODY and compare its value with EXPECTED under LABEL."
+ (declare (indent 2) (debug t))
+ `(let* ((wanted ,expected)
+ (actual
+ (condition-case error-data
+ (progn ,@body)
+ (error (list :unexpected-error error-data)))))
+ (cl-incf tp-doctest--total)
+ (if (equal actual wanted)
(princ (format "PASS %s\n" ,label))
- (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))))
+ (cl-incf tp-doctest--failures)
+ (princ (format "FAIL %s\n expected: %S\n actual: %S\n"
+ ,label wanted actual)))))
-;; ---- Quick Start ----
-(chk-str "QS-set" "#(\"hello\" 0 5 (face bold))" (tp-set "hello" 'face 'bold))
-(chk "QS-layer" 'spotlight
- (progn
- (define-tp spotlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 6 'spotlight)
- (tp-layer-top 1 6))))
-(defvar accent-color "red")
-(chk "QS-reactive" '(:foreground "blue")
- (progn
- (define-tp accent ()
- :props '(face (:foreground $accent-color)))
- (with-temp-buffer
- (insert "Hello")
- (tp-push-layer 1 6 'accent)
- (setq accent-color "blue")
- (tp-at 1 'face))))
+(unwind-protect
+ (progn
+ (tp-doctest--check "static-propertize"
+ '("Hello" (:foreground "white" :background "navy") t nil)
+ (let* ((callback (lambda (_window _object _position) "Open"))
+ (text
+ (tp-propertize
+ "Hello"
+ (list 'face '(:foreground "white" :background "navy")
+ 'help-echo callback 'keymap nil))))
+ (list (substring-no-properties text)
+ (get-text-property 0 'face text)
+ (eq (get-text-property 0 'help-echo text) callback)
+ (get-text-property 0 'keymap text))))
-;; ---- Features ----
-(chk "F-getstyle" '((0 5 wave))
- (let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face (:underline (:color "green" :style wave))) str)
- (tp-get str 'face :underline :style)))
-(chk "F-getmulti" '((0 5 (:color "green" :style wave)))
- (let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face (:underline (:color "green" :style wave))) str)
- (tp-get str 'face :underline '(:color :style))))
-(chk "F-dupface" '((:foreground "red") (:background "green") bold)
- (tp-at 0 'face (tp-set "emacs"
- 'face 'bold
- 'face '(:background "green")
- 'face '(:foreground "red"))))
-(chk "F-override" '(:foreground "yellow")
- (tp-at 0 'face (tp-set "emacs"
- 'face '(:foreground "red")
- 'face '(:foreground "yellow"))))
-(chk "F-search" '((0 5 t) (12 17 t))
- (let ((my-string (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-search my-string 'marker)))
-(chk "F-searchmap" "HELLO world HELLO"
- (let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-search-map #'upcase 'marker tp-any-value my-string)
- (substring-no-properties my-string)))
-(chk "F-teaser-fullname" '(help-echo "John Doe" face (:foreground "purple") tp-name full-name-layer)
- (progn
- (define-tp full-name-layer ()
- :props '(help-echo $full-name face (:foreground $name-color))
- :data '((first-name . "John") (last-name . "Doe") (name-color . "purple"))
- :compute '((full-name (lambda () (concat first-name " " last-name))))
- :watch '((first-name (lambda (new old layer)
- (message "Name changed from %s to %s" old new)))))
- (tp-layer-props 'full-name-layer)))
+ (tp-doctest--check "buffer-apply"
+ '("abcdef" nil italic nil host)
+ (with-temp-buffer
+ (insert "abcdef")
+ (put-text-property 1 7 'category 'host)
+ (tp-apply (current-buffer) 2 5 '(face italic))
+ (list (buffer-string)
+ (get-text-property 1 'face)
+ (get-text-property 2 'face)
+ (get-text-property 5 'face)
+ (get-text-property 3 'category))))
-;; ---- tp-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-doctest--check "declaration-recipe"
+ '((:foreground "cyan" :weight bold) "Open item" nil)
+ (define-tp tp-doctest-link (foreground)
+ `(face (:foreground ,foreground :weight bold)
+ help-echo "Open item"
+ keymap nil))
+ (let ((text (tp-set "item" '(tp-doctest-link "cyan"))))
+ (list (get-text-property 0 'face text)
+ (get-text-property 0 'help-echo text)
+ (get-text-property 0 'keymap text))))
-;; ---- tp-member ----
-(chk "M-member-str" '((face nil) nil)
- (let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face nil) str)
- (list (tp-member 0 'face str)
- (tp-member 0 'display str))))
-(chk "M-member-buf" '(face bold)
- (with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold))
- (tp-member 1 'face)))
+ (tp-doctest--check "explicit-computed-value"
+ '(1 (:height 7))
+ (setq tp-doctest--computed-calls 0)
+ (define-tp tp-doctest-sized ()
+ `(face ,(tp-computed
+ (lambda ()
+ (cl-incf tp-doctest--computed-calls)
+ (list :height tp-doctest--height)))))
+ (let ((text (tp-set "size" 'tp-doctest-sized)))
+ (list tp-doctest--computed-calls
+ (get-text-property 0 'face text))))
-;; ---- tp-lookup ----
-(chk "Q-lookup-direct-nil-absent" '((t nil :text-direct) (nil nil :absent))
- (let ((str (copy-sequence "ab")))
- (put-text-property 0 1 'state nil str)
- (let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct))
- (absent-result (tp-lookup 1 'state :object str :mode :text-direct)))
- (list (list (tp-lookup-result-present-p nil-result)
- (tp-lookup-result-value nil-result)
- (tp-lookup-result-source nil-result))
- (list (tp-lookup-result-present-p absent-result)
- (tp-lookup-result-value absent-result)
- (tp-lookup-result-source absent-result))))))
-(chk "Q-lookup-source-category" '(category-value :category)
- (let* ((str (copy-sequence "a"))
- (category (make-symbol "tp-doc-category")))
- (put category 'state 'category-value)
- (put-text-property 0 1 'category category str)
- (let ((result (tp-lookup 0 'state :object str :mode :text-source)))
- (list (tp-lookup-result-value result)
- (tp-lookup-result-source result)))))
-(chk "Q-lookup-char-source-overlay" '(high :overlay t)
- (with-temp-buffer
- (insert "x")
- (let ((low (make-overlay 1 2))
- (high (make-overlay 1 2)))
- (overlay-put low 'priority 1)
- (overlay-put low 'state 'low)
- (overlay-put high 'priority 10)
- (overlay-put high 'state 'high)
- (let ((result (tp-lookup 1 'state :mode :char-source)))
- (list (tp-lookup-result-value result)
- (tp-lookup-result-source result)
- (eq (tp-lookup-result-overlay result) high))))))
+ (tp-doctest--check "reactive-existing-text"
+ '((:foreground "red") (:foreground "green") 2 nil)
+ (with-temp-buffer
+ (insert "offline")
+ (let* ((online (tp-signal-create nil))
+ (surface
+ (tp-watch
+ (current-buffer) 1 8
+ (lambda ()
+ (list 'face
+ (list :foreground
+ (if (tp-signal-read online)
+ "green"
+ "red"))))))
+ (before (get-text-property 1 'face)))
+ (tp-signal-set online t)
+ (prog1
+ (list before
+ (get-text-property 1 'face)
+ (tp-surface-revision surface)
+ (plist-get (tp-surface-unmount surface)
+ :property-conflicts))
+ (tp-signal-dispose online)))))
-;; ---- tp-remove nested ----
-(chk "R-remove-nested" '(:color "blue")
- (let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue")))))
- (let ((result (tp-remove original 'face :underline '(:style))))
- (tp-at 0 '(face :underline) result))))
+ (tp-doctest--check "retained-content"
+ '("ready" "done" 2 1)
+ (with-temp-buffer
+ (let* ((status (tp-signal-create "ready"))
+ (producer
+ (lambda (context)
+ (let* ((object
+ (tp-object-ensure context nil 'status 'text))
+ (binding
+ (tp-bind object '(readme . status)
+ (lambda () (tp-signal-read status)))))
+ (tp-surface-plan-create
+ :key 'status :kind 'text
+ :text (tp-binding-read binding)
+ :props '(face bold) :capability 'content))))
+ (surface
+ (tp-surface-mount
+ (current-buffer) producer '(:capability content)))
+ (first (buffer-string)))
+ (tp-with-transaction
+ (tp-signal-set status "working")
+ (tp-signal-set status "done"))
+ (prog1
+ (list first (buffer-string)
+ (tp-surface-revision surface)
+ (plist-get (tp-surface-report surface)
+ :text-operations))
+ (tp-surface-unmount surface)
+ (tp-signal-dispose status)))))
-;; ---- tp-forward / tp-backward ----
-(chk "N-fwd-t" 7
- (with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char 1)
- (let ((match (tp-forward 'marker t)))
- (when match (prop-match-beginning match)))))
-(chk "N-fwd-any" '(7 12)
- (with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char 1)
- (let ((match (tp-forward 'marker)))
- (list (prop-match-beginning match) (prop-match-end match)))))
-(chk "N-bwd-t" '(7 12)
- (with-temp-buffer
- (insert "Hello World Test")
- (tp-set 7 12 '(marker t))
- (goto-char (point-max))
- (let ((match (tp-backward 'marker t)))
- (list (prop-match-beginning match) (prop-match-end match)))))
-(chk "N-fwd-heading" 'heading
- (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(type heading))
- (goto-char 1)
- (let ((match (tp-forward 'type 'heading)))
- (when match (prop-match-value match)))))
-(chk "N-fwd-string" '((0 5 t) (12 17 t))
- (let ((my-string (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward 'marker tp-any-value my-string 2)))
+ (tp-doctest--check "retained-noop"
+ '(1 1 nil)
+ (with-temp-buffer
+ (let* ((plan
+ (tp-surface-plan-create
+ :key 'root :kind 'text :text "same"
+ :capability 'content))
+ (surface
+ (tp-surface-mount
+ (current-buffer) plan '(:capability content)))
+ (revision (tp-surface-revision surface)))
+ (set-buffer-modified-p nil)
+ (tp-surface-update surface plan)
+ (prog1
+ (list revision
+ (tp-surface-revision surface)
+ (buffer-modified-p))
+ (tp-surface-unmount surface)))))
-;; ---- tp-forward-do / tp-search-map examples ----
-(chk "DO-fdo" "hello world HELLO"
- (let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward-do #'upcase 'marker tp-any-value my-string 2)
- (substring-no-properties my-string)))
-(chk "DO-bdo" "HELLO world hello"
- (let ((my-string (copy-sequence "hello world hello")))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-backward-do #'upcase 'marker tp-any-value my-string 2)
- (substring-no-properties my-string)))
-(chk "DO-fdo-pos" '("hello world HELLO" (12 17))
- (let ((my-string (copy-sequence "hello world hello"))
- (match-info nil))
- (tp-set 0 5 '(marker t) my-string)
- (tp-set 12 17 '(marker t) my-string)
- (tp-forward-do
- (lambda (text start end)
- (setq match-info (list start end))
- (upcase text))
- 'marker tp-any-value my-string 2)
- (list (substring-no-properties my-string) match-info)))
-(chk "SM-idx" '("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11)))
- (let ((my-string (copy-sequence "aaa bbb ccc"))
- (positions nil))
- (tp-set 0 3 '(marker t) my-string)
- (tp-set 4 7 '(marker t) my-string)
- (tp-set 8 11 '(marker t) my-string)
- (tp-search-map
- (lambda (text start end idx)
- (push (list idx start end) positions)
- (upcase text))
- 'marker tp-any-value my-string)
- (list (substring-no-properties my-string) (nreverse positions))))
+ (tp-doctest--check "materialize-is-ephemeral"
+ '("42" nil nil 0)
+ (let ((signal (tp-signal-create 42)) object binding)
+ (let ((text
+ (tp-surface-materialize-string
+ (lambda (context)
+ (setq object
+ (tp-object-ensure context nil 'value 'text)
+ binding
+ (tp-bind object '(readme . value)
+ (lambda () (tp-signal-read signal))))
+ (tp-surface-plan-create
+ :key 'value :kind 'text
+ :text (number-to-string (tp-binding-read binding))
+ :capability 'content)))))
+ (prog1
+ (list text
+ (tp-object-live-p object)
+ (tp-binding-live-p binding)
+ (tp-signal-subscriber-count signal))
+ (tp-signal-dispose signal))))))
+ (tp-layer-reset)
+ (tp-reactive-reset))
-;; ---- Layer definitions ----
-(defvar my-color)
-(chk "L-format3" '((:foreground "blue") "status: active")
- (progn
- (tp-layer-reset)
- (define-tp my-reactive-layer ()
- :props '(face (:foreground $my-color) help-echo $status-note)
- :data '((my-color . "red") (status . "active"))
- :compute '((status-note (lambda () (concat "status: " status))))
- :watch '((my-color (lambda (new old layer) (message "Color changed!"))))
- :transform (lambda (text) (upcase text)))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'my-reactive-layer)
- (setq my-color "blue")
- (list (tp-at 1 'face) (tp-at 1 'help-echo)))))
-(chk "L-statuscolors" 3
- (progn
- (tp-layer-reset)
- (define-tp highlight ()
- '(face (:background "yellow" :foreground "black")))
- (define-tp error ()
- '(face (:background "red" :foreground "white")))
- (define-tp info ()
- '(face (:background "blue" :foreground "white")))
- (define-tps status-colors ()
- 'highlight 'error 'info)
- (length (tp-group-props 'status-colors))))
-(chk "L-moon" '(display "🌕")
- (progn
- (tp-layer-reset)
- (define-tps moon-phases ()
- '("new" . (display "🌑"))
- '("waxing-crescent" . (display "🌒"))
- '("first-quarter" . (display "🌓"))
- '("full" . (display "🌕")))
- (tp-layer-props 'moon-phases-full)))
-;; Compared per property (print order of the top-level plist varies
-;; across Emacs versions; the tp-layers stack order itself is stable).
-(chk "L-paramgroup"
- '((:foreground "orange")
- tp-test-l1
- ((face (:foreground "red") tp-name tp-test-l2)
- (face (:background "green") tp-name tp-test-l3)))
- (progn
- (tp-layer-reset)
- (define-tp tp-test-l1 (color)
- `(face (:foreground ,color)))
- (define-tp tp-test-l2 (color)
- `(face (:foreground ,color)))
- (define-tp tp-test-l3 ()
- '(face (:background "green")))
- (define-tps tp-test-group1 (color)
- `(tp-test-l1 ,color)
- '(tp-test-l2 "red")
- 'tp-test-l3)
- (let ((r (tp-set "emacs" 'tp-test-group1 "orange")))
- (list (tp-at 0 'face r)
- (tp-at 0 'tp-name r)
- (tp-at 0 'tp-layers r)))))
-(chk "L-props" '((face bold help-echo "tip")
- (face bold help-echo "tip" tp-name my-layer))
- (progn
- (tp-layer-reset)
- (define-tp my-layer ()
- '(face bold help-echo "tip"))
- (list (tp-layer-props 'my-layer)
- (tp-layer-props 'my-layer t))))
-(chk "L-groupprops" 2
- (progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tps my-group ()
- 'layer1 'layer2)
- (length (tp-group-props 'my-group))))
-(chk "L-undeflayer" nil
- (progn
- (tp-layer-reset)
- (define-tp temp-layer () '(face bold))
- (tp-undefine-layer 'temp-layer)
- (tp-layer-props 'temp-layer)))
-(chk "L-undefgroup" nil
- (progn
- (tp-layer-reset)
- (define-tp l1 () '(face bold))
- (define-tps my-group ()
- 'l1)
- (tp-undefine-group 'my-group)
- (assoc 'my-group tp-layer-groups)))
-(chk "L-reset" '(nil nil)
- (progn
- (define-tp test-layer () '(face bold))
- (tp-layer-reset)
- (list tp-layer-alist tp-layer-groups)))
-(defvar my-reactive-color "red")
-(chk "L-reactivereset" '(face (:foreground "red"))
- (progn
- (tp-layer-reset)
- (define-tp reactive-layer ()
- :props '(face (:foreground $my-reactive-color)))
- (tp-reactive-reset)
- (tp-layer-props 'reactive-layer)))
-
-;; ---- tp-put-layer / tp-push-layer ----
-(chk "P-base" 'base
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-at 1 'tp-name))))
-(chk "P-idx1" 2
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-put-layer 1 10 'highlight 1)
- (tp-layer-count 1 10))))
-(chk "P-bottom" 'base
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp info () '(face (:foreground "blue")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 'base 0)
- (tp-put-layer 1 10 'info -1)
- (tp-layer-top 1 10))))
-(chk "P-inline" '(bold "tip")
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(face bold help-echo "tip") 0)
- (list (tp-at 1 'face) (tp-at 1 'help-echo))))
-(chk "P-names" '(bold (layer-a layer-b))
- (progn
- (tp-layer-reset)
- (define-tp layer-a () '(face bold))
- (define-tp layer-b () '(face italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(layer-a layer-b) 0)
- (list (tp-at 1 'face) (tp-layer-list 1 10)))))
-(chk "P-param" '(:foreground "red")
- (progn
- (tp-layer-reset)
- (define-tp tp-color (color)
- `(face (:foreground ,color)))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(tp-color "red") 0)
- (tp-at 1 'face))))
-(chk "P-stack" '(:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2)
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (list :face (tp-at 1 'face)
- :top (tp-layer-top 1 10)
- :layers (tp-layer-list 1 10)
- :hidden (length (tp-at 1 'tp-layers))))))
-(chk "P-transaction-ok" '(ok (1 . 4) bold)
- (progn
- (tp-layer-reset)
- (define-tp tx-base () '(face bold))
- (define-tp tx-temp () '(face italic))
- (with-temp-buffer
- (insert "abcd")
- (let ((result
- (tp-layer-transaction
- 1 4 (current-buffer)
- (lambda () (tp-put-layer 1 3 'tx-base 0)))))
- (list (plist-get result :status)
- (plist-get result :range)
- (tp-at 1 'face))))))
-
-;; ---- Utilities ----
-(chk "U-intervals" '((0 5 (face bold)) (5 6 nil) (6 11 (face italic)))
- (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-intervals 1 12)))
-(chk "U-intervalsmap" '((0 5 bold) (5 6 nil) (6 11 italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-intervals-map
- (lambda (start end props belows)
- (ignore belows)
- (list start end (plist-get props 'face)))
- 1 12)))
-(chk "U-plist" '(help-echo "Tip" face italic)
- (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold help-echo "Tip"))
- (tp-set 7 12 '(face italic))
- (tp-plist 1 12)))
-(chk "U-emptyp" '(t nil)
- (let* ((str "text")
- (new (tp-set str 'face 'bold)))
- (list (tp-empty-p str) (tp-empty-p new))))
-(chk "U-emptyp2" t (tp-empty-p "plain text"))
-(chk-str "U-popbuffer" "#(\"Important\" 0 9 (face (:foreground \"red\" :weight bold)))"
- (progn
- (tp-pop-to-buffer "*tp-demo*"
- (insert (tp-set "Important" 'face '(:foreground "red" :weight bold))
- " message\n"))
- (with-current-buffer "*tp-demo*"
- (buffer-substring 1 10))))
-(chk "U-parsecolor1" "red" (tp-parse-color "red"))
-(chk "U-parsecolor2" t
- (and (member (tp-parse-color '("white" . "black")) '("white" "black")) t))
-
-;; ---- Practical examples ----
-(chk "X-taskstatus" 3
- (progn
- (tp-layer-reset)
- (define-tp status-todo () '(face (:foreground "gray")))
- (define-tp status-progress () '(face (:foreground "yellow")))
- (define-tp status-done () '(face (:foreground "green")))
- (define-tps task-status () 'status-todo 'status-progress 'status-done)
- (length (tp-group-props 'task-status))))
-(chk "X-temphl" '(face (:background "yellow"))
- (progn
- (tp-layer-reset)
- (define-tp temp-highlight ()
- '(face (:background "yellow")))
- (tp-layer-props 'temp-highlight)))
-(chk "X-synhl" 'code-error
- (progn
- (tp-layer-reset)
- (define-tp code-base ()
- '(face font-lock-keyword-face))
- (define-tp code-error ()
- '(face (:underline (:color "red" :style wave))
- help-echo "Syntax error"))
- (define-tp code-debug ()
- '(face (:background "dark blue")))
- (with-temp-buffer
- (insert (make-string 100 ?x))
- (tp-push-layer 1 100 'code-base)
- (tp-push-layer 50 60 'code-error)
- (tp-layer-top 50 60))))
-
-;; ---- Reactive chapter ----
-(defvar status-color nil)
-(chk "RC-watch" '("Layer monitored-layer: color changed from nil to red"
- "Layer monitored-layer: color changed from red to green")
- (let ((msgs nil))
- (tp-layer-reset)
- (cl-letf* (((symbol-function 'message)
- (lambda (fmt &rest args)
- (when fmt (push (apply #'format fmt args) msgs))
- nil)))
- (define-tp monitored-layer ()
- :props '(face (:foreground $status-color))
- :watch '((status-color
- (lambda (new-val old-val layer-name)
- (message "Layer %s: color changed from %s to %s"
- layer-name old-val new-val)))))
- (setq status-color "red")
- (setq status-color "green"))
- (nreverse msgs)))
-(chk "RC-groups" '(face (:foreground "green") tp-name status-indicators-success)
- (progn
- (tp-layer-reset)
- (define-tps status-indicators ()
- '("success" :props (face (:foreground $success-color))
- :data ((success-color . "green")))
- '("warning" :props (face (:foreground $warning-color))
- :data ((warning-color . "orange")))
- '("error" :props (face (:foreground $error-color))
- :data ((error-color . "red"))))
- (tp-layer-props 'status-indicators-success)))
-(defvar fg-color)
-(defvar bg-color)
-(chk "RC-batch" '(:foreground "red" :background "blue")
- (progn
- (tp-layer-reset)
- (define-tp themed-text ()
- :props '(face (:foreground $fg-color :background $bg-color))
- :data '((fg-color . "white") (bg-color . "black")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 12 'themed-text)
- (setq fg-color "yellow")
- (setq bg-color "navy")
- (tp-with-batch-updates
- (setq fg-color "red")
- (setq bg-color "blue"))
- (tp-at 1 'face))))
-(defvar my-face-color "blue")
-(chk "RC-anon" '((:foreground "blue") (:foreground "red"))
- (progn
- (tp-layer-reset)
- (setq my-face-color "blue")
- (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 10 '(face (:foreground $my-face-color)))
- (let ((before (tp-at 1 'face)))
- (setq my-face-color "red")
- (list before (tp-at 1 'face))))))
-
-;; ---- Theme example (as in the docs) ----
-(declare-function switch-to-light-theme "tp-doctest")
-(defvar theme-fg "white")
-(defvar theme-bg "black")
-(defvar theme-accent "cyan")
-(chk "RC-theme" '(:before ((:foreground "cyan" :weight bold)
- (:foreground "white" :background "black"))
- :after ((:foreground "blue" :weight bold)
- (:foreground "black" :background "white")))
- (progn
- (tp-layer-reset)
- (setq theme-fg "white" theme-bg "black" theme-accent "cyan")
- (define-tp code-text ()
- :props '(face (:foreground $theme-fg :background $theme-bg)))
- (define-tp code-keyword ()
- :props '(face (:foreground $theme-accent :weight bold)))
- (defun switch-to-light-theme ()
- (interactive)
- (setq theme-fg "black")
- (setq theme-bg "white")
- (setq theme-accent "blue"))
- (defun switch-to-dark-theme ()
- (interactive)
- (setq theme-fg "white")
- (setq theme-bg "black")
- (setq theme-accent "cyan"))
- (with-temp-buffer
- (insert "(defun greet () (let (x) x))")
- (tp-set (point-min) (point-max) 'code-text)
- (tp-match-set '("defun" "defvar" "let" "if" "when") 'code-keyword)
- (let ((before (list (tp-at 2 'face) (tp-at 10 'face))))
- (switch-to-light-theme)
- (list :before before
- :after (list (tp-at 2 'face) (tp-at 10 'face)))))))
-
-;; ---- Regexp and string-form examples ----
-(tp-layer-reset)
-(chk "X-buffer-return" '(1 . 10)
- (let ((my-buffer (generate-new-buffer "*test*")))
- (with-current-buffer my-buffer (insert "Hello World"))
- (prog1 (tp-set 1 10 '(face italic) my-buffer)
- (kill-buffer my-buffer))))
-(chk-str "X-regexp-case-fold" "#(\"Hello WORLD\" 0 5 (face bold) 6 11 (face bold))"
- (tp-regexp-set "[A-Z]+" '(face bold) "Hello WORLD"))
-(chk-str "X-regexp-multi" "#(\"abc 123 XYZ\" 0 3 (face bold) 4 7 (face bold) 8 11 (face bold))"
- (tp-regexp-set '("[0-9]+" "[A-Z]+") '(face bold) "abc 123 XYZ"))
-(chk "X-regexp-reset-new-string" '((face italic) (help-echo "original"))
- (let ((str (copy-sequence "abc 123 def")))
- (tp-set 4 7 '(help-echo "original") str)
- (let ((result (tp-regexp-reset "[0-9]+" '(face italic) str)))
- (list (tp-at 4 result) (tp-at 4 str)))))
-(chk "X-regexp-add-new-string" '((face italic help-echo "number") (help-echo "number"))
- (let ((str (copy-sequence "abc 123 def")))
- (tp-set 4 7 '(help-echo "number") str)
- (let ((result (tp-regexp-add "[0-9]+" '(face italic) str)))
- (list (tp-at 4 result) (tp-at 4 str)))))
-(chk "X-match-per-pattern-order" '((7 . 12) (1 . 6) (14 . 19))
- (with-temp-buffer
- (insert "Hello world, Hello again")
- (tp-match-set '("world" "Hello") '(face bold))))
-(chk "X-do-shortfall-all-or-nothing" '(1 "hello world")
- (let ((str (copy-sequence "hello world")))
- (tp-set 0 5 '(marker t) str)
- (list (tp-forward-do #'upcase 'marker tp-any-value str 3)
- (substring-no-properties str))))
-
-;; ---- 0.3.0: search bounds and SUBEXP ----
-;; Compared via tp-search / tp-at accessors, not prin1 output, so the
-;; property print order difference between Emacs 28 and 29+ cannot bite.
-(chk "V3-match-bounds" '((10 . 14))
- (with-temp-buffer
- (insert "TODO one TODO two")
- (tp-match-set "TODO" '(face warning) nil 5 18)))
-(chk "V3-subexp" '(((8 10 bold) (13 14 bold)) ((0 3 bold)))
- (list (tp-search (tp-regexp-set "\\([0-9]+\\)px" '(face bold)
- "margin: 10px 4px" nil nil 1)
- 'face)
- ;; group 1 does not participate in the "bar" match
- (tp-search (tp-regexp-set "\\(foo\\)\\|bar" '(face bold)
- "foo bar" nil nil 1)
- 'face)))
-(chk "V3-subexp-out-of-range"
- '(:ERROR (error "Regexp \"[0-9]+\" has no group 2"))
- (tp-regexp-set "[0-9]+" '(face bold) "abc 123" nil nil 2))
-(chk "V3-regexp-bounds-and-reversed" '(((1 3 bold)) ((1 3 bold)))
- (list (tp-search (tp-regexp-set "a+" '(face bold) "aaaa" 1 3) 'face)
- (tp-search (tp-regexp-set "a+" '(face bold) "aaaa" 3 1) 'face)))
-
-;; ---- 0.3.0: PREDICATE / NOT-CURRENT ----
-(chk "V3-predicate" '((3 6) ((6 11 20)))
- (list (with-temp-buffer
- (insert "abcdef")
- (tp-set 1 3 '(size 10))
- (tp-set 3 6 '(size 20))
- (goto-char 1)
- (let ((match (tp-forward 'size 15 nil 1
- (lambda (target v) (and v (> v target))))))
- (list (prop-match-beginning match) (prop-match-end match))))
- (let ((str (copy-sequence "hello world")))
- (tp-set 0 5 '(size 10) str)
- (tp-set 6 11 '(size 20) str)
- (tp-forward 'size 15 str 2
- (lambda (target v) (and v (> v target)))))))
-(chk "V3-not-current" '(2 5)
- (with-temp-buffer
- (insert "one two")
- (tp-set 1 4 '(mark t))
- (tp-set 5 8 '(mark t))
- (let (a b)
- (goto-char 2)
- (setq a (prop-match-beginning (tp-forward 'mark t)))
- (goto-char 2)
- (setq b (prop-match-beginning (tp-forward 'mark t nil 1 nil t)))
- (list a b))))
-
-;; ---- 0.3.0: multi-argument parameterized layers ----
-(chk "V3-multiarg-specs" '((:foreground "red" :background "blue")
- ((:foreground "red" :background "blue") "tip")
- (:foreground "white" :background "black"))
- (progn
- (tp-layer-reset)
- (define-tp tp-colors (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (list (tp-at 0 'face (tp-set "hello" 'tp-colors "red" "blue"))
- (let ((str (copy-sequence "hello")))
- (tp-set 0 5 '(tp-colors ("red" "blue") help-echo "tip") str)
- (list (tp-at 0 'face str) (tp-at 0 'help-echo str)))
- (with-temp-buffer
- (insert "Hello World")
- (tp-put-layer 1 10 '(tp-colors "white" "black") 0)
- (tp-at 1 'face)))))
-(chk "V3-multiarg-arity-error"
- '(:ERROR (error "tp layer tp-colors takes 2 argument(s), got 1"))
- (tp-set "hello" 'tp-colors "red"))
-(chk "V3-args-introspection"
- '((face (:foreground "red" :background "blue"))
- (fg bg)
- ((face (:foreground "white" :background "black")) (face bold)))
- (progn
- (define-tps tp-badge (fg bg)
- `(tp-colors ,fg ,bg)
- '(face bold))
- (list (tp-layer-props-with-args 'tp-colors '("red" "blue"))
- (tp-layer-arglist 'tp-colors)
- (tp-group-props-with-args 'tp-badge '("white" "black")))))
-
-;; ---- 0.3.0: layer visibility ----
-(chk "V3-hide-reveals-below"
- '(:visible base :face default :count 2 :layers (highlight base))
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (tp-hide-layer 1 10 'highlight)
- (list :visible (tp-at 1 'tp-name)
- :face (tp-at 1 'face)
- :count (tp-layer-count 1 10)
- :layers (tp-layer-list 1 10)))))
-(chk "V3-hide-all-bare-and-show" '((:face nil :count 2) (:background "yellow"))
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (tp-hide-layer 1 10 'highlight)
- (tp-hide-layer 1 10 'base)
- (let ((all-hidden (list :face (tp-at 1 'face)
- :count (tp-layer-count 1 10))))
- (tp-show-layer 1 10 'highlight)
- (list all-hidden (tp-at 1 'face))))))
-(chk "V3-hide-run-counts" '(1 0 0)
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (list (tp-hide-layer 1 10 'base)
- (tp-hide-layer 1 10 'base)
- (tp-hide-layer 1 10 'nonexistent)))))
-(chk "V3-merge-excludes-hidden" '(:face bold :help nil :name merged)
- (progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(help-echo "tip"))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-hide-layer 1 10 'layer2)
- (tp-merge-layers 1 10 'merged '(layer1 layer2))
- (list :face (tp-at 1 'face)
- :help (tp-at 1 'help-echo)
- :name (tp-at 1 'tp-name)))))
-(chk "V3-flatten-discards-hidden" '(default flat)
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (tp-hide-layer 1 10 'highlight)
- (tp-flatten-layers 1 10 'flat)
- (list (tp-at 1 'face) (tp-at 1 'tp-name)))))
-
-;; ---- 0.3.0: movement additions and stack introspection ----
-(chk "V3-lower-layer" '(layer2 (layer2 layer3 layer1))
- (progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-push-layer 1 10 'layer3)
- (tp-lower-layer 1 10 'layer3 1)
- (list (tp-layer-top 1 10) (tp-layer-list 1 10)))))
-(chk "V3-rotate-canonical" '((layer1 layer3 layer2) (layer1 layer3 layer2))
- (progn
- (tp-layer-reset)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (list (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-push-layer 1 10 'layer3)
- (tp-rotate-layer 1 10 'up)
- (tp-layer-list 1 10))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'layer1)
- (tp-push-layer 1 10 'layer2)
- (tp-push-layer 1 10 'layer3)
- (tp-rotate-layer 1 10 'down 2)
- (tp-layer-list 1 10)))))
-;; Compared via assq/plist-get per layer: the top layer's PROPS come from
-;; the direct text properties, whose plist order varies on Emacs 28.
-(chk "V3-layer-stack-at" '(((highlight base) (:background "yellow") default nil)
- ((highlight base) (:background "yellow") default t)
- nil)
- (progn
- (tp-layer-reset)
- (define-tp base () '(face default))
- (define-tp highlight () '(face (:background "yellow")))
- (with-temp-buffer
- (insert "Hello World")
- (tp-push-layer 1 10 'base)
- (tp-push-layer 1 10 'highlight)
- (let* ((probe (lambda ()
- (let ((stack (tp-layer-stack-at 1)))
- (list (mapcar #'car stack)
- (plist-get (cdr (assq 'highlight stack)) 'face)
- (plist-get (cdr (assq 'base stack)) 'face)
- (plist-get (cdr (assq 'highlight stack))
- 'tp-hidden)))))
- (visible (funcall probe)))
- (tp-hide-layer 1 10 'highlight)
- (list visible
- (funcall probe)
- (with-temp-buffer (insert "Hello") (tp-layer-stack-at 1)))))))
-(chk "V3-put-push-noerror" '(nil nil)
- (with-temp-buffer
- (insert "Hello World")
- (list (tp-put-layer 1 10 'no-such-layer 0 nil t)
- (tp-push-layer 1 10 'no-such-layer nil t))))
-
-;; ---- 0.3.0: reactive layer-buffer registry and lifecycle ----
-(defvar reg-color "red")
-(chk "V3-registry-and-track" '(unknown t (reg-layer))
- (progn
- (tp-layer-reset)
- (define-tp reg-layer ()
- :props '(face (:foreground $reg-color)))
- (let ((before (tp-reactive-layer-buffers 'reg-layer)))
- (with-temp-buffer
- (insert "Hello")
- (tp-push-layer 1 6 'reg-layer)
- (let ((registered (equal (tp-reactive-layer-buffers 'reg-layer)
- (list (current-buffer)))))
- (list before
- registered
- (let ((s (tp-set "hello" 'reg-layer)))
- (with-temp-buffer
- (insert s)
- (tp-reactive-track-buffer)))))))))
-(defvar tmp-color "green")
-(chk "V3-gc-anonymous" '(1 nil nil)
- (progn
- (tp-reactive-reset)
- (tp-layer-reset)
- (let ((buf (generate-new-buffer "*gc-demo*")))
- (with-current-buffer buf
- (insert "Hello")
- (tp-set 1 6 '(face (:foreground $tmp-color))))
- (kill-buffer buf)
- (let ((collected (tp-gc-anonymous-layers)))
- (list (length collected)
- (tp-layer-props (car collected))
- ;; string-only layers stay `unknown' and are kept
- (let ((s (tp-set "hello" '(face (:foreground $tmp-color)))))
- (ignore s)
- (tp-gc-anonymous-layers)))))))
-
-;; ---- 0.3.0: minimal-diff tp-text re-rendering ----
-(defvar counter-val "0")
-(chk "V3-tp-text-minimal-diff" '("count: 9 items" 105 10)
- (progn
- (tp-layer-reset)
- (setq counter-val "0")
- (define-tp counter-label ()
- :props '(tp-text $counter-val))
- (with-temp-buffer
- (insert "count: 0 items")
- (tp-set 8 9 'counter-label)
- (let ((m (copy-marker 10))) ; marker on the "i" of "items"
- (setq counter-val "9")
- (list (buffer-substring-no-properties 1 (point-max))
- (char-after m)
- (marker-position m))))))
-(chk "V3-tp-text-noop-unmodified" nil
- (with-temp-buffer
- (insert "count: 9 items")
- (tp-set 8 9 'counter-label)
- (set-buffer-modified-p nil)
- (setq counter-val "9")
- (buffer-modified-p)))
-
-;; ---- 0.3.0: ABSOLUTE coordinates and palette primaries ----
-(chk "V3-intervals-absolute"
- '(((1 6 (face bold)) (6 7 nil) (7 12 (face italic))) "bold text")
- (list (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-intervals 1 12 nil t))
- (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (dolist (iv (tp-intervals 1 12 nil t))
- (when (eq (plist-get (nth 2 iv) 'face) 'bold)
- (tp-add (nth 0 iv) (nth 1 iv) '(help-echo "bold text"))))
- (tp-at 1 'help-echo))))
-(chk "V3-intervals-map-absolute" '((1 6 bold) (6 7 nil) (7 12 italic))
- (with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-intervals-map
- (lambda (start end props belows)
- (ignore belows)
- (list start end (plist-get props 'face)))
- 1 12 nil t)))
-;; The resolved color depends on the frame's light/dark mode, like the
-;; U-parsecolor2 assertion above.
-(chk "V3-palette-primaries" '(t nil (t t t nil))
- (list (and (member (tp-palette-color 'info :fg)
- '("#0969da" "#58a6ff"))
- t)
- (tp-palette-color 'no-such-palette :fg)
- (list (tp-palette-has-p 'info)
- (tp-palette-has-p 'info :fg)
- (tp-palette-has-p 'info :border)
- (tp-palette-has-p 'no-such-palette))))
-
-(princ (format "\nTOTAL: %d FAILS: %d\n" tp-doctest--total tp-doctest--fails))
-(when (> tp-doctest--fails 0) (kill-emacs 1))
+(princ (format "\nTOTAL: %d FAILURES: %d\n"
+ tp-doctest--total tp-doctest--failures))
+(when (> tp-doctest--failures 0)
+ (kill-emacs 1))
+(provide 'tp-doctest)
;;; tp-doctest.el ends here
diff --git a/tests/tp-examples-tests.el b/tests/tp-examples-tests.el
new file mode 100644
index 0000000..fef11b7
--- /dev/null
+++ b/tests/tp-examples-tests.el
@@ -0,0 +1,247 @@
+;;; tp-examples-tests.el --- Tests for public TP examples -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;;; Commentary:
+
+;; Exercises the new examples in `examples/` through public TP entry points.
+
+;;; Code:
+
+(require 'ert)
+(require 'tp)
+
+(require 'static-properties)
+(require 'reactive-status)
+(require 'retained-dashboard)
+(require 'diagnostic-decoration)
+
+(defmacro tp-examples-tests--with-temp-buffer (name &rest body)
+ "Run BODY in a temporary isolated buffer.
+
+NAME is the buffer name to create."
+ (declare (indent 1) (debug t))
+ `(let ((buffer (generate-new-buffer ,name)))
+ (unwind-protect
+ (progn ,@body)
+ (when (buffer-live-p buffer)
+ (kill-buffer buffer)))))
+
+(defun tp-examples-tests--buffer-substring (buffer)
+ "Return full buffer text from BUFFER as plain string."
+ (with-current-buffer buffer
+ (buffer-substring-no-properties (point-min) (point-max))))
+
+(defun tp-examples-tests--label-property (state label property)
+ "Return PROPERTY at LABEL start in STATE buffer."
+ (let ((buffer (plist-get state :buffer)))
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char (point-min))
+ (when (search-forward label nil t)
+ (get-text-property (match-beginning 0) property))))))
+
+(ert-deftest tp-examples-test-static-properties-direct-output-observable ()
+ (let ((styled (tp-example-static-properties-format-title "Release")))
+ (should (equal (substring-no-properties styled) (format "%-28s" "Release")))
+ (should (equal (get-text-property 0 'face styled)
+ '((:weight bold)
+ (:foreground "white" :background "#3c4656"))))
+ (should (equal (get-text-property 0 'keymap styled)
+ tp-example-static-properties-keymap))
+ (should (eq (get-text-property 0 'help-echo styled)
+ #'tp-example-static-properties-help))
+ (should (plist-member (text-properties-at 0 styled) 'mouse-face))
+ (should-not (get-text-property 0 'mouse-face styled)))
+
+ (tp-examples-tests--with-temp-buffer " *tp-static-range*"
+ (with-current-buffer buffer
+ (insert "hello world")
+ (should (equal (tp-example-static-properties-mark-range buffer 1 6 "#dff0") '(1 . 6)))
+ (should (equal (tp-at 1 'face buffer) '(:background "#dff0")))
+ (should (equal (tp-at 1 'help-echo buffer) "Static range marker")))))
+
+(ert-deftest tp-examples-test-reactive-status-noop-and-sparse-dependency ()
+ (tp-examples-tests--with-temp-buffer " *tp-reactive-status*"
+ (let* ((state (tp-example-reactive-status-mount buffer))
+ (surface (plist-get state :surface)))
+ (unwind-protect
+ (progn
+ (should (equal (tp-example-reactive-status-color state) "ForestGreen"))
+ (should (equal (tp-at 1 'help-echo buffer) "status=ready"))
+ (tp-example-reactive-status-clear-reactive-counters)
+ (let ((before-revision (tp-surface-revision surface)))
+ (tp-example-reactive-status-poke state 10)
+ (should (= (tp-surface-revision surface) before-revision))
+ (should (= (plist-get (tp-reactive-counters) :invalidated) 0))
+ (should (= (plist-get (tp-reactive-counters) :recomputed) 0))
+ (tp-example-reactive-status-set state 'error)
+ (should (= (tp-surface-revision surface) (+ before-revision 1)))
+ (should (equal (tp-example-reactive-status-color state) "IndianRed"))
+ (should (equal (tp-at 1 'help-echo buffer) "status=error"))
+ (should (= (plist-get (tp-example-reactive-status-watch-report state) :new-revision)
+ (+ before-revision 1)))
+
+ (tp-example-reactive-status-clear-reactive-counters)
+ (tp-example-reactive-status-set state 'error)
+ (should (= (tp-surface-revision surface) (+ before-revision 1)))
+ (should (= (plist-get (tp-reactive-counters) :invalidated) 0))
+ (should (= (plist-get (tp-reactive-counters) :recomputed) 0))
+ (tp-example-reactive-status-poke state 11)
+ (should (= (tp-surface-revision surface) (+ before-revision 1)))
+ (should (= (plist-get (tp-reactive-counters) :invalidated) 0))
+ (should (= (plist-get (tp-reactive-counters) :recomputed) 0))))
+ (tp-example-reactive-status-dispose state)
+ (should-not (tp-surface-live-p surface))
+ (should-not (tp-surface-live-p (plist-get state :surface)))
+ (should-not (tp-signal-live-p (plist-get state :status)))
+ (should-not (tp-signal-live-p (plist-get state :noise)))))))
+
+(ert-deftest tp-examples-test-reactive-content-dependencies-and-batch ()
+ (tp-examples-tests--with-temp-buffer " *tp-reactive-content*"
+ (let* ((state (tp-example-reactive-content-mount buffer))
+ (surface (plist-get state :surface)))
+ (unwind-protect
+ (progn
+ (should (equal (tp-example-reactive-content-text state)
+ "primary:ready"))
+
+ (let ((revision (tp-surface-revision surface)))
+ (tp-reactive-reset-counters)
+ (tp-example-reactive-content-set-fallback state "standby")
+ (should (= (tp-surface-revision surface) revision))
+ (should (= (plist-get (tp-reactive-counters) :invalidated) 0)))
+
+ (let ((revision (tp-surface-revision surface)))
+ (tp-example-reactive-content-batch-primary
+ state (mapcar (lambda (number) (format "step-%d" number))
+ (number-sequence 1 100)))
+ (should (= (tp-surface-revision surface) (1+ revision)))
+ (should (equal (tp-example-reactive-content-text state)
+ "primary:step-100")))
+
+ (tp-example-reactive-content-set-enabled state nil)
+ (should (equal (tp-example-reactive-content-text state)
+ "fallback:standby"))
+ (let ((revision (tp-surface-revision surface)))
+ (tp-example-reactive-content-set-primary state "ignored")
+ (should (= (tp-surface-revision surface) revision)))
+ (tp-example-reactive-content-set-fallback state "offline")
+ (should (equal (tp-example-reactive-content-text state)
+ "fallback:offline")))
+ (tp-example-reactive-content-dispose state)
+ (should-not (tp-surface-live-p surface))
+ (dolist (key '(:enabled :primary :fallback))
+ (should-not (tp-signal-live-p (plist-get state key))))))))
+
+(ert-deftest tp-examples-test-retained-dashboard-identity-theme-and-failure-recovery ()
+ (tp-examples-tests--with-temp-buffer " *tp-retained-dashboard*"
+ (let* ((dashboard (tp-example-retained-dashboard-mount buffer))
+ (surface (plist-get dashboard :surface))
+ (alpha-first-handle (tp-example-retained-dashboard-entry-handle dashboard 'alpha))
+ (gamma-handle (tp-example-retained-dashboard-entry-handle dashboard 'gamma))
+ (report-before (tp-example-retained-dashboard-report dashboard)))
+ (unwind-protect
+ (progn
+ (should (eq alpha-first-handle (tp-example-retained-dashboard-entry-handle dashboard 'alpha)))
+ (should (eq gamma-handle (tp-example-retained-dashboard-entry-handle dashboard 'gamma)))
+ (should (consp (tp-examples-tests--label-property dashboard " Alpha " 'keymap)))
+ (should (equal (tp-examples-tests--label-property dashboard " Alpha " 'button)
+ "entry:alpha"))
+
+ (let* ((theme-report (tp-example-retained-dashboard-set-theme dashboard 'dark))
+ (theme-revision (plist-get theme-report :new-revision)))
+ (should (= theme-revision (+ (plist-get report-before :new-revision) 1)))
+ (should (equal (tp-examples-tests--label-property dashboard " Alpha " 'face)
+ '(:weight bold :foreground "#83a598"))))
+
+ (let* ((revision-before-update (tp-surface-revision surface))
+ (update-report
+ (tp-example-retained-dashboard-update
+ dashboard
+ '((:id gamma :label "Gamma")
+ (:id alpha :label "Alpha" :active t)
+ (:id delta :label "Delta")))))
+ (should (eq gamma-handle
+ (tp-example-retained-dashboard-entry-handle
+ dashboard 'gamma)))
+ (should (eq alpha-first-handle
+ (tp-example-retained-dashboard-entry-handle
+ dashboard 'alpha)))
+ (should-not (tp-example-retained-dashboard-entry-handle
+ dashboard 'beta))
+ (should (string-match-p
+ "Gamma" (tp-examples-tests--buffer-substring buffer)))
+ (should (string-match-p
+ "Delta" (tp-examples-tests--buffer-substring buffer)))
+ (should (> (plist-get update-report :new-revision)
+ revision-before-update)))
+
+ (let ((committed-text
+ (tp-examples-tests--buffer-substring buffer))
+ (committed-revision (tp-surface-revision surface)))
+ (should-error
+ (tp-example-retained-dashboard-update
+ dashboard
+ '((:id forced :label "Boom" :force-failure t))))
+ (should (equal (tp-examples-tests--buffer-substring buffer)
+ committed-text))
+ (should (= (tp-surface-revision surface) committed-revision))
+ (should (eq (tp-example-retained-dashboard-entry-handle
+ dashboard 'alpha)
+ alpha-first-handle))))
+ (let ((report (tp-example-retained-dashboard-remove dashboard)))
+ (should (plist-get report :unmounted))
+ (should-not (tp-surface-live-p surface))
+ (should-not
+ (tp-signal-live-p (plist-get (plist-get dashboard :state)
+ :theme))))))))
+
+(ert-deftest tp-examples-test-diagnostic-decoration-conflict-rebase-cleanup ()
+ (tp-examples-tests--with-temp-buffer " *tp-diagnostic-decoration*"
+ (let* ((state (tp-example-diagnostic-decoration-mount buffer))
+ (surface (plist-get state :surface)))
+ (unwind-protect
+ (progn
+ (let ((range-before (tp-example-diagnostic-decoration-range state)))
+ (should (equal range-before '(2 . 6)))
+ (let ((warn-report (tp-example-diagnostic-decoration-set-mode state 'warn)))
+ (should (> (plist-get warn-report :new-revision) 0))
+ (should (equal (tp-at (car range-before) 'face buffer)
+ '(:foreground "DarkOrange"))))
+
+ (tp-example-diagnostic-decoration-insert-host-text state 1 "[")
+ (should (equal (tp-example-diagnostic-decoration-range state)
+ (cons (+ (car range-before) 1) (+ (cdr range-before) 1))))
+
+ (tp-example-diagnostic-decoration-delete-host-range state 1 2)
+ (should (equal (tp-example-diagnostic-decoration-range state) range-before))
+ (tp-example-diagnostic-decoration-repaint-range
+ state '(face (:foreground "Blue") help-echo "host override"))
+ (let ((revision (tp-surface-revision surface)))
+ (should-error
+ (tp-example-diagnostic-decoration-set-mode state 'busy)
+ :type 'tp-property-conflict)
+ (should (= (tp-surface-revision surface) revision))
+ (should (eq (tp-signal-peek (plist-get state :mode-signal))
+ 'warn))
+ (should (equal (tp-at (car range-before) 'face buffer)
+ '(:foreground "Blue"))))
+
+ (tp-example-diagnostic-decoration-rebase state)
+ (tp-example-diagnostic-decoration-set-mode state 'busy)
+ (should (equal (tp-at (car range-before) 'face buffer)
+ '(:foreground "Purple")))
+ (tp-example-diagnostic-decoration-repaint-range
+ state '(face (:foreground "Blue") help-echo "host override"))))
+ (let ((unmount (tp-example-diagnostic-decoration-unmount state)))
+ (should (plist-get unmount :unmounted))
+ (should (consp (plist-get unmount :property-conflicts)))
+ (should (buffer-live-p buffer))
+ (should-not (tp-range-anchor-live-p (plist-get state :anchor)))
+ (should-not (tp-signal-live-p (plist-get state :mode-signal)))
+ (should (equal (tp-at 2 'face buffer)
+ '(:foreground "Blue"))))))))
+
+;;; tp-examples-tests.el ends here
diff --git a/tests/tp-layer-tests.el b/tests/tp-layer-tests.el
index a1dafd7..18e694a 100644
--- a/tests/tp-layer-tests.el
+++ b/tests/tp-layer-tests.el
@@ -1,719 +1,296 @@
-;;; tp-layer-tests.el --- ERT regression tests for tp-layer.el -*- lexical-binding: t -*-
+;;; tp-layer-tests.el --- Declaration recipe tests -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
-;; Regression tests for confirmed bugs fixed in the layer-definition
-;; module (tp-layer.el). Each section is tagged with the canonical
-;; bug id it guards against.
+;; Contract tests for static and parameterized named declaration recipes.
;;; Code:
(require 'ert)
(require 'tp)
-(defmacro tp-layer-tests--with-clean (&rest body)
- "Run BODY with a clean layer/reactive state, resetting afterwards."
- (declare (indent 0))
+(defmacro tp-layer-test--isolated (&rest body)
+ "Run BODY with isolated declaration recipe registries."
+ (declare (indent 0) (debug t))
`(unwind-protect
(progn (tp-layer-reset) ,@body)
(tp-layer-reset)))
-;; Dynamic variables used by reactive tests ($foo refers to variable foo).
-(defvar tp-layer-test-b15-color nil)
-(defvar tp-layer-test-b23-color nil)
-(defvar tp-layer-test-b26-color nil)
-
-;;; B20: documented parameterized define-tps format must yield props
-
-(ert-deftest tp-layer-test-param-group-docstring-format ()
- "The define-tps docstring Format 2 example returns real props."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-status (color)
- `((face (:foreground ,color)))
- '(face (:weight bold)))
- (should (tp-group-parameterized-p 'tp-layer-test-status))
- (should (equal (tp-group-props-with-arg 'tp-layer-test-status "red")
- '((face (:foreground "red"))
- (face (:weight bold)))))))
-
-(ert-deftest tp-layer-test-param-group-resolves-in-tp-set-path ()
- "tp--resolve-props builds a layered structure from a parameterized group."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-status (color)
- `((face (:foreground ,color)))
- '(face (:weight bold)))
- (let ((props (tp--resolve-props '(tp-layer-test-status "red"))))
- (should (equal (plist-get props 'face) '(:foreground "red")))
- (should (equal (plist-get props 'tp-layers)
- '((face (:weight bold))))))))
-
-(ert-deftest tp-layer-test-param-group-layer-reference-specs ()
- "Parameterized groups still accept layer-name and (LAYER ARG) specs."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-bold () '(face bold))
- (define-tp tp-layer-test-fg (c) `(face (:foreground ,c)))
- (define-tps tp-layer-test-mixed (color)
- 'tp-layer-test-bold
- `(tp-layer-test-fg ,color))
- (should (equal (tp-group-props-with-arg 'tp-layer-test-mixed "blue")
- '((face bold)
- (face (:foreground "blue")))))))
-
-(ert-deftest tp-layer-test-param-group-named-element ()
- "Parameterized groups accept named (\"NAME\" :props PLIST) elements."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-named (color)
- `(("fg" :props (face (:foreground ,color)))))
- (should (equal (tp-group-props-with-arg 'tp-layer-test-named "red")
- '((face (:foreground "red")))))))
-
-;;; B21: cyclic layer references signal a clear error, not stack overflow
-
-(ert-deftest tp-layer-test-cycle-self-reference ()
- "A layer referencing itself signals an error naming the cycle."
- (tp-layer-tests--with-clean
- (tp--set-layer-props 'tp-layer-test-cyc '(tp-layer-test-cyc t face bold))
- (let ((err (should-error (tp-layer-props 'tp-layer-test-cyc))))
- (should (string-match-p "cyclic layer reference"
- (error-message-string err)))
- (should (string-match-p "tp-layer-test-cyc -> tp-layer-test-cyc"
- (error-message-string err))))))
-
-(ert-deftest tp-layer-test-cycle-mutual-reference ()
- "Two layers referencing each other signal an error naming both."
- (tp-layer-tests--with-clean
- (tp--set-layer-props 'tp-layer-test-ca '(tp-layer-test-cb t face bold))
- (tp--set-layer-props 'tp-layer-test-cb '(tp-layer-test-ca t face italic))
- (let ((err (should-error (tp-layer-props 'tp-layer-test-ca))))
- (should (string-match-p
- "tp-layer-test-ca -> tp-layer-test-cb -> tp-layer-test-ca"
- (error-message-string err))))))
-
-(ert-deftest tp-layer-test-cycle-diamond-is-not-a-cycle ()
- "Re-using the same layer along different branches is not a cycle."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-base () '(face bold))
- (tp--set-layer-props 'tp-layer-test-left '(tp-layer-test-base t help-echo "l"))
- (tp--set-layer-props 'tp-layer-test-right '(tp-layer-test-base t mouse-face highlight))
- (tp--set-layer-props 'tp-layer-test-top
- '(tp-layer-test-left t tp-layer-test-right t))
- (let ((props (tp-layer-props 'tp-layer-test-top)))
- (should (equal (plist-get props 'help-echo) "l"))
- (should (eq (plist-get props 'mouse-face) 'highlight)))))
-
-;;; B22: extra body forms in define-tp simple format are an error
-
-(ert-deftest tp-layer-test-extra-body-forms-error ()
- "define-tp with two simple body forms errors instead of dropping one."
- (should-error
- (eval '(define-tp tp-layer-test-extra ()
- '(face bold)
- '(display "x"))
- t)))
-
-(ert-deftest tp-layer-test-single-body-form-still-works ()
- "define-tp with exactly one simple body form still defines the layer."
- (tp-layer-tests--with-clean
- (eval '(define-tp tp-layer-test-single () '(face bold)) t)
- (should (equal (tp-layer-props 'tp-layer-test-single) '(face bold)))))
-
-(ert-deftest tp-layer-test-keyword-format-unaffected-by-arity-check ()
- "The reactive keyword format still accepts multiple keyword pairs."
- (tp-layer-tests--with-clean
- (eval '(define-tp tp-layer-test-kw ()
- :props '(face bold)
- :transform #'upcase)
- t)
- (should (equal (plist-get (tp-layer-props 'tp-layer-test-kw) 'face) 'bold))
- (should (eq (cdr (assoc 'tp-layer-test-kw tp-layer-transforms)) #'upcase))))
-
-;;; B23: $-symbols in parameterized bodies resolve instead of leaking
-
-(ert-deftest tp-layer-test-param-layer-resolves-reactive-symbols ()
- "$-syms in a parameterized body resolve to current variable values."
- (tp-layer-tests--with-clean
- (setq tp-layer-test-b23-color "green")
- (define-tp tp-layer-test-preact (x)
- `(face (:foreground $tp-layer-test-b23-color) help-echo ,x))
- (should (equal (tp-layer-props-with-arg 'tp-layer-test-preact "hi")
- '(face (:foreground "green") help-echo "hi")))
- ;; And through the tp-set resolution pipeline as well.
- (should (equal (tp--resolve-props '(tp-layer-test-preact "hi"))
- '(face (:foreground "green") help-echo "hi")))))
-
-(ert-deftest tp-layer-test-param-layer-reactive-syms-not-registered ()
- "Resolved $-syms in parameterized bodies create no reactive deps."
- (tp-layer-tests--with-clean
- (setq tp-layer-test-b23-color "green")
- (define-tp tp-layer-test-preact (x)
- `(face (:foreground $tp-layer-test-b23-color) help-echo ,x))
- (tp-layer-props-with-arg 'tp-layer-test-preact "hi")
- (should-not (tp--layer-has-reactive-deps-p 'tp-layer-test-preact))))
-
-;;; B24: accessors return copies, not internal storage
-
-(ert-deftest tp-layer-test-props-mutation-does-not-corrupt-static-layer ()
- "Mutating the plist returned for a define-tp layer leaves it intact."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-st () '(face bold))
- (let ((props (tp-layer-props 'tp-layer-test-st)))
- (setcar (cdr props) 'MUTATED))
- (should (equal (tp-layer-props 'tp-layer-test-st) '(face bold)))))
-
-(ert-deftest tp-layer-test-props-mutation-does-not-corrupt-old-format ()
- "Mutating the plist returned for an old-format layer leaves it intact."
- (tp-layer-tests--with-clean
- (tp--set-layer-props 'tp-layer-test-old '(face bold))
- (let ((props (tp-layer-props 'tp-layer-test-old)))
- (setcar (cdr props) 'MUTATED))
- (should (equal (tp-layer-props 'tp-layer-test-old) '(face bold)))))
-
-(ert-deftest tp-layer-test-props-deep-mutation-does-not-corrupt ()
- "Mutating nested structure of the returned plist leaves storage intact."
- (tp-layer-tests--with-clean
- (tp--set-layer-props 'tp-layer-test-deep '(face (:weight bold)))
- (let ((props (tp-layer-props 'tp-layer-test-deep)))
- (setcar (plist-get props 'face) 'MUTATED))
- (should (equal (tp-layer-props 'tp-layer-test-deep)
- '(face (:weight bold))))))
-
-(ert-deftest tp-layer-test-group-props-mutation-does-not-corrupt ()
- "Mutating plists returned by tp-group-props leaves layers intact."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-gm () '(face bold))
- (define-tps tp-layer-test-gmg () 'tp-layer-test-gm)
- (let ((props-list (tp-group-props 'tp-layer-test-gmg)))
- (setcar (cdar props-list) 'MUTATED))
- (should (equal (tp-group-props 'tp-layer-test-gmg) '((face bold))))))
-
-;;; B25: :transform in define-tps group elements is registered
-
-(ert-deftest tp-layer-test-group-element-transform-registered ()
- "A format-4 group element's :transform lands in tp-layer-transforms."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-tg ()
- '("a" :props (face (:foreground $tp-layer-test-b26-color))
- :data ((tp-layer-test-b26-color . "red"))
- :transform upcase))
- (should (eq (cdr (assoc 'tp-layer-test-tg-a tp-layer-transforms))
- 'upcase))))
-
-(ert-deftest tp-layer-test-group-element-transform-removed-on-redefine ()
- "Redefining a group element without :transform unregisters the old one."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-tg ()
- '("a" :props (face bold) :transform upcase))
- (should (assoc 'tp-layer-test-tg-a tp-layer-transforms))
- (define-tps tp-layer-test-tg ()
- '("a" . (face bold)))
- (should-not (assoc 'tp-layer-test-tg-a tp-layer-transforms))))
-
-;;; B26: group redefinition / undefinition cleans up generated layers
-
-(ert-deftest tp-layer-test-group-redefine-removes-orphans ()
- "Shrinking a group on redefinition undefines the dropped layers."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-rg ()
- '(face bold) '(face italic) '(face underline))
- (should (assoc 'tp-layer-test-rg-1 tp-layer-alist))
- (should (assoc 'tp-layer-test-rg-2 tp-layer-alist))
- (define-tps tp-layer-test-rg ()
- '(face bold))
- (should (assoc 'tp-layer-test-rg-0 tp-layer-alist))
- (should-not (assoc 'tp-layer-test-rg-1 tp-layer-alist))
- (should-not (assoc 'tp-layer-test-rg-2 tp-layer-alist))
- (should (equal (tp-group-props 'tp-layer-test-rg) '((face bold))))))
-
-(ert-deftest tp-layer-test-undefine-group-removes-generated-layers ()
- "tp-undefine-group also undefines layers generated by the group."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-ug ()
- '(face bold)
- '("named" . (face italic)))
- (tp-undefine-group 'tp-layer-test-ug)
- (should-not (assoc 'tp-layer-test-ug tp-layer-groups))
- (should-not (assoc 'tp-layer-test-ug-0 tp-layer-alist))
- (should-not (assoc 'tp-layer-test-ug-named tp-layer-alist))))
-
-(ert-deftest tp-layer-test-undefine-group-keeps-referenced-layers ()
- "Layers merely referenced by a group survive its undefinition."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-keep () '(face bold))
- (define-tps tp-layer-test-ug2 ()
- 'tp-layer-test-keep
- '(face italic))
- (tp-undefine-group 'tp-layer-test-ug2)
- (should (assoc 'tp-layer-test-keep tp-layer-alist))
- (should-not (assoc 'tp-layer-test-ug2-0 tp-layer-alist))))
-
-(ert-deftest tp-layer-test-undefine-group-cleans-reactive-deps ()
- "Undefining a group unregisters reactive deps of generated layers."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-ug3 ()
- '("r" :props (face (:foreground $tp-layer-test-b26-color))
- :data ((tp-layer-test-b26-color . "red"))))
- (should (tp--layer-has-reactive-deps-p 'tp-layer-test-ug3-r))
- (tp-undefine-group 'tp-layer-test-ug3)
- (should-not (tp--layer-has-reactive-deps-p 'tp-layer-test-ug3-r))
- (should-not (assoc 'tp-layer-test-ug3-r tp-layer-alist))))
-
-(ert-deftest tp-layer-test-group-redefine-to-parameterized-cleans-up ()
- "Redefining a plain group as parameterized undefines its old layers."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-pg ()
- '(face bold))
- (should (assoc 'tp-layer-test-pg-0 tp-layer-alist))
- (define-tps tp-layer-test-pg (color)
- `((face (:foreground ,color))))
- (should-not (assoc 'tp-layer-test-pg-0 tp-layer-alist))
- (should (tp-group-parameterized-p 'tp-layer-test-pg))))
-
-;;; B27: unknown keywords in group elements are an error, not a misparse
-
-(ert-deftest tp-layer-test-group-element-unknown-keyword-errors ()
- "An unknown keyword in a format-4 group element signals an error."
- (tp-layer-tests--with-clean
- (let ((err (should-error
- (eval '(define-tps tp-layer-test-bad ()
- '("a" :props (face bold)
- :bogus (:props (face italic))))
- t))))
- (should (string-match-p "Unknown keyword"
- (error-message-string err))))))
-
-;;; B15: anonymous reactive layers are interned, not minted per call
-
-(ert-deftest tp-layer-test-anonymous-layer-interned ()
- "Equal reactive plists reuse a single anonymous layer entry."
- (tp-layer-tests--with-clean
- (setq tp-layer-test-b15-color "red")
- (let* ((s1 (tp-set (copy-sequence "hi")
- '(face (:foreground $tp-layer-test-b15-color))))
- (s2 (tp-set (copy-sequence "hi")
- '(face (:foreground $tp-layer-test-b15-color))))
- (n1 (get-text-property 0 'tp-name s1))
- (n2 (get-text-property 0 'tp-name s2)))
- (should n1)
- (should (eq n1 n2))
- ;; Exactly one anonymous registry entry for the shared spec.
- (should (= (length tp-layer-alist) 1)))))
-
-(ert-deftest tp-layer-test-anonymous-layer-distinct-specs-distinct ()
- "Different reactive plists still get different anonymous layers."
- (tp-layer-tests--with-clean
- (setq tp-layer-test-b15-color "red")
- (let* ((s1 (tp-set (copy-sequence "hi")
- '(face (:foreground $tp-layer-test-b15-color))))
- (s2 (tp-set (copy-sequence "hi")
- '(face (:background $tp-layer-test-b15-color))))
- (n1 (get-text-property 0 'tp-name s1))
- (n2 (get-text-property 0 'tp-name s2)))
- (should n1)
- (should n2)
- (should-not (eq n1 n2)))))
-
-(ert-deftest tp-layer-test-anonymous-layer-reuse-keeps-reactivity ()
- "Reactive updates still reach buffer text using a reused anonymous layer."
- (tp-layer-tests--with-clean
- (with-temp-buffer
- (setq tp-layer-test-b15-color "red")
- (insert "Hello World")
- (tp-set 1 3 '(face (:foreground $tp-layer-test-b15-color)))
- (tp-set 7 9 '(face (:foreground $tp-layer-test-b15-color)))
- (should (eq (get-text-property 1 'tp-name)
- (get-text-property 7 'tp-name)))
- (setq tp-layer-test-b15-color "blue")
- (should (equal (plist-get (get-text-property 1 'face) :foreground)
- "blue"))
- (should (equal (plist-get (get-text-property 7 'face) :foreground)
- "blue")))))
-
-(ert-deftest tp-layer-test-anonymous-registry-cleared-on-reset ()
- "tp-layer-reset clears the anonymous-layer intern registry."
- (tp-layer-tests--with-clean
- (setq tp-layer-test-b15-color "red")
- (tp-set (copy-sequence "hi")
- '(face (:foreground $tp-layer-test-b15-color)))
- (should tp--anonymous-layer-registry)
- (tp-layer-reset)
- (should-not tp--anonymous-layer-registry)))
-
-;;; 0.3.0 A4: multi-argument parameterized layers
-
-(ert-deftest tp-layer-test-multi-arg-define-and-props-with-args ()
- "define-tp accepts multi-symbol arglists; props-with-args expands them."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-fgbg (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (should (tp-layer-parameterized-p 'tp-layer-test-fgbg))
- (should (equal (tp-layer-arglist 'tp-layer-test-fgbg) '(fg bg)))
- (should (equal (tp-layer-props-with-args 'tp-layer-test-fgbg
- '("red" "blue"))
- '(face (:foreground "red" :background "blue"))))
- (should (equal (tp-layer-props-with-args 'tp-layer-test-fgbg
- '("red" "blue") t)
- '(face (:foreground "red" :background "blue")
- tp-name tp-layer-test-fgbg)))))
-
-(ert-deftest tp-layer-test-props-with-arg-is-thin-wrapper ()
- "tp-layer-props-with-arg keeps its single-argument contract."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-fg1 (c) `(face (:foreground ,c)))
- (should (equal (tp-layer-props-with-arg 'tp-layer-test-fg1 "red")
- '(face (:foreground "red"))))
- (should (equal (tp-layer-props-with-arg 'tp-layer-test-fg1 "red")
- (tp-layer-props-with-args 'tp-layer-test-fg1 '("red"))))))
-
-(ert-deftest tp-layer-test-props-with-args-non-parameterized-nil ()
- "props-with-args and tp-layer-arglist return nil for other layers."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-np () '(face bold))
- (should-not (tp-layer-props-with-args 'tp-layer-test-np '(1)))
- (should-not (tp-layer-arglist 'tp-layer-test-np))
- (should-not (tp-layer-props-with-args 'tp-layer-test-missing '(1)))))
-
-(ert-deftest tp-layer-test-multi-arg-tp-set-flat-string-form ()
- "The flat (tp-set STRING \\='LAYER ARG1 ARG2) form binds all params."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-fgbg (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (let ((s (tp-set "hello" 'tp-layer-test-fgbg "red" "blue")))
- (should (equal (get-text-property 0 'face s)
- '(:foreground "red" :background "blue"))))))
-
-(ert-deftest tp-layer-test-multi-arg-tp-set-flat-with-extra-props ()
- "Extra props after multi args survive, with no stray nil pair."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-fgbg (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (let ((s (tp-set "hello" 'tp-layer-test-fgbg "red" "blue"
- 'help-echo "tip")))
- (should (equal (plist-get (get-text-property 0 'face s) :foreground)
- "red"))
- (should (equal (get-text-property 0 'help-echo s) "tip"))
- ;; The odd-length flat spec is padded with nil by key merging;
- ;; resolution must strip it instead of setting a nil property.
- (should (equal (text-properties-at 0 s)
- '(face (:foreground "red" :background "blue")
- help-echo "tip"))))))
-
-(ert-deftest tp-layer-test-multi-arg-tp-set-region-list-form ()
- "The region form (tp-set START END \\='(LAYER ARG1 ARG2)) works (1-based)."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-fgbg (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (with-temp-buffer
- (insert "hello")
- (tp-set 1 4 '(tp-layer-test-fgbg "red" "blue"))
- (should (equal (get-text-property 1 'face)
- '(:foreground "red" :background "blue")))
- (should-not (get-text-property 4 'face)))))
-
-(ert-deftest tp-layer-test-multi-arg-tp-set-wrapped-args-plist-form ()
- "The plist spec (LAYER (ARG1 ARG2) EXTRA...) passes args as one list."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-fgbg (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- ;; Layer at the head of the plist.
- (let ((s (copy-sequence "hello")))
- (tp-set 0 5 '(tp-layer-test-fgbg ("red" "blue") help-echo "tip") s)
- (should (equal (get-text-property 0 'face s)
- '(:foreground "red" :background "blue")))
- (should (equal (get-text-property 0 'help-echo s) "tip")))
- ;; Layer at a non-head plist position.
- (let ((s (copy-sequence "hello")))
- (tp-set 0 5 '(help-echo "tip" tp-layer-test-fgbg ("red" "blue")) s)
- (should (equal (plist-get (get-text-property 0 'face s) :background)
- "blue"))
- (should (equal (get-text-property 0 'help-echo s) "tip")))))
-
-(ert-deftest tp-layer-test-multi-arg-normalize-layer-spec ()
- "Normalized parameterized specs retain args in managed metadata."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-fgbg (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (let* ((entry (tp--normalize-layer-spec
- '(tp-layer-test-fgbg "red" "blue")))
- (meta (plist-get entry 'tp-meta)))
- (should (equal (plist-get entry 'face)
- '(:foreground "red" :background "blue")))
- (should (eq (plist-get entry 'tp-name) 'tp-layer-test-fgbg))
- (should (equal (plist-get meta :args) '("red" "blue")))
- (should (equal (plist-get meta :arglist) '(fg bg)))
- (should (integerp (plist-get meta :definition-version))))))
-
-(ert-deftest tp-layer-test-multi-arg-tp-put-layer ()
- "tp-put-layer accepts multi-argument parameterized layer specs."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-fgbg (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (let ((s (copy-sequence "hi")))
- (tp-put-layer s '(tp-layer-test-fgbg "red" "blue") 0)
- (should (equal (get-text-property 0 'face s)
- '(:foreground "red" :background "blue")))
- (should (eq (get-text-property 0 'tp-name s) 'tp-layer-test-fgbg)))))
-
-(ert-deftest tp-layer-test-multi-arg-cycle-detection ()
- "Cycle detection still fires through the multi-argument path."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-mcyc (a b)
- `(tp-layer-test-mcyc (,a ,b)))
- (let ((err (should-error
- (tp-layer-props-with-args 'tp-layer-test-mcyc '(1 2)))))
- (should (string-match-p "cyclic layer reference"
- (error-message-string err))))))
-
-(ert-deftest tp-layer-test-multi-arg-props-are-copies ()
- "props-with-args returns fresh copies; mutation cannot corrupt storage."
- (tp-layer-tests--with-clean
- ;; The (:weight bold) subform is a shared constant in the
- ;; backquoted body; without copy-on-return, mutating the returned
- ;; plist would corrupt every later expansion.
- (define-tp tp-layer-test-mcopy (a b)
- `(face (:weight bold) help-echo ,(format "%s-%s" a b)))
- (let ((props (tp-layer-props-with-args 'tp-layer-test-mcopy '("x" "y"))))
- (setcar (plist-get props 'face) 'MUTATED))
- (should (equal (tp-layer-props-with-args 'tp-layer-test-mcopy '("x" "y"))
- '(face (:weight bold) help-echo "x-y")))))
-
-(ert-deftest tp-layer-test-multi-arg-group ()
- "define-tps accepts multi-symbol arglists usable through tp-set specs."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-mgrp (fg w)
- `((face (:foreground ,fg)))
- `((face (:weight ,w))))
- (should (tp-group-parameterized-p 'tp-layer-test-mgrp))
- (should (equal (tp--group-arglist 'tp-layer-test-mgrp) '(fg w)))
- (should (equal (tp--group-props-with-args 'tp-layer-test-mgrp
- '("red" bold))
- '((face (:foreground "red")) (face (:weight bold)))))
- ;; Flat (GROUP ARG1 ARG2) spec through the tp-set pipeline.
- (let ((props (tp--resolve-props '(tp-layer-test-mgrp "red" bold))))
- (should (equal (plist-get props 'face) '(:foreground "red")))
- (should (equal (plist-get props 'tp-layers)
- '((face (:weight bold))))))
- ;; Single-argument groups keep working through the wrapper.
- (define-tps tp-layer-test-sgrp (color)
- `((face (:foreground ,color))))
- (should (equal (tp-group-props-with-arg 'tp-layer-test-sgrp "red")
- '((face (:foreground "red")))))))
-
-;;; 0.3.0 A5: tp-describe-layer and its data collector
-
-(ert-deftest tp-layer-test-describe-data-unified ()
- "Describe data for a define-tp layer reports the unified format."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-du () '(face bold))
- (let ((data (tp--describe-layer-data 'tp-layer-test-du)))
- (should (eq (plist-get data :name) 'tp-layer-test-du))
- (should (eq (plist-get data :format) 'unified))
- (should (equal (plist-get data :body) '(quote (face bold))))
- (should (equal (plist-get data :props)
- '(face bold tp-name tp-layer-test-du)))
- (should-not (plist-get data :arglist))
- (should-not (plist-get data :reactive-deps))
- (should-not (plist-get data :transform))
- (should-not (plist-get data :group)))))
-
-(ert-deftest tp-layer-test-describe-data-flat ()
- "Describe data for an old-format layer reports the flat format."
- (tp-layer-tests--with-clean
- (tp--set-layer-props 'tp-layer-test-df '(face italic))
- (let ((data (tp--describe-layer-data 'tp-layer-test-df)))
- (should (eq (plist-get data :format) 'flat))
- (should (equal (plist-get data :body) '(face italic)))
- (should (equal (plist-get data :props)
- '(face italic tp-name tp-layer-test-df))))))
-
-(ert-deftest tp-layer-test-describe-data-parameterized ()
- "Describe data for a parameterized layer reports arglist and a note."
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-dp (a b)
- `(face (:foreground ,a :background ,b)))
- (let ((data (tp--describe-layer-data 'tp-layer-test-dp)))
- (should (eq (plist-get data :format) 'parameterized))
- (should (equal (plist-get data :arglist) '(a b)))
- ;; Expanded props need arguments, so a placeholder note is used.
- (should (stringp (plist-get data :props)))
- (should (string-match-p "tp-layer-props-with-args"
- (plist-get data :props))))))
-
-(ert-deftest tp-layer-test-describe-data-reactive ()
- "Describe data for a reactive layer reports format and dependencies."
- (tp-layer-tests--with-clean
- (setq tp-layer-test-b15-color "red")
- (define-tp tp-layer-test-dr ()
- '(face (:foreground $tp-layer-test-b15-color)))
- (let ((data (tp--describe-layer-data 'tp-layer-test-dr)))
- (should (eq (plist-get data :format) 'reactive))
- (should (equal (plist-get data :reactive-deps)
- '(tp-layer-test-b15-color))))))
-
-(ert-deftest tp-layer-test-describe-data-group-and-transform ()
- "Describe data reports the owning group and transform presence."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-dg ()
- '("a" :props (face bold) :transform upcase))
- (let ((data (tp--describe-layer-data 'tp-layer-test-dg-a)))
- (should (eq (plist-get data :group) 'tp-layer-test-dg))
- (should (plist-get data :transform)))))
-
-(ert-deftest tp-layer-test-describe-data-unknown-layer-nil ()
- "Describe data returns nil for names not in tp-layer-alist."
- (tp-layer-tests--with-clean
- (should-not (tp--describe-layer-data 'tp-layer-test-nonexistent))))
-
-(ert-deftest tp-layer-test-describe-layer-command ()
- "tp-describe-layer is a command and renders a help buffer."
- (should (commandp 'tp-describe-layer))
- (tp-layer-tests--with-clean
- (define-tp tp-layer-test-dc () '(face bold))
- (save-window-excursion
- (tp-describe-layer 'tp-layer-test-dc)
- (with-current-buffer (help-buffer)
- (should (string-match-p "tp-layer-test-dc is a tp layer"
- (buffer-string)))
- (should (string-match-p "Storage format: unified"
- (buffer-string)))))
- (should-error (tp-describe-layer 'tp-layer-test-missing)
- :type 'user-error)))
-
-;;; ARG-1: wrong-arity parameterized-layer calls signal clear errors
-
-(defmacro tp-layer-tests--with-colors (&rest body)
- "Run BODY with the two-parameter test layer tp-lt-colors defined."
- (declare (indent 0))
- `(tp-layer-tests--with-clean
- (define-tp tp-lt-colors (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- ,@body))
-
-(ert-deftest tp-layer-test-props-with-args-missing-arg-errors ()
- "tp-layer-props-with-args signals on fewer args than parameters.
-Since Emacs 27 `cl-progv' silently binds missing parameters to nil,
-so the old docstring's promised unbound-variable error could never
-fire; the arity is now checked explicitly (ARG-1)."
- (tp-layer-tests--with-colors
- (let ((err (should-error
- (tp-layer-props-with-args 'tp-lt-colors '("red")))))
- ;; Parens are literal in Emacs regexps.
- (should (string-match-p "takes 2 argument(s), got 1" (cadr err))))
- ;; Correct arity still works.
- (should (equal (tp-layer-props-with-args 'tp-lt-colors
- '("red" "blue"))
- '(face (:foreground "red" :background "blue"))))
- ;; Extra values are still ignored, per the documented contract.
- (should (equal (tp-layer-props-with-args 'tp-lt-colors
- '("red" "blue" "green"))
- '(face (:foreground "red" :background "blue"))))))
-
-(ert-deftest tp-layer-test-tp-set-flat-missing-arg-errors ()
- "The flat tp-set form with too few layer args signals, not nil-binds.
-Before ARG-1, (tp-set \"s\" \\='(layer \"red\")) on a two-parameter
-layer silently produced (:foreground \"red\" :background nil)."
- (tp-layer-tests--with-colors
- (should-error (tp-set "s" '(tp-lt-colors "red")))))
-
-(ert-deftest tp-layer-test-tp-set-flat-excess-arg-errors ()
- "Flat-form excess positional args signal instead of corrupting props.
-Before ARG-1, the excess string fell into extra-props and was applied
-as a text-property KEY with value nil."
- (tp-layer-tests--with-colors
- (let ((err (should-error
- (tp-set "gg" '(tp-lt-colors "red" "blue" "green")))))
- (should (string-match-p "excess argument" (cadr err))))
- ;; Correct-arity flat form is unchanged.
- (should (equal (text-properties-at
- 0 (tp-set "ok" '(tp-lt-colors "red" "blue")))
- '(face (:foreground "red" :background "blue"))))
- ;; Legitimate extra PROPS after the args still work.
- (should (equal (plist-get
- (text-properties-at
- 0 (tp-set "ok" '(tp-lt-colors "red" "blue"
- help-echo "tip")))
- 'help-echo)
- "tip"))
- ;; The wrapped-args form with extra props is untouched as well.
- (should (equal (plist-get
- (text-properties-at
- 0 (tp-set "ok" '(tp-lt-colors ("red" "blue")
- help-echo "tip")))
- 'help-echo)
- "tip"))))
-
-(ert-deftest tp-layer-test-stack-path-wrong-arity-clear-error ()
- "The stack path signals a clear arity error, not \"Odd length ...\".
-Before ARG-1, (tp-push-layer s \\='(layer \"red\")) fell through
-tp--normalize-layer-spec's named-inline branch, producing the odd
-plist (\"red\" tp-name layer) and the cryptic error \"Odd length
-text property list\"."
- (tp-layer-tests--with-colors
- (let ((err (should-error
- (tp-push-layer (copy-sequence "st")
- '(tp-lt-colors "red")))))
- (should (string-match-p "expects 2 args, got 1" (cadr err))))
- (let ((err (should-error
- (tp--normalize-layer-spec '(tp-lt-colors "red")))))
- (should (string-match-p "expects 2 args, got 1" (cadr err))))
- ;; Correct arity through the stack path keeps the rendered facade
- ;; while authoritative metadata lives in stack storage.
- (let ((s (copy-sequence "st")))
- (tp-push-layer s '(tp-lt-colors "red" "blue"))
- (should (equal (get-text-property 0 'face s)
- '(:foreground "red" :background "blue")))
- (should (eq (get-text-property 0 'tp-name s) 'tp-lt-colors))
- (let* ((entry (car (get-text-property 0 'tp-layers s)))
- (meta (plist-get entry 'tp-meta)))
- (should (equal (plist-get meta :args) '("red" "blue")))))))
-
-;;; API-SYM-01: public tp-group-props-with-args mirrors the layer pair
-
-(ert-deftest tp-layer-test-group-props-with-args-public ()
- "The public plural group accessor matches the private path."
- (tp-layer-tests--with-clean
- (define-tps tp-layer-test-pgrp (fg w)
- `((face (:foreground ,fg)))
- `((face (:weight ,w))))
- (should (equal (tp-group-props-with-args 'tp-layer-test-pgrp
- '("red" bold))
- '((face (:foreground "red")) (face (:weight bold)))))
- (should (equal (tp-group-props-with-args 'tp-layer-test-pgrp
- '("red" bold))
- (tp--group-props-with-args 'tp-layer-test-pgrp
- '("red" bold))))
- (should (equal (tp-group-props-with-args 'tp-layer-test-pgrp
- '("red" bold) t)
- (tp--group-props-with-args 'tp-layer-test-pgrp
- '("red" bold) t)))
- ;; Non-parameterized or undefined groups return nil, like the
- ;; layer counterpart.
- (should-not (tp-group-props-with-args 'tp-layer-test-nope '("x")))))
-
-;;; API-NAME-02: prefix-conforming tp-define-* aliases
-
-(ert-deftest tp-layer-test-define-layer-alias ()
- "tp-define-layer is a working macro alias of define-tp."
- (tp-layer-tests--with-clean
- (tp-define-layer tp-layer-test-alias-l ()
- '(face bold))
- (should (equal (tp-layer-props 'tp-layer-test-alias-l) '(face bold)))
- ;; Parameterized definitions work through the alias too.
- (tp-define-layer tp-layer-test-alias-p (color)
+(ert-deftest tp-layer-test-static-recipe-expands-to-direct-properties ()
+ "A static recipe expands without runtime metadata."
+ (tp-layer-test--isolated
+ (define-tp tp-layer-test-static ()
+ '(face bold help-echo "static"))
+ (should (equal (tp-layer-props 'tp-layer-test-static)
+ '(face bold help-echo "static")))
+ (let ((text (tp-set "demo" 'tp-layer-test-static)))
+ (should (eq (get-text-property 0 'face text) 'bold))
+ (should (equal (get-text-property 0 'help-echo text) "static")))))
+
+(ert-deftest tp-layer-test-parameterized-recipe-requires-exact-arity ()
+ "Parameterized recipes bind every declared argument exactly once."
+ (tp-layer-test--isolated
+ (define-tp tp-layer-test-parameterized (foreground weight)
+ `(face (:foreground ,foreground :weight ,weight)))
+ (should
+ (equal (tp-layer-props-with-args
+ 'tp-layer-test-parameterized '("red" bold))
+ '(face (:foreground "red" :weight bold))))
+ (should-error
+ (tp-layer-props-with-args 'tp-layer-test-parameterized '("red")))
+ (should-error
+ (tp-layer-props-with-args
+ 'tp-layer-test-parameterized '("red" bold extra)))))
+
+(ert-deftest tp-layer-test-whole-string-call-supports-wrapped-arguments ()
+ "A multi-argument recipe accepts a wrapped argument list plus extras."
+ (tp-layer-test--isolated
+ (define-tp tp-layer-test-card (foreground background)
+ `(face (:foreground ,foreground :background ,background)))
+ (let ((text (tp-set "card" 'tp-layer-test-card
+ '("white" "navy") 'help-echo "Card")))
+ (should
+ (equal (get-text-property 0 'face text)
+ '(:foreground "white" :background "navy")))
+ (should (equal (get-text-property 0 'help-echo text) "Card")))))
+
+(ert-deftest tp-layer-test-nested-recipes-compose-direct-properties ()
+ "Recipe keys expand recursively and use native merge semantics."
+ (tp-layer-test--isolated
+ (define-tp tp-layer-test-color (color)
`(face (:foreground ,color)))
- (should (equal (tp-layer-props-with-arg 'tp-layer-test-alias-p "red")
- '(face (:foreground "red"))))))
+ (define-tp tp-layer-test-button (color)
+ `(tp-layer-test-color ,color
+ face (:weight bold)
+ mouse-face highlight))
+ (should
+ (equal (tp-layer-props-with-arg 'tp-layer-test-button "red")
+ '(face (:foreground "red" :weight bold)
+ mouse-face highlight)))))
-(ert-deftest tp-layer-test-define-group-alias ()
- "tp-define-group is a working macro alias of define-tps."
- (tp-layer-tests--with-clean
- (tp-define-layer tp-layer-test-alias-m ()
- '(face italic))
- (tp-define-group tp-layer-test-alias-g ()
- 'tp-layer-test-alias-m
- '(face bold))
- (should (assoc 'tp-layer-test-alias-g tp-layer-groups))
- (should (equal (tp-group-props 'tp-layer-test-alias-g)
- '((face italic) (face bold))))))
+(ert-deftest tp-layer-test-cycle-errors-name-the-path ()
+ "Cyclic recipe references fail instead of partially expanding."
+ (tp-layer-test--isolated
+ (define-tp tp-layer-test-a () '(tp-layer-test-b t))
+ (let ((error
+ (should-error
+ (eval '(define-tp tp-layer-test-b ()
+ '(tp-layer-test-a t))))))
+ (let ((message (error-message-string error)))
+ (should (string-match-p "tp-layer-test-a" message))
+ (should (string-match-p "tp-layer-test-b" message))
+ (should (string-match-p " -> " message))))))
+
+(ert-deftest tp-layer-test-group-merges-ordered-contributions ()
+ "A group expands into ordered direct property contributions."
+ (tp-layer-test--isolated
+ (define-tp tp-layer-test-base () '(face (:weight bold)))
+ (define-tps tp-layer-test-group ()
+ 'tp-layer-test-base
+ '(face (:foreground "cyan"))
+ '(help-echo "group"))
+ (let ((text (tp-set "group" 'tp-layer-test-group)))
+ (should
+ (equal (get-text-property 0 'face text)
+ '(:weight bold :foreground "cyan")))
+ (should (equal (get-text-property 0 'help-echo text) "group")))))
+
+(ert-deftest tp-layer-test-parameterized-group-evaluates-at-application ()
+ "Parameterized groups remain recipes and are not frozen at definition."
+ (tp-layer-test--isolated
+ (define-tps tp-layer-test-theme (foreground background)
+ `(face (:foreground ,foreground))
+ `(face (:background ,background)))
+ (should
+ (equal (tp-group-props-with-args
+ 'tp-layer-test-theme '("white" "black"))
+ '((face (:foreground "white"))
+ (face (:background "black")))))))
+
+(ert-deftest tp-layer-test-static-named-group-element-compiles-style ()
+ "A named static group element also becomes a named direct style."
+ (tp-layer-test--isolated
+ (define-tps tp-layer-test-parts ()
+ '("label" . (face italic mouse-face highlight)))
+ (should
+ (equal (tp-style-declarations 'tp-layer-test-parts-label)
+ '(text/face italic text/mouse-face highlight)))))
+
+(ert-deftest tp-layer-test-group-redefinition-removes-generated-recipes ()
+ "Redefining a group removes generated recipes no longer present."
+ (tp-layer-test--isolated
+ (define-tps tp-layer-test-parts ()
+ '("old" . (face bold)))
+ (should (tp-layer-props 'tp-layer-test-parts-old))
+ (define-tps tp-layer-test-parts ()
+ '("new" . (face italic)))
+ (should-not (tp-layer-props 'tp-layer-test-parts-old))
+ (should (tp-layer-props 'tp-layer-test-parts-new))))
+
+(ert-deftest tp-layer-test-failed-group-definition-leaves-no-registry-state ()
+ "A failed first group definition must not publish partial entries."
+ (tp-layer-test--isolated
+ (should-error
+ (eval '(define-tps tp-layer-test-broken ()
+ '("label" . (face)))))
+ (should-not (assq 'tp-layer-test-broken tp-layer-groups))
+ (should-not (tp-layer-props 'tp-layer-test-broken-label))
+ (should-not (tp-style-declarations 'tp-layer-test-broken-label))))
+
+(ert-deftest tp-layer-test-failed-group-redefinition-preserves-old-state ()
+ "A failed group redefinition must leave every old entry usable."
+ (tp-layer-test--isolated
+ (define-tps tp-layer-test-atomic ()
+ '("old" . (face bold help-echo "old")))
+ (let ((old-group (tp-group-props 'tp-layer-test-atomic))
+ (old-layer (tp-layer-props 'tp-layer-test-atomic-old))
+ (old-style (tp-style-declarations 'tp-layer-test-atomic-old)))
+ (should-error
+ (eval '(define-tps tp-layer-test-atomic ()
+ '("new" . (face)))))
+ (should (equal (tp-group-props 'tp-layer-test-atomic) old-group))
+ (should (equal (tp-layer-props 'tp-layer-test-atomic-old) old-layer))
+ (should (equal (tp-style-declarations 'tp-layer-test-atomic-old)
+ old-style))
+ (should-not (tp-layer-props 'tp-layer-test-atomic-new))
+ (should-not (tp-style-declarations 'tp-layer-test-atomic-new)))))
+
+(ert-deftest tp-layer-test-failed-second-generated-install-rolls-back ()
+ "A failed generated recipe install must preserve the complete old group."
+ (tp-layer-test--isolated
+ (define-tps tp-layer-test-atomic-install ()
+ '("old-a" . (face bold help-echo "old-a"))
+ '("old-b" . (face italic help-echo "old-b")))
+ (let ((old-group (tp-group-props 'tp-layer-test-atomic-install))
+ (old-a-layer (tp-layer-props 'tp-layer-test-atomic-install-old-a))
+ (old-b-layer (tp-layer-props 'tp-layer-test-atomic-install-old-b))
+ (old-a-style
+ (tp-style-declarations 'tp-layer-test-atomic-install-old-a))
+ (old-b-style
+ (tp-style-declarations 'tp-layer-test-atomic-install-old-b))
+ (old-generated
+ (cdr (assq 'tp-layer-test-atomic-install
+ tp--group-generated-layers)))
+ (install-count 0)
+ (original-define
+ (symbol-function 'tp--candidate-define-layer-recipe)))
+ (cl-letf (((symbol-function 'tp--candidate-define-layer-recipe)
+ (lambda (name arglist body layers groups styles compiled)
+ (if (and (memq name '(tp-layer-test-atomic-install-new-a
+ tp-layer-test-atomic-install-new-b))
+ (= (cl-incf install-count) 2))
+ (error "synthetic second generated install failure")
+ (funcall original-define
+ name arglist body
+ layers groups styles compiled)))))
+ (should-error
+ (eval '(define-tps tp-layer-test-atomic-install ()
+ '("new-a" . (face underline help-echo "new-a"))
+ '("new-b" . (face shadow help-echo "new-b"))))))
+ (should (equal (tp-group-props 'tp-layer-test-atomic-install)
+ old-group))
+ (should (equal (tp-layer-props 'tp-layer-test-atomic-install-old-a)
+ old-a-layer))
+ (should (equal (tp-layer-props 'tp-layer-test-atomic-install-old-b)
+ old-b-layer))
+ (should
+ (equal (tp-style-declarations 'tp-layer-test-atomic-install-old-a)
+ old-a-style))
+ (should
+ (equal (tp-style-declarations 'tp-layer-test-atomic-install-old-b)
+ old-b-style))
+ (should (equal (cdr (assq 'tp-layer-test-atomic-install
+ tp--group-generated-layers))
+ old-generated))
+ (should-not (tp-layer-props 'tp-layer-test-atomic-install-new-a))
+ (should-not (tp-layer-props 'tp-layer-test-atomic-install-new-b))
+ (should-not
+ (tp-style-declarations 'tp-layer-test-atomic-install-new-a))
+ (should-not
+ (tp-style-declarations 'tp-layer-test-atomic-install-new-b)))))
+
+(ert-deftest tp-layer-test-definition-results-are-defensive-copies ()
+ "Mutating one expanded result cannot corrupt the stored recipe."
+ (tp-layer-test--isolated
+ (define-tp tp-layer-test-copy ()
+ '(face (:foreground "red")))
+ (let ((first (tp-layer-props 'tp-layer-test-copy)))
+ (setcar (cdr (plist-get first 'face)) "blue")
+ (should
+ (equal (tp-layer-props 'tp-layer-test-copy)
+ '(face (:foreground "red")))))))
+
+(ert-deftest tp-layer-test-recipe-owns-mutable-values-and-keeps-identities ()
+ "Recipe storage and expansion isolate data without cloning opaque values."
+ (tp-layer-test--isolated
+ (let* ((caller-string (copy-sequence "tooltip"))
+ (caller-vector (vector (copy-sequence "display")))
+ (record (tp--make-native-range 'owner :test 1 2))
+ (calls 0)
+ (callback (lambda (&rest _args) (cl-incf calls))))
+ (eval
+ `(define-tp tp-layer-test-deep-copy ()
+ (list 'help-echo ',caller-string
+ 'display ',caller-vector
+ 'tp-test-record ',record
+ 'action ',callback)))
+ (let* ((first (tp-layer-props 'tp-layer-test-deep-copy))
+ (first-string (plist-get first 'help-echo))
+ (first-vector (plist-get first 'display)))
+ (should-not (eq first-string caller-string))
+ (should-not (eq first-vector caller-vector))
+ (should-not (eq (aref first-vector 0) (aref caller-vector 0)))
+ (should (eq (plist-get first 'tp-test-record) record))
+ (should (eq (plist-get first 'action) callback))
+ (should (= calls 0))
+ (aset caller-string 0 ?T)
+ (aset (aref caller-vector 0) 0 ?D)
+ (should (equal first-string "tooltip"))
+ (should (equal first-vector ["display"]))
+ (aset first-string 1 ?O)
+ (aset (aref first-vector 0) 1 ?I)
+ (should
+ (equal (tp-layer-props 'tp-layer-test-deep-copy)
+ (list 'help-echo "tooltip"
+ 'display ["display"]
+ 'tp-test-record record
+ 'action callback)))))))
+
+(ert-deftest tp-layer-test-legacy-dollar-syntax-is-rejected ()
+ "Legacy dollar-variable syntax cannot recreate a hidden watcher runtime."
+ (tp-layer-test--isolated
+ (should-error
+ (eval '(define-tp tp-layer-test-reactive ()
+ '(face (:foreground $tp-layer-test-color))))
+ :type 'tp-invalid-layer-definition)))
+
+(ert-deftest tp-layer-test-computed-source-uses-the-shared-policy-core ()
+ "Explicit computed sources evaluate through ordinary property projection."
+ (tp-layer-test--isolated
+ (let ((color "red") (calls 0))
+ (define-tp tp-layer-test-computed ()
+ `(face ,(tp-computed
+ (lambda ()
+ (cl-incf calls)
+ (list :foreground color)))))
+ (let ((text (tp-set "computed" 'tp-layer-test-computed)))
+ (should (equal (get-text-property 0 'face text)
+ '(:foreground "red")))
+ (should (= calls 1))))))
+
+(ert-deftest tp-layer-test-literal-function-property-is-not-called ()
+ "Literal function values remain callbacks when a recipe is applied."
+ (tp-layer-test--isolated
+ (let* ((calls 0)
+ (callback (lambda (&rest _args) (cl-incf calls))))
+ (eval `(define-tp tp-layer-test-help ()
+ (list 'help-echo ,callback)))
+ (let ((text (tp-set "help" 'tp-layer-test-help)))
+ (should (eq (get-text-property 0 'help-echo text) callback))
+ (should (= calls 0))))))
(provide 'tp-layer-tests)
;;; tp-layer-tests.el ends here
diff --git a/tests/tp-managed-tests.el b/tests/tp-managed-tests.el
deleted file mode 100644
index d5c0110..0000000
--- a/tests/tp-managed-tests.el
+++ /dev/null
@@ -1,303 +0,0 @@
-;;; tp-managed-tests.el --- ERT tests for managed lifecycle APIs -*- lexical-binding: t -*-
-
-;;; Commentary:
-
-;; Stage 4 RED tests for additive managed lifecycle behavior. These
-;; tests intentionally drive public entry points and should fail until
-;; managed metadata, diagnostics, transactions, and theme generation are
-;; implemented.
-
-;;; Code:
-
-(require 'ert)
-(require 'tp)
-
-(defmacro tp-managed-tests--with-clean (&rest body)
- "Run BODY in a temp buffer with clean layer/reactive state."
- (declare (indent 0))
- `(unwind-protect
- (with-temp-buffer
- (tp-layer-reset)
- (tp-reactive-reset)
- (setq tp-reactive-observer-errors nil)
- ,@body)
- (tp-layer-reset)
- (tp-reactive-reset)
- (setq tp-reactive-observer-errors nil)))
-
-(defun tp-managed-tests--require-api (fn)
- "Assert FN exists and return its function binding."
- (should (fboundp fn))
- (symbol-function fn))
-
-(defun tp-managed-tests--raw-intervals ()
- "Return raw text and property intervals for the current buffer."
- (list (buffer-substring-no-properties (point-min) (point-max))
- (tp-intervals (point-min) (point-max) nil t)))
-
-(defun tp-managed-tests--managed-buffer-diagnostics ()
- "Call `tp-managed-buffer-diagnostics' after asserting it exists."
- (tp-managed-tests--require-api 'tp-managed-buffer-diagnostics)
- (tp-managed-buffer-diagnostics (current-buffer)))
-
-(defun tp-managed-tests--managed-layer-diagnostics (layer)
- "Call `tp-managed-layer-diagnostics' for LAYER after asserting it exists."
- (tp-managed-tests--require-api 'tp-managed-layer-diagnostics)
- (tp-managed-layer-diagnostics layer))
-
-(defun tp-managed-tests--managed-diagnostics ()
- "Call `tp-managed-diagnostics' after asserting it exists."
- (tp-managed-tests--require-api 'tp-managed-diagnostics)
- (tp-managed-diagnostics))
-
-(ert-deftest tp-managed-test-metadata-is-not-public-stack-or-rendered ()
- "Managed tp-meta is stripped from public stack query and rendered props."
- (tp-managed-tests--with-clean
- (insert "abcd")
- (tp-put-layer 1 4
- '(stage4-visible
- face (:foreground "red")
- help-echo "visible"
- tp-meta (:schema 1
- :entry-id stage4-entry-a
- :origin inline
- :args ("red" 7)))
- 0)
- (let* ((stack (tp-layer-stack-at 1))
- (top (cdr (assq 'stage4-visible stack)))
- (rendered (text-properties-at 1)))
- (should (assq 'stage4-visible stack))
- (should-not (plist-member top 'tp-meta))
- (should-not (plist-member rendered 'tp-meta))
- (should (equal (plist-get rendered 'face) '(:foreground "red")))
- (should (equal (plist-get rendered 'help-echo) "visible")))))
-
-(ert-deftest tp-managed-test-parameterized-mounted-layer-retains-args ()
- "Parameterized mounted layer diagnostics retain each entry's args."
- (tp-managed-tests--with-clean
- (insert "abcdefgh")
- (define-tp stage4-color (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (tp-put-layer 1 4 '(stage4-color "red" "blue") 0)
- (tp-put-layer 5 8 '(stage4-color "green" "black") 0)
- (let* ((diag (tp-managed-tests--managed-layer-diagnostics 'stage4-color))
- (entries (plist-get diag :entries))
- (args (mapcar (lambda (entry) (plist-get entry :args)) entries)))
- (should (member '("red" "blue") args))
- (should (member '("green" "black") args)))))
-
-(ert-deftest tp-managed-test-parameterized-mounted-layer-refreshes-after-redefine ()
- "Parameterized mounted entries re-render from stored args after redefine."
- (tp-managed-tests--with-clean
- (insert "abcdefgh")
- (define-tp stage4-redef (fg bg)
- `(face (:foreground ,fg :background ,bg)))
- (tp-put-layer 1 4 '(stage4-redef "red" "blue") 0)
- (tp-put-layer 5 8 '(stage4-redef "green" "black") 0)
- (define-tp stage4-redef (fg bg)
- `(face (:foreground ,fg :background ,bg :weight bold)))
- (should (equal (get-text-property 1 'face)
- '(:foreground "red" :background "blue" :weight bold)))
- (should (equal (get-text-property 5 'face)
- '(:foreground "green" :background "black" :weight bold)))))
-
-(ert-deftest tp-managed-test-attach-finds-inserted-managed-string ()
- "Attach registers layers copied in through a propertized string."
- (tp-managed-tests--with-clean
- (define-tp stage4-attached () '(face (:box t)))
- (let ((payload (copy-sequence "xy")))
- (tp-put-layer payload 'stage4-attached 0)
- (insert payload))
- (tp-managed-tests--require-api 'tp-attach-managed-layers)
- (should (equal (tp-attach-managed-layers 1 3 (current-buffer))
- '(stage4-attached)))
- (should (equal (tp-reactive-layer-buffers 'stage4-attached)
- (list (current-buffer))))))
-
-(ert-deftest tp-managed-test-detach-removes-managed-storage-and-keeps-rendered ()
- "Detach with KEEP-RENDERED removes managed storage but preserves visible props."
- (tp-managed-tests--with-clean
- (insert "abcd")
- (define-tp stage4-detach () '(face italic help-echo "kept"))
- (tp-put-layer 1 4 'stage4-detach 0)
- (tp-managed-tests--require-api 'tp-detach-managed-layers)
- (should (equal (tp-detach-managed-layers 1 4 (current-buffer) t)
- '(stage4-detach)))
- (should-not (plist-member (text-properties-at 1) 'tp-layers))
- (should-not (plist-member (text-properties-at 1) 'tp-meta))
- (should-not (plist-member (text-properties-at 1) 'tp-name))
- (should (eq (get-text-property 1 'face) 'italic))
- (should (equal (get-text-property 1 'help-echo) "kept"))
- (should-not (tp-reactive-layer-buffers 'stage4-detach))))
-
-(ert-deftest tp-managed-test-buffer-diagnostics-are-read-only ()
- "Managed buffer diagnostics do not mutate text, props, point, or modified state."
- (tp-managed-tests--with-clean
- (insert "abcd")
- (define-tp stage4-diag () '(face bold))
- (tp-put-layer 1 4 'stage4-diag 0)
- (goto-char 3)
- (set-buffer-modified-p nil)
- (let ((before-state (tp-managed-tests--raw-intervals))
- (before-point (point))
- (before-modified (buffer-modified-p))
- (before-undo buffer-undo-list))
- (let ((diag (tp-managed-tests--managed-buffer-diagnostics)))
- (should (plist-member diag :layers))
- (should (member 'stage4-diag (plist-get diag :layers))))
- (should (equal (tp-managed-tests--raw-intervals) before-state))
- (should (= (point) before-point))
- (should (eq (buffer-modified-p) before-modified))
- (should (eq buffer-undo-list before-undo)))))
-
-(ert-deftest tp-managed-test-layer-transaction-rolls-back-on-body-error ()
- "tp-layer-transaction restores raw properties when the body errors."
- (tp-managed-tests--with-clean
- (insert "abcdef")
- (define-tp stage4-base () '(face bold help-echo "base"))
- (define-tp stage4-temp () '(face italic help-echo "temp"))
- (tp-put-layer 1 6 'stage4-base 0)
- (let ((before (tp-managed-tests--raw-intervals)))
- (tp-managed-tests--require-api 'tp-layer-transaction)
- (let ((err (should-error
- (tp-layer-transaction
- 1 6 (current-buffer)
- (lambda ()
- (tp-put-layer 1 3 'stage4-temp 0)
- (error "stage4 boom"))))))
- (should (eq (car err) 'tp-layer-transaction-error)))
- (should (equal (tp-managed-tests--raw-intervals) before)))))
-
-(ert-deftest tp-managed-test-buffer-transaction-rolls-back-length-changes ()
- "Buffer rollback tracks insertions and deletions inside the live range."
- (dolist (mutation '(insert delete))
- (tp-managed-tests--with-clean
- (insert (propertize "abcdef" 'face 'bold))
- (let ((before (buffer-substring (point-min) (point-max))))
- (should-error
- (tp-layer-transaction
- 2 5 (current-buffer)
- (lambda ()
- (pcase mutation
- ('insert
- (goto-char 3)
- (insert (propertize "XYZ" 'help-echo "temporary")))
- ('delete
- (delete-region 3 4)))
- (error "length-changing rollback"))))
- (should (equal-including-properties
- (buffer-substring (point-min) (point-max))
- before))))))
-
-(ert-deftest tp-managed-test-layer-transaction-success-keeps-body-result ()
- "Successful transactions expose the body's result and changed ranges."
- (tp-managed-tests--with-clean
- (insert "abcd")
- (define-tp stage4-success () '(face bold))
- (let ((result
- (tp-layer-transaction
- 1 4 (current-buffer)
- (lambda ()
- (tp-push-layer 1 4 'stage4-success)
- :body-result))))
- (should (eq (plist-get result :status) 'ok))
- (should (eq (plist-get result :ok) t))
- (should (eq (plist-get result :result) :body-result))
- (should (plist-get result :changed-ranges)))))
-
-(ert-deftest tp-managed-test-layer-transaction-noerror-returns-structured-failure ()
- "NOERROR transaction failures return operation data and rollback status."
- (tp-managed-tests--with-clean
- (insert "abcdef")
- (define-tp stage4-base2 () '(face bold))
- (define-tp stage4-temp2 () '(face italic))
- (tp-put-layer 1 6 'stage4-base2 0)
- (let ((before (tp-managed-tests--raw-intervals)))
- (tp-managed-tests--require-api 'tp-layer-transaction)
- (let ((result (tp-layer-transaction
- 1 6 (current-buffer)
- (lambda ()
- (tp-put-layer 2 5 'stage4-temp2 0)
- (signal 'error '("stage4 noerror")))
- t)))
- (should (eq (plist-get result :status) 'error))
- (should (plist-get result :operation-id))
- (should (plist-member result :stage))
- (should (equal (plist-get result :range) '(1 . 6)))
- (should (eq (plist-get result :rollback-applied) t))
- (should (plist-get result :original-condition)))
- (should (equal (tp-managed-tests--raw-intervals) before)))))
-
-(ert-deftest tp-managed-test-string-transaction-restores-every-property-run ()
- "String rollback restores characters and every distinct property run."
- (tp-managed-tests--with-clean
- (let ((text (copy-sequence "abcdef")))
- (put-text-property 0 2 'face 'bold text)
- (put-text-property 2 4 'face 'italic text)
- (put-text-property 4 6 'help-echo "tail" text)
- (let ((before (copy-sequence text)))
- (should-error
- (tp-layer-transaction
- 0 6 text
- (lambda ()
- (set-text-properties 0 6 '(face underline) text)
- (signal 'error '("rollback string")))))
- (should (equal-including-properties text before))))))
-
-(ert-deftest tp-managed-test-fixed-seed-stack-state-machine ()
- "Fixed seeds preserve public stack order across varied operations."
- (dolist (seed '(1 7 42 747555))
- (tp-managed-tests--with-clean
- (insert "x")
- (dolist (name '(stage4-sm-a stage4-sm-b stage4-sm-c))
- (eval `(define-tp ,name () '(face bold))))
- (let ((state seed)
- (names '(stage4-sm-a stage4-sm-b stage4-sm-c))
- model)
- (dotimes (_ 40)
- (setq state (mod (+ (* state 1103515245) 12345) 2147483648))
- (pcase (% state 4)
- (0
- (let ((name (nth (% (/ state 4) 3) names)))
- (unless (memq name model)
- (tp-push-layer 1 2 name)
- (push name model))))
- (1
- (when model
- (tp-pop-layer 1 2)
- (setq model (cdr model))))
- (2
- (when (cdr model)
- (tp-move-layer 1 2 0 -1)
- (setq model (append (cdr model) (list (car model))))))
- (3
- (when model
- (tp-hide-layer 1 2 (car model))
- (tp-show-layer 1 2 (car model)))))
- (should (equal (mapcar #'car (tp-layer-stack-at 1)) model)))))))
-
-(ert-deftest tp-managed-test-theme-generation-diagnostics-increments-on-theme-hooks ()
- "Theme lifecycle diagnostics record generation and hook source."
- (tp-managed-tests--with-clean
- (insert "abcd")
- (define-tp stage4-theme () '(face (:foreground "red")))
- (tp-put-layer 1 4 'stage4-theme 0)
- (let* ((before (tp-managed-tests--managed-diagnostics))
- (before-theme (plist-get before :theme))
- (before-generation (plist-get before-theme :generation)))
- (should (integerp before-generation))
- (enable-theme 'user)
- (let* ((after-enable (tp-managed-tests--managed-diagnostics))
- (theme (plist-get after-enable :theme)))
- (should (> (plist-get theme :generation) before-generation))
- (should (eq (plist-get theme :last-hook-source) 'enable-theme))
- (should (member (plist-get theme :refresh-mode)
- '(:dependency-targeted :conservative)))
- (should (plist-get theme :refreshed-ranges)))
- (disable-theme 'user)
- (let* ((after-disable (tp-managed-tests--managed-diagnostics))
- (theme (plist-get after-disable :theme)))
- (should (eq (plist-get theme :last-hook-source) 'disable-theme))))))
-
-(provide 'tp-managed-tests)
-;;; tp-managed-tests.el ends here
diff --git a/tests/tp-render-tests.el b/tests/tp-render-tests.el
deleted file mode 100644
index 50600f6..0000000
--- a/tests/tp-render-tests.el
+++ /dev/null
@@ -1,1062 +0,0 @@
-;;; tp-render-tests.el --- ERT regression tests for tp-render.el -*- lexical-binding: t -*-
-
-;;; Commentary:
-
-;; Regression tests for confirmed bugs fixed in the reactive-render
-;; module (tp-render.el, with supporting fixes in tp-reactive.el).
-;; Each section is tagged with the canonical bug id it guards against.
-
-;;; Code:
-
-(require 'ert)
-(require 'tp)
-
-;; Reactive test variables must be dynamically bound so watcher and
-;; compute machinery can see them through `symbol-value'.
-(defvar tp-rt-b9-var nil)
-(defvar tp-rt-b10-data nil)
-(defvar tp-rt-b10-full nil)
-(defvar tp-rt-b11-face nil)
-(defvar tp-rt-b11b-color nil)
-(defvar tp-rt-b12-color nil)
-(defvar tp-rt-b13-text nil)
-(defvar tp-rt-b13b-text nil)
-(defvar tp-rt-b14-flag nil)
-(defvar tp-rt-b14-inv nil)
-(defvar tp-rt-b14b-init nil)
-(defvar tp-rt-b16-data nil)
-(defvar tp-rt-b16-comp nil)
-(defvar tp-rt-b16-count 0)
-(defvar tp-rt-b17-color nil)
-(defvar tp-rt-b17-text nil)
-(defvar tp-rt-b17b-color nil)
-(defvar tp-rt-b17b-echo nil)
-(defvar tp-rt-b18-text nil)
-(defvar tp-rt-b19-amount nil)
-(defvar tp-rt-b19s-amount nil)
-(defvar tp-rt-r1-color nil)
-(defvar tp-rt-r1b-color nil)
-(defvar tp-rt-r1c-color nil)
-(defvar tp-rt-r1d-color nil)
-(defvar tp-rt-r2-text nil)
-(defvar tp-rt-r2m-text nil)
-(defvar tp-rt-r2n-text nil)
-(defvar tp-rt-r2s-text nil)
-(defvar tp-rt-r3a-color nil)
-(defvar tp-rt-r3b-color nil)
-(defvar tp-rt-r3c-color nil)
-(defvar tp-rt-a02-old-color nil)
-(defvar tp-rt-a02-new-color nil)
-(defvar tp-rt-a11-data nil)
-(defvar tp-rt-a11-computed nil)
-(defvar tp-rt-a11-watched nil)
-(defvar tp-rt-a11-text nil)
-
-(defmacro tp-rt-with-cleanup (layers vars &rest body)
- "Run BODY, then undefine LAYERS and reset VARS to nil (teardown)."
- (declare (indent 2))
- `(unwind-protect
- (progn ,@body)
- ,@(mapcar (lambda (l) `(tp-undefine-layer ',l)) layers)
- ,@(mapcar (lambda (v) `(setq ,v nil)) vars)
- (setq tp-reactive-observer-errors nil)))
-
-;;; B9: sub-region tp-text on a string must splice, not replace the whole string
-
-(ert-deftest tp-render-test-tp-text-string-region-keeps-rest ()
- "Region-form tp-text on a string keeps the text outside the region."
- (let ((result (tp-set 0 1 '(tp-text "X") (copy-sequence "abc"))))
- (should (equal result "Xbc"))
- (should (equal (get-text-property 0 'tp-text result) "X"))
- ;; The preserved suffix must not receive the layer's props
- (should (null (get-text-property 1 'tp-text result)))
- (should (null (get-text-property 2 'tp-text result)))))
-
-(ert-deftest tp-render-test-tp-text-string-mid-region-splices ()
- "A mid-string tp-text region splices prefix + replacement + suffix."
- (let ((result (tp-set 1 2 '(face bold tp-text "XY") (copy-sequence "abc"))))
- (should (equal result "aXYc"))
- ;; Props only on the replaced span [1, 3)
- (should (null (get-text-property 0 'face result)))
- (should (eq (get-text-property 1 'face result) 'bold))
- (should (eq (get-text-property 2 'face result) 'bold))
- (should (null (get-text-property 3 'face result)))))
-
-(ert-deftest tp-render-test-tp-text-string-region-preserves-outside-props ()
- "Splicing keeps the original string's properties outside the region."
- (let* ((source (propertize "abc" 'face 'italic 'my-prop 1))
- (result (tp-set 1 2 '(tp-text "X") source)))
- (should (equal result "aXc"))
- ;; Prefix and suffix keep their original props
- (should (eq (get-text-property 0 'face result) 'italic))
- (should (eq (get-text-property 2 'face result) 'italic))
- ;; Replaced span preserves non-conflicting props (tp-set preserves)
- (should (eq (get-text-property 1 'my-prop result) 1))))
-
-(ert-deftest tp-render-test-tp-text-whole-string-still-replaces ()
- "Whole-string form still returns just the replacement (legacy semantics)."
- (let ((result (tp-set "2" 'face '(:background "green") 'tp-text "6")))
- (should (equal result "6"))
- (should (equal (get-text-property 0 'face result) '(:background "green")))
- (should (equal (get-text-property 0 'tp-text result) "6"))))
-
-;;; TP-A01 / TP-A03: initial tp-text application uses per-run properties
-
-(ert-deftest tp-render-test-initial-tp-text-keeps-string-property-runs ()
- "Initial string tp-text application does not smear position-zero props."
- (let* ((payload (concat (propertize "AB" 'face 'bold)
- (propertize "CD" 'face 'italic)))
- (result (tp-set "xxxx" 'tp-text payload)))
- (should (eq (get-text-property 0 'face result) 'bold))
- (should (eq (get-text-property 2 'face result) 'italic))))
-
-(ert-deftest tp-render-test-initial-tp-text-keeps-buffer-property-runs ()
- "Initial buffer tp-text application preserves every embedded prop run."
- (let ((payload (concat (propertize "AB" 'face 'bold)
- (propertize "CD" 'face 'italic))))
- (with-temp-buffer
- (insert "xxxx")
- (tp-set 1 5 (list 'tp-text payload))
- (should (eq (get-text-property 1 'face) 'bold))
- (should (eq (get-text-property 3 'face) 'italic)))))
-
-(ert-deftest tp-render-test-tp-text-explicit-nil-overrides-embedded-value ()
- "A caller-provided nil remains present and wins over embedded props."
- (let* ((payload (propertize "X" 'custom 'embedded))
- (result (tp-set "x" 'tp-text payload 'custom nil)))
- (should (equal (tp-member 0 'custom result) '(custom nil)))
- (with-temp-buffer
- (insert "x")
- (tp-set 1 2 (list 'tp-text payload 'custom nil))
- (should (equal (tp-member 1 'custom) '(custom nil))))))
-
-(ert-deftest tp-render-test-same-text-reset-removes-old-properties ()
- "A same-text tp-reset still replaces the complete property set."
- (with-temp-buffer
- (insert (propertize "AB" 'help-echo "old" 'face 'italic))
- (tp-reset 1 3 '(tp-text "AB" face bold))
- (should-not (plist-member (text-properties-at 1) 'help-echo))
- (should (eq (get-text-property 1 'face) 'bold)))
- (let* ((source (propertize "AB" 'help-echo "old" 'face 'italic))
- (result (tp-reset source 'tp-text "AB" 'face 'bold)))
- (should-not (plist-member (text-properties-at 0 result) 'help-echo))
- (should (eq (get-text-property 0 'face result) 'bold))))
-
-(ert-deftest tp-render-test-same-text-add-merges-existing-face ()
- "A same-text tp-add keeps add semantics while applying per-run props."
- (with-temp-buffer
- (insert (propertize "AB" 'face 'italic))
- (tp-add 1 3 '(tp-text "AB" face bold))
- (should (equal (get-text-property 1 'face) '(bold italic))))
- (let* ((source (propertize "AB" 'face 'italic))
- (result (tp-add source 'tp-text "AB" 'face 'bold)))
- (should (equal (get-text-property 0 'face result) '(bold italic))))
- (let* ((source (propertize "AB" 'face 'italic))
- (result (tp-add source 'tp-text nil 'face 'bold)))
- (should (equal (get-text-property 0 'face result) '(bold italic)))))
-
-;;; TP-A02: layer redefinition refreshes with full old/new ownership
-
-(ert-deftest tp-render-test-static-redefinition-refreshes-managed-region ()
- "A simple static redefinition refreshes an already-mounted layer."
- (tp-rt-with-cleanup (tp-rt-a02-static) ()
- (define-tp tp-rt-a02-static () '(face bold help-echo "old"))
- (with-temp-buffer
- (insert "Hello")
- (tp-push-layer 1 6 'tp-rt-a02-static)
- (define-tp tp-rt-a02-static () '(face italic))
- (should (eq (get-text-property 1 'face) 'italic))
- (should-not (plist-member (text-properties-at 1) 'help-echo)))))
-
-(ert-deftest tp-render-test-redefinition-preserves-external-value ()
- "A value changed after mounting is not deleted as stale layer output."
- (tp-rt-with-cleanup (tp-rt-a02-external) ()
- (define-tp tp-rt-a02-external () '(face bold help-echo "owned"))
- (with-temp-buffer
- (insert "Hello")
- (tp-push-layer 1 6 'tp-rt-a02-external)
- (put-text-property 1 6 'help-echo "external")
- (define-tp tp-rt-a02-external () '(face italic))
- (should (eq (get-text-property 1 'face) 'italic))
- (should (equal (get-text-property 1 'help-echo) "external")))))
-
-(ert-deftest tp-render-test-reactive-redefinition-removes-old-owned-keys ()
- "Reactive redefinition removes keys and nested face data it no longer owns."
- (tp-rt-with-cleanup
- (tp-rt-a02-reactive) (tp-rt-a02-old-color tp-rt-a02-new-color)
- (setq tp-rt-a02-old-color "red"
- tp-rt-a02-new-color "blue")
- (define-tp tp-rt-a02-reactive ()
- :props '(face (:foreground $tp-rt-a02-old-color)
- help-echo "old"))
- (with-temp-buffer
- (insert "Hello")
- (tp-push-layer 1 6 'tp-rt-a02-reactive)
- (define-tp tp-rt-a02-reactive ()
- :props '(face (:background $tp-rt-a02-new-color)))
- (let ((face (get-text-property 1 'face)))
- (should (equal (plist-get face :background) "blue"))
- (should-not (plist-member face :foreground)))
- (should-not (plist-member (text-properties-at 1) 'help-echo)))))
-
-;;; TP-A11: business computations fail; observers are isolated and recorded
-
-(ert-deftest tp-render-test-transform-error-propagates ()
- "Transform failures and non-string results both propagate."
- (tp-rt-with-cleanup
- (tp-rt-a11-transform tp-rt-a11-nonstring) (tp-rt-a11-text)
- (setq tp-rt-a11-text "raw")
- (define-tp tp-rt-a11-transform ()
- :props '(tp-text $tp-rt-a11-text)
- :transform (lambda (_text) (error "transform failed")))
- (should-error (tp-set "old" 'tp-rt-a11-transform)
- :type 'error)
- (define-tp tp-rt-a11-nonstring ()
- :props '(tp-text $tp-rt-a11-text)
- :transform (lambda (_text) 42))
- (should-error (tp-set "old" 'tp-rt-a11-nonstring)
- :type 'error)))
-
-(ert-deftest tp-render-test-compute-errors-propagate ()
- "Initial and update-time compute failures reach the caller."
- (tp-rt-with-cleanup (tp-rt-a11-initial tp-rt-a11-update)
- (tp-rt-a11-data tp-rt-a11-computed)
- (should-error
- (define-tp tp-rt-a11-initial ()
- :props '(help-echo $tp-rt-a11-computed)
- :compute '((tp-rt-a11-computed
- (lambda () (error "initial compute failed")))))
- :type 'error)
- (setq tp-rt-a11-data "ok")
- (define-tp tp-rt-a11-update ()
- :props '(help-echo $tp-rt-a11-computed)
- :data '(tp-rt-a11-data)
- :compute '((tp-rt-a11-computed
- (lambda ()
- (if (equal tp-rt-a11-data "ok")
- "ready"
- (error "update compute failed"))))))
- (should-error (setq tp-rt-a11-data "fail")
- :type 'error)))
-
-(ert-deftest tp-render-test-watcher-error-is-recorded-and-update-continues ()
- "Watcher failures are isolated, queryable, and do not block rendering."
- (tp-rt-with-cleanup (tp-rt-a11-watcher) (tp-rt-a11-watched)
- (setq tp-rt-a11-watched "red")
- (when (boundp 'tp-reactive-observer-errors)
- (set 'tp-reactive-observer-errors nil))
- (define-tp tp-rt-a11-watcher ()
- :props '(face (:foreground $tp-rt-a11-watched))
- :watch '((tp-rt-a11-watched
- (lambda (_new _old _layer)
- (error "watcher failed")))))
- (with-temp-buffer
- (insert "x")
- (tp-push-layer 1 2 'tp-rt-a11-watcher)
- (setq tp-rt-a11-watched "blue")
- (should (equal (plist-get (tp-at 1 'face) :foreground) "blue"))
- (should (boundp 'tp-reactive-observer-errors))
- (let ((failure (car (symbol-value 'tp-reactive-observer-errors))))
- (should (eq (plist-get failure :kind) 'watcher))
- (should (eq (plist-get failure :layer) 'tp-rt-a11-watcher))
- (should (eq (plist-get failure :symbol) 'tp-rt-a11-watched))
- (should (eq (car (plist-get failure :condition)) 'error))))))
-
-;;; B10: computed-variable path must not clobber sibling static attributes
-
-(ert-deftest tp-render-test-computed-update-keeps-static-siblings ()
- "A computed update deep-merges, keeping static nested attributes."
- (tp-rt-with-cleanup (tp-rt-b10-layer) (tp-rt-b10-data tp-rt-b10-full)
- (setq tp-rt-b10-data "red")
- (define-tp tp-rt-b10-layer ()
- :props '(face (:foreground $tp-rt-b10-full :background "green"))
- :data '(tp-rt-b10-data)
- :compute '((tp-rt-b10-full (lambda () (concat "col-" tp-rt-b10-data)))))
- (setq tp-rt-b10-data "blue")
- (let ((face (plist-get (cdr (assoc 'tp-rt-b10-layer tp-layer-alist)) 'face)))
- (should (equal (plist-get face :foreground) "col-blue"))
- ;; The sibling static attribute must survive the update
- (should (equal (plist-get face :background) "green")))))
-
-;;; B11: reactive refresh replaces the layer's own keys instead of accumulating
-
-(ert-deftest tp-render-test-reactive-refresh-replaces-face ()
- "Changing a symbol-valued face variable replaces the face, not stacks it."
- (tp-rt-with-cleanup (tp-rt-b11-layer) (tp-rt-b11-face)
- (setq tp-rt-b11-face 'bold)
- (define-tp tp-rt-b11-layer () '(face $tp-rt-b11-face))
- (with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 'tp-rt-b11-layer)
- (should (eq (get-text-property 1 'face) 'bold))
- (setq tp-rt-b11-face 'italic)
- ;; Must be italic alone, not (italic bold)
- (should (eq (get-text-property 1 'face) 'italic)))))
-
-(ert-deftest tp-render-test-reactive-refresh-keeps-unrelated-props ()
- "Reactive refresh leaves property keys the layer does not own alone."
- (tp-rt-with-cleanup (tp-rt-b11b-layer) (tp-rt-b11b-color)
- (setq tp-rt-b11b-color "red")
- (define-tp tp-rt-b11b-layer () '(face (:foreground $tp-rt-b11b-color)))
- (with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 'tp-rt-b11b-layer)
- (put-text-property 1 6 'help-echo "keep me")
- (setq tp-rt-b11b-color "green")
- (should (equal (plist-get (get-text-property 1 'face) :foreground) "green"))
- (should (equal (get-text-property 1 'help-echo) "keep me")))))
-
-;;; B12: setq-local must not leak into the global layer definition
-
-(ert-deftest tp-render-test-setq-local-does-not-touch-global-def ()
- "A buffer-local change re-renders the buffer but keeps the global def."
- (tp-rt-with-cleanup (tp-rt-b12-layer) ()
- (setq-default tp-rt-b12-color "red")
- (define-tp tp-rt-b12-layer () '(face (:foreground $tp-rt-b12-color)))
- (let ((buf-a (generate-new-buffer " tp-rt-b12-a"))
- (buf-b (generate-new-buffer " tp-rt-b12-b")))
- (unwind-protect
- (progn
- (with-current-buffer buf-a
- (insert "Hello")
- (tp-set 1 6 'tp-rt-b12-layer))
- (with-current-buffer buf-b
- (insert "Hello")
- (tp-set 1 6 'tp-rt-b12-layer))
- (with-current-buffer buf-a
- (setq-local tp-rt-b12-color "purple"))
- ;; Buffer A is re-rendered with its local value
- (with-current-buffer buf-a
- (should (equal (plist-get (get-text-property 1 'face) :foreground)
- "purple")))
- ;; The GLOBAL definition must not absorb the local value
- (should (equal (plist-get
- (plist-get (cdr (assoc 'tp-rt-b12-layer tp-layer-alist))
- 'face)
- :foreground)
- "red"))
- (should (equal (default-value 'tp-rt-b12-color) "red"))
- ;; Other buffers keep rendering the global value
- (with-current-buffer buf-b
- (should (equal (plist-get (get-text-property 1 'face) :foreground)
- "red"))))
- (kill-buffer buf-a)
- (kill-buffer buf-b)
- (setq-default tp-rt-b12-color nil)))))
-
-;;; B13: reactive tp-text replacement preserves unrelated properties
-
-(ert-deftest tp-render-test-reactive-text-update-preserves-other-props ()
- "Replacing reactive text keeps properties other layers put on the region."
- (tp-rt-with-cleanup (tp-rt-b13-layer) (tp-rt-b13-text)
- (setq tp-rt-b13-text "aaa")
- (define-tp tp-rt-b13-layer () '(face bold tp-text $tp-rt-b13-text))
- (with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 'tp-rt-b13-layer)
- (put-text-property 1 3 'my-other-prop 42)
- (setq tp-rt-b13-text "bbb")
- (should (equal (buffer-substring-no-properties (point-min) (point-max))
- "bbb"))
- ;; The unrelated property survives the text replacement
- (should (eq (get-text-property 1 'my-other-prop) 42))
- ;; The layer's own props are still applied
- (should (eq (get-text-property 1 'face) 'bold)))))
-
-(ert-deftest tp-render-test-reactive-text-same-text-preserves-other-props ()
- "A same-text properties-only update keeps unrelated properties too."
- (tp-rt-with-cleanup (tp-rt-b13b-layer) (tp-rt-b13b-text)
- (setq tp-rt-b13b-text "emacs")
- (define-tp tp-rt-b13b-layer () '(tp-text $tp-rt-b13b-text))
- (with-temp-buffer
- (insert "emacs")
- (tp-set 1 6 'tp-rt-b13b-layer)
- (put-text-property 1 6 'my-other-prop 'yes)
- ;; Same text, new embedded properties
- (setq tp-rt-b13b-text (propertize "emacs" 'face 'bold))
- (should (eq (get-text-property 1 'face) 'bold))
- (should (eq (get-text-property 1 'my-other-prop) 'yes)))))
-
-;;; B14: computed values of nil must propagate
-
-(ert-deftest tp-render-test-computed-nil-propagates-on-update ()
- "A compute function returning nil updates the variable and the layer."
- (tp-rt-with-cleanup (tp-rt-b14-layer) (tp-rt-b14-flag tp-rt-b14-inv)
- (setq tp-rt-b14-flag t)
- (define-tp tp-rt-b14-layer ()
- :props '(invisible $tp-rt-b14-inv)
- :data '(tp-rt-b14-flag)
- :compute '((tp-rt-b14-inv (lambda () tp-rt-b14-flag))))
- (should (eq tp-rt-b14-inv t))
- (setq tp-rt-b14-flag nil)
- ;; nil is a legitimate computed value, not an error sentinel
- (should (eq tp-rt-b14-inv nil))
- (should (eq (plist-get (cdr (assoc 'tp-rt-b14-layer tp-layer-alist))
- 'invisible)
- nil))))
-
-(ert-deftest tp-render-test-computed-nil-applies-initially ()
- "An initial computed value of nil overwrites a stale non-nil value."
- (tp-rt-with-cleanup (tp-rt-b14b-layer) (tp-rt-b14b-init)
- (setq tp-rt-b14b-init 'stale)
- (define-tp tp-rt-b14b-layer ()
- :props '(invisible $tp-rt-b14b-init)
- :compute '((tp-rt-b14b-init (lambda () nil))))
- (should (eq tp-rt-b14b-init nil))))
-
-;;; B16: no watcher recursion from nested variable writes
-
-(ert-deftest tp-render-test-compute-runs-once-per-change ()
- "One data change runs each compute function exactly once (no recursion)."
- (tp-rt-with-cleanup (tp-rt-b16-layer) (tp-rt-b16-data tp-rt-b16-comp)
- (setq tp-rt-b16-data "a" tp-rt-b16-count 0)
- (define-tp tp-rt-b16-layer ()
- :props '(help-echo $tp-rt-b16-comp)
- :data '(tp-rt-b16-data)
- :compute '((tp-rt-b16-comp
- (lambda ()
- (setq tp-rt-b16-count (1+ tp-rt-b16-count))
- (concat tp-rt-b16-data "!")))))
- (with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 'tp-rt-b16-layer)
- (setq tp-rt-b16-count 0)
- (setq tp-rt-b16-data "b")
- ;; The nested (set comp ...) must queue its re-render, not re-enter
- ;; the compute machinery.
- (should (= tp-rt-b16-count 1))
- ;; The nested change's re-render still lands in the buffer
- (should (equal tp-rt-b16-comp "b!"))
- (should (equal (get-text-property 1 'help-echo) "b!")))))
-
-;;; B17: batched entries must union WHERE and the tp-text-affected flag
-
-(ert-deftest tp-render-test-batch-tp-text-flag-is-sticky ()
- "A tp-text change deferred after a non-tp-text change still replaces text."
- (tp-rt-with-cleanup (tp-rt-b17-layer) (tp-rt-b17-color tp-rt-b17-text)
- (setq tp-rt-b17-color "red" tp-rt-b17-text "one")
- (define-tp tp-rt-b17-layer ()
- '(face (:foreground $tp-rt-b17-color) tp-text $tp-rt-b17-text))
- (with-temp-buffer
- (insert "one")
- (tp-set 1 4 'tp-rt-b17-layer)
- (tp-with-batch-updates
- (setq tp-rt-b17-color "blue") ; first change: no tp-text
- (setq tp-rt-b17-text "two")) ; second change: tp-text affected
- (should (equal (buffer-substring-no-properties (point-min) (point-max))
- "two"))
- (should (equal (plist-get (get-text-property 1 'face) :foreground)
- "blue")))))
-
-(ert-deftest tp-render-test-batch-where-widens-to-all-buffers ()
- "A global change after a buffer-local one must reach other buffers."
- (tp-rt-with-cleanup (tp-rt-b17b-layer) ()
- (setq-default tp-rt-b17b-color "red")
- (setq-default tp-rt-b17b-echo "old")
- (define-tp tp-rt-b17b-layer ()
- '(face (:foreground $tp-rt-b17b-color) help-echo $tp-rt-b17b-echo))
- (let ((buf-a (generate-new-buffer " tp-rt-b17b-a"))
- (buf-b (generate-new-buffer " tp-rt-b17b-b")))
- (unwind-protect
- (progn
- (with-current-buffer buf-a
- (insert "Hello") (tp-set 1 6 'tp-rt-b17b-layer))
- (with-current-buffer buf-b
- (insert "Hello") (tp-set 1 6 'tp-rt-b17b-layer))
- (with-current-buffer buf-a
- (tp-with-batch-updates
- (setq-local tp-rt-b17b-color "blue") ; WHERE = buf-a
- (setq tp-rt-b17b-echo "new"))) ; WHERE = global
- ;; The global change must not be trapped in buf-a's WHERE
- (with-current-buffer buf-b
- (should (equal (get-text-property 1 'help-echo) "new"))
- (should (equal (plist-get (get-text-property 1 'face) :foreground)
- "red")))
- ;; buf-a gets both, with its local color honored
- (with-current-buffer buf-a
- (should (equal (get-text-property 1 'help-echo) "new"))
- (should (equal (plist-get (get-text-property 1 'face) :foreground)
- "blue"))))
- (kill-buffer buf-a)
- (kill-buffer buf-b)
- (setq-default tp-rt-b17b-color nil)
- (setq-default tp-rt-b17b-echo nil)))))
-
-;;; B18: multi-interval reactive strings keep per-interval styling
-
-(ert-deftest tp-render-test-reactive-text-keeps-per-interval-props ()
- "A propertized reactive string renders each interval's own props."
- (tp-rt-with-cleanup (tp-rt-b18-layer) (tp-rt-b18-text)
- (setq tp-rt-b18-text "init")
- (define-tp tp-rt-b18-layer () '(tp-text $tp-rt-b18-text))
- (with-temp-buffer
- (insert "init")
- (tp-set 1 5 'tp-rt-b18-layer)
- (setq tp-rt-b18-text (concat (propertize "AB" 'face 'bold)
- (propertize "CD" 'face 'italic)))
- (should (equal (buffer-substring-no-properties (point-min) (point-max))
- "ABCD"))
- ;; Position-0 props must not smear over the whole region
- (should (eq (get-text-property 1 'face) 'bold))
- (should (eq (get-text-property 2 'face) 'bold))
- (should (eq (get-text-property 3 'face) 'italic))
- (should (eq (get-text-property 4 'face) 'italic)))))
-
-;;; B19: :transform applies on the initial nil-tp-text render too
-
-(ert-deftest tp-render-test-transform-applies-on-initial-render ()
- "First render of a nil tp-text layer shows the transformed text."
- (tp-rt-with-cleanup (tp-rt-b19-layer) (tp-rt-b19-amount)
- (setq tp-rt-b19-amount nil)
- (define-tp tp-rt-b19-layer ()
- :props '(face bold tp-text $tp-rt-b19-amount)
- :transform (lambda (s) (concat "$" s)))
- (with-temp-buffer
- (insert "5.00")
- (tp-set 1 5 'tp-rt-b19-layer)
- ;; Initial rendering must match later reactive renderings
- (should (equal (buffer-substring-no-properties (point-min) (point-max))
- "$5.00"))
- ;; The model (variable and tp-text prop) keeps the raw value
- (should (equal tp-rt-b19-amount "5.00"))
- (should (equal (get-text-property 1 'tp-text) "5.00"))
- (should (eq (get-text-property 1 'face) 'bold))
- ;; And a later update stays consistent
- (setq tp-rt-b19-amount "6.00")
- (should (equal (buffer-substring-no-properties (point-min) (point-max))
- "$6.00")))))
-
-(ert-deftest tp-render-test-transform-applies-on-initial-string-render ()
- "String form of a nil tp-text layer also shows the transformed text."
- (tp-rt-with-cleanup (tp-rt-b19s-layer) (tp-rt-b19s-amount)
- (setq tp-rt-b19s-amount nil)
- (define-tp tp-rt-b19s-layer ()
- :props '(face bold tp-text $tp-rt-b19s-amount)
- :transform (lambda (s) (concat "$" s)))
- (let ((result (tp-set "5.00" 'tp-rt-b19s-layer)))
- (should (equal result "$5.00"))
- ;; Model keeps the raw value
- (should (equal tp-rt-b19s-amount "5.00"))
- (should (equal (get-text-property 0 'tp-text result) "5.00"))
- (should (eq (get-text-property 0 'face result) 'bold)))))
-
-;;; R1 (0.3.0): reactive buffer registry replaces the buffer-list scan
-
-(ert-deftest tp-render-test-registry-update-visits-only-registered ()
- "A reactive update walks only registered buffers, not `buffer-list'."
- (tp-rt-with-cleanup (tp-rt-r1-layer) (tp-rt-r1-color)
- (setq tp-rt-r1-color "red")
- (define-tp tp-rt-r1-layer () '(face (:foreground $tp-rt-r1-color)))
- (let ((buf-a (generate-new-buffer " tp-rt-r1-a"))
- (buf-b (generate-new-buffer " tp-rt-r1-b"))
- (visited nil))
- (unwind-protect
- (progn
- (with-current-buffer buf-a
- (insert "Hello")
- (tp-set 1 6 'tp-rt-r1-layer))
- (with-current-buffer buf-b (insert "Hello"))
- ;; Applying through tp-ops registered the buffer
- (should (equal (tp-reactive-layer-buffers 'tp-rt-r1-layer)
- (list buf-a)))
- ;; Count per-buffer visits of the update walk
- (let ((orig (symbol-function 'tp--render-visit-buffer)))
- (cl-letf (((symbol-function 'tp--render-visit-buffer)
- (lambda (buf fn)
- (push buf visited)
- (funcall orig buf fn))))
- (setq tp-rt-r1-color "blue")))
- ;; Only the registered buffer was visited
- (should (equal visited (list buf-a)))
- (with-current-buffer buf-a
- (should (equal (plist-get (get-text-property 1 'face)
- :foreground)
- "blue"))))
- (kill-buffer buf-a)
- (kill-buffer buf-b)))))
-
-(ert-deftest tp-render-test-registry-prunes-on-kill-buffer ()
- "Killing a buffer removes it from the layer-buffer registry."
- (tp-rt-with-cleanup (tp-rt-r1b-layer) (tp-rt-r1b-color)
- (setq tp-rt-r1b-color "red")
- (define-tp tp-rt-r1b-layer () '(face (:foreground $tp-rt-r1b-color)))
- (let ((buf (generate-new-buffer " tp-rt-r1b")))
- (unwind-protect
- (progn
- (with-current-buffer buf
- (insert "Hello")
- (tp-set 1 6 'tp-rt-r1b-layer))
- (should (equal (tp-reactive-layer-buffers 'tp-rt-r1b-layer)
- (list buf)))
- (kill-buffer buf)
- ;; The kill-buffer hook pruned the raw registry entry ...
- (should-not (memq buf (gethash 'tp-rt-r1b-layer
- tp--layer-buffers)))
- ;; ... and the accessor answers "known: none", NOT `unknown'.
- (should (null (tp-reactive-layer-buffers 'tp-rt-r1b-layer)))
- (should-not (eq (tp-reactive-layer-buffers 'tp-rt-r1b-layer)
- 'unknown)))
- (when (buffer-live-p buf) (kill-buffer buf))))))
-
-(ert-deftest tp-render-test-registry-unknown-full-scan-learns ()
- "An `unknown' layer falls back to a full scan and learns its buffers."
- (tp-rt-with-cleanup (tp-rt-r1c-layer) (tp-rt-r1c-color)
- (setq tp-rt-r1c-color "red")
- (define-tp tp-rt-r1c-layer () '(face (:foreground $tp-rt-r1c-color)))
- (let ((buf (generate-new-buffer " tp-rt-r1c")))
- (unwind-protect
- (progn
- (with-current-buffer buf
- (insert "Hello")
- (tp-set 1 6 'tp-rt-r1c-layer))
- ;; Simulate a buffer that got the layer outside the
- ;; registering paths: erase the registry knowledge.
- (remhash 'tp-rt-r1c-layer tp--layer-buffers)
- (should (eq (tp-reactive-layer-buffers 'tp-rt-r1c-layer)
- 'unknown))
- ;; The update still reaches the buffer (conservative fallback)
- (setq tp-rt-r1c-color "blue")
- (with-current-buffer buf
- (should (equal (plist-get (get-text-property 1 'face)
- :foreground)
- "blue")))
- ;; ... and the scan registered the buffer it found (learning)
- (should (equal (tp-reactive-layer-buffers 'tp-rt-r1c-layer)
- (list buf))))
- (kill-buffer buf)))))
-
-(ert-deftest tp-render-test-track-buffer-closes-string-insert-gap ()
- "`tp-reactive-track-buffer' registers a buffer filled by string insert."
- (tp-rt-with-cleanup (tp-rt-r1d-layer) (tp-rt-r1d-color)
- (setq tp-rt-r1d-color "red")
- (define-tp tp-rt-r1d-layer () '(face (:foreground $tp-rt-r1d-color)))
- (let ((buf-a (generate-new-buffer " tp-rt-r1d-a"))
- (buf-b (generate-new-buffer " tp-rt-r1d-b")))
- (unwind-protect
- (progn
- (with-current-buffer buf-a
- (insert "Hello")
- (tp-set 1 6 'tp-rt-r1d-layer))
- ;; Inserting an already-propertized STRING bypasses the
- ;; registering buffer operations.
- (let ((s (tp-set "Hi" 'tp-rt-r1d-layer)))
- (with-current-buffer buf-b (insert s)))
- (should-not (memq buf-b
- (tp-reactive-layer-buffers 'tp-rt-r1d-layer)))
- ;; The layer is known, so buf-b is NOT updated (the gap) ...
- (setq tp-rt-r1d-color "blue")
- (with-current-buffer buf-b
- (should (equal (plist-get (get-text-property 1 'face)
- :foreground)
- "red")))
- ;; ... until tp-reactive-track-buffer closes it.
- (should (equal (with-current-buffer buf-b
- (tp-reactive-track-buffer))
- '(tp-rt-r1d-layer)))
- (should (memq buf-b
- (tp-reactive-layer-buffers 'tp-rt-r1d-layer)))
- (setq tp-rt-r1d-color "green")
- (with-current-buffer buf-b
- (should (equal (plist-get (get-text-property 1 'face)
- :foreground)
- "green")))
- (with-current-buffer buf-a
- (should (equal (plist-get (get-text-property 1 'face)
- :foreground)
- "green"))))
- (kill-buffer buf-a)
- (kill-buffer buf-b)))))
-
-;;; R2 (0.3.0): minimal-diff tp-text replacement
-
-(ert-deftest tp-render-test-minimal-diff-point-in-prefix-stays ()
- "Point in the common prefix survives a reactive text edit unmoved."
- (tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
- (setq tp-rt-r2-text "abcdef")
- (define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
- (with-temp-buffer
- (insert "abcdef")
- (tp-set 1 7 'tp-rt-r2-layer)
- (goto-char 2) ; inside the common prefix "ab"
- (setq tp-rt-r2-text "abXYef")
- (should (equal (buffer-substring-no-properties (point-min) (point-max))
- "abXYef"))
- (should (= (point) 2)))))
-
-(ert-deftest tp-render-test-minimal-diff-point-in-suffix-stays ()
- "Point in the common suffix stays glued to its character."
- (tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
- (setq tp-rt-r2-text "abcdef")
- (define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
- (with-temp-buffer
- (insert "abcdef")
- (tp-set 1 7 'tp-rt-r2-layer)
- (goto-char 6) ; on the "f" of the suffix "ef"
- ;; Same-length edit: point must not move at all
- (setq tp-rt-r2-text "abXYef")
- (should (= (point) 6))
- (should (eq (char-after) ?f))
- ;; Length-changing edit: point stays glued to its character
- (setq tp-rt-r2-text "abXYZWef")
- (should (= (point) 8))
- (should (eq (char-after) ?f)))))
-
-(ert-deftest tp-render-test-minimal-diff-point-inside-diff-clamps ()
- "Point inside the differing span ends up at the edit start."
- (tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
- (setq tp-rt-r2-text "abcdef")
- (define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
- (with-temp-buffer
- (insert "abcdef")
- (tp-set 1 7 'tp-rt-r2-layer)
- (goto-char 4) ; on "d", inside the "cd" -> "XY" span
- (setq tp-rt-r2-text "abXYef")
- (should (= (point) 3)))))
-
-(ert-deftest tp-render-test-minimal-diff-markers-survive ()
- "Markers in the unchanged prefix and suffix survive a text update."
- (tp-rt-with-cleanup (tp-rt-r2m-layer) (tp-rt-r2m-text)
- (setq tp-rt-r2m-text "abcdef")
- (define-tp tp-rt-r2m-layer () '(tp-text $tp-rt-r2m-text))
- (with-temp-buffer
- (insert "abcdef")
- (tp-set 1 7 'tp-rt-r2m-layer)
- (let ((m-prefix (copy-marker 2)) ; on "b"
- (m-suffix (copy-marker 6))) ; on "f"
- (setq tp-rt-r2m-text "abXYZef") ; "cd" -> "XYZ", one char longer
- (should (equal (buffer-substring-no-properties (point-min)
- (point-max))
- "abXYZef"))
- (should (= (marker-position m-prefix) 2))
- (should (eq (char-after m-prefix) ?b))
- (should (= (marker-position m-suffix) 7))
- (should (eq (char-after m-suffix) ?f))
- (set-marker m-prefix nil)
- (set-marker m-suffix nil)))))
-
-;;; TXT-1: the suffix-boundary marker must track its character
-
-(defun tp-rt--txt1-marker-after-edit (old new marker-offset)
- "Run a minimal-diff replacement of OLD by NEW with a boundary marker.
-Insert \"HEAD \" OLD \" TAIL\" in a temp buffer, tag OLD with a
-tp-name, put an insertion-type-nil marker at OLD's start plus
-MARKER-OFFSET, replace via `tp--replace-reactive-text-in-buffer' and
-return (MARKER-POSITION CHAR-AT-MARKER ORIGINAL-CHAR)."
- (with-temp-buffer
- (insert "HEAD ")
- (let ((m-start (point)))
- (insert old " TAIL")
- (put-text-property m-start (+ m-start (length old))
- 'tp-name 'tp-rt-txt1-layer)
- (let* ((mpos (+ m-start marker-offset))
- (mchar (char-after mpos))
- (mk (copy-marker mpos)))
- (tp--replace-reactive-text-in-buffer 'tp-rt-txt1-layer new nil)
- (prog1 (list (marker-position mk) (char-after mk) mchar)
- (set-marker mk nil))))))
-
-(ert-deftest tp-render-test-minimal-diff-suffix-start-marker-tracks ()
- "A marker on the FIRST character of the preserved suffix tracks it.
-TXT-1: delete-then-insert collapsed such a marker onto the edit
-start, stranding it before the inserted text; insert-then-delete
-shifts it right with its character. Grow, same-length (the clearest
-docstring violation) and shrink edits are all covered."
- ;; Grow: "0" -> "42"; marker on the space before "items" (offset 8).
- (pcase-let ((`(,pos ,got ,want)
- (tp-rt--txt1-marker-after-edit
- "count: 0 items" "count: 42 items" 8)))
- (should (eq got want))
- (should (= pos 15))) ; 14 shifted right by 1
- ;; Same length: "0" -> "9"; the marker's correct position is
- ;; numerically unchanged.
- (pcase-let ((`(,pos ,got ,want)
- (tp-rt--txt1-marker-after-edit
- "count: 0 items" "count: 9 items" 8)))
- (should (eq got want))
- (should (= pos 14)))
- ;; Shrink: "42" -> "0".
- (pcase-let ((`(,pos ,got ,want)
- (tp-rt--txt1-marker-after-edit
- "count: 42 items" "count: 0 items" 9)))
- (should (eq got want))
- (should (= pos 14))))
-
-(ert-deftest tp-render-test-minimal-diff-deleted-char-marker-at-edit-end ()
- "A marker whose character was deleted ends at the END of the edit.
-The documented side effect of inserting before deleting; previously
-such markers collapsed to the edit start. Either way they stay
-inside the replacement span."
- ;; "100" -> "42": marker on the middle "0" (strictly inside the
- ;; edited span) ends after the inserted "42".
- (pcase-let ((`(,pos ,_got ,_want)
- (tp-rt--txt1-marker-after-edit
- "count: 100 items" "count: 42 items" 8)))
- ;; Edit span starts at buffer position 13 ("100"), insert "42":
- ;; the marker lands at the end of the inserted text.
- (should (= pos 15))))
-
-(ert-deftest tp-render-test-minimal-diff-suffix-marker-real-path ()
- "The suffix-start marker tracks through a real setq-driven update."
- (tp-rt-with-cleanup (tp-rt-r2s-layer) (tp-rt-r2s-text)
- (setq tp-rt-r2s-text "count: 0 items")
- (define-tp tp-rt-r2s-layer () '(tp-text $tp-rt-r2s-text))
- (with-temp-buffer
- (insert "count: 0 items")
- (tp-set 1 15 'tp-rt-r2s-layer)
- (let ((m (copy-marker 9))) ; the space before "items"
- (setq tp-rt-r2s-text "count: 42 items")
- (should (equal (buffer-substring-no-properties (point-min)
- (point-max))
- "count: 42 items"))
- (should (eq (char-after m) ?\s))
- (should (= (marker-position m) 10))
- (set-marker m nil)))))
-
-(ert-deftest tp-render-test-minimal-diff-identical-update-is-noop ()
- "An identical-text reactive replacement leaves the buffer unmodified."
- (tp-rt-with-cleanup (tp-rt-r2n-layer) (tp-rt-r2n-text)
- (setq tp-rt-r2n-text "emacs")
- (define-tp tp-rt-r2n-layer () '(face bold tp-text $tp-rt-r2n-text))
- (with-temp-buffer
- (insert "emacs")
- (tp-set 1 6 'tp-rt-r2n-layer)
- (set-buffer-modified-p nil)
- (save-excursion
- (tp--replace-reactive-text-in-buffer
- 'tp-rt-r2n-layer "emacs" (tp-layer-props 'tp-rt-r2n-layer t)))
- ;; No text edit and no property churn: the flag must stay clear
- (should-not (buffer-modified-p))
- (should (equal (buffer-substring-no-properties (point-min) (point-max))
- "emacs"))
- (should (eq (get-text-property 1 'face) 'bold)))))
-
-;;; ARCH-4: the pending queue must survive neither reset nor errors
-
-(defvar tp-rt-a4-face nil)
-(defvar tp-rt-a4-color nil)
-
-(ert-deftest tp-render-test-reactive-reset-clears-pending-queue ()
- "tp-reactive-reset drops queued batch re-renders (ARCH-4).
-Stranded entries would otherwise survive the reset and replay against
-freshly (re)defined layers on the next flush."
- (unwind-protect
- (progn
- (tp--queue-batch-update 'tp-rt-a4-ghost 'tp-rt-a4-ghost-var nil nil)
- (should tp--batch-update-pending)
- (tp-reactive-reset)
- (should (null tp--batch-update-pending)))
- (setq tp--batch-update-pending nil)))
-
-(ert-deftest tp-render-test-error-escaping-update-flushes-nested-queue ()
- "An error escaping a re-render cannot strand nested queued updates.
-A modification hook that writes a second reactive variable and then
-signals used to strand the nested entry in the global queue - the
-flush tail sat outside any unwind-protect. The flush now runs as the
-update unwinds, so the nested variable's re-render still lands and
-the queue is drained (ARCH-4)."
- (setq tp-rt-a4-face 'bold
- tp-rt-a4-color "red")
- (unwind-protect
- (progn
- (define-tp tp-rt-a4-layer-a () '(face $tp-rt-a4-face))
- (define-tp tp-rt-a4-layer-b ()
- '(face (:foreground $tp-rt-a4-color)))
- (with-temp-buffer
- (insert "Hello world")
- (tp-set 1 6 'tp-rt-a4-layer-a)
- (tp-set 7 12 'tp-rt-a4-layer-b)
- (let ((armed t))
- (add-hook 'before-change-functions
- (lambda (_beg _end)
- (when armed
- (setq armed nil)
- ;; Nested reactive write from within the
- ;; re-render: goes to the global queue.
- (setq tp-rt-a4-color "green")
- (error "boom from modification hook")))
- nil t)
- (should-error (setq tp-rt-a4-face 'italic))
- ;; The nested entry was flushed on the way out, not
- ;; stranded...
- (should (null tp--batch-update-pending))
- ;; ...and its re-render landed despite the error.
- (should (equal (get-text-property 7 'face)
- '(:foreground "green"))))))
- (tp-undefine-layer 'tp-rt-a4-layer-a)
- (tp-undefine-layer 'tp-rt-a4-layer-b)
- (setq tp-rt-a4-face nil
- tp-rt-a4-color nil
- tp--batch-update-pending nil)))
-
-;;; R3 (0.3.0): anonymous-layer garbage collection
-
-(ert-deftest tp-render-test-gc-collects-unreferenced-anonymous-layer ()
- "GC collects an anonymous layer whose only buffer was killed."
- (setq tp-rt-r3a-color "red")
- (let ((buf (generate-new-buffer " tp-rt-r3a"))
- (name nil))
- (unwind-protect
- (progn
- (with-current-buffer buf
- (insert "Hello")
- (tp-set 1 6 '(face (:foreground $tp-rt-r3a-color)))
- (setq name (get-text-property 1 'tp-name)))
- (should name)
- (should (assoc name tp-layer-alist))
- (kill-buffer buf)
- (should (memq name (tp-gc-anonymous-layers)))
- (should-not (assoc name tp-layer-alist))
- (should-not (rassq name tp--anonymous-layer-registry)))
- (when (buffer-live-p buf) (kill-buffer buf))
- (when (and name (assoc name tp-layer-alist))
- (tp-undefine-layer name))
- (setq tp-rt-r3a-color nil))))
-
-(ert-deftest tp-render-test-gc-keeps-layer-still-displayed ()
- "GC keeps an anonymous layer that a live buffer still shows."
- (setq tp-rt-r3b-color "red")
- (let ((buf (generate-new-buffer " tp-rt-r3b"))
- (name nil))
- (unwind-protect
- (progn
- (with-current-buffer buf
- (insert "Hello")
- (tp-set 1 6 '(face (:foreground $tp-rt-r3b-color)))
- (setq name (get-text-property 1 'tp-name)))
- (should name)
- (should-not (memq name (tp-gc-anonymous-layers)))
- (should (assoc name tp-layer-alist)))
- (kill-buffer buf)
- (when (and name (assoc name tp-layer-alist))
- (tp-undefine-layer name))
- (setq tp-rt-r3b-color nil))))
-
-(ert-deftest tp-render-test-gc-keeps-unknown-registry-layer ()
- "GC keeps an anonymous layer whose registry state is `unknown'."
- (setq tp-rt-r3c-color "red")
- (let* ((s (tp-set "Hello" '(face (:foreground $tp-rt-r3c-color))))
- (name (get-text-property 0 'tp-name s)))
- (unwind-protect
- (progn
- (should name)
- ;; Applied to a string only: the registry knows nothing
- (should (eq (tp-reactive-layer-buffers name) 'unknown))
- (should-not (memq name (tp-gc-anonymous-layers)))
- (should (assoc name tp-layer-alist)))
- (when (and name (assoc name tp-layer-alist))
- (tp-undefine-layer name))
- (setq tp-rt-r3c-color nil))))
-
-;;; GC-1: buried and hidden layers are ALIVE for GC and track-buffer
-
-(defvar tp-rt-gc1-color nil)
-(defvar tp-rt-gc1b-color nil)
-(defvar tp-rt-gc1c-color nil)
-
-(ert-deftest tp-render-test-gc-keeps-layer-buried-under-push ()
- "GC keeps an anonymous layer buried below a pushed top layer.
-The buried layer's tp-name lives inside `tp-layers' storage, not as a
-direct property; the stack-aware liveness scan must still see it, and
-reactivity must survive a later pop (GC-1)."
- (setq tp-rt-gc1-color "blue")
- (let ((buf (generate-new-buffer " tp-rt-gc1"))
- (name nil))
- (unwind-protect
- (progn
- (define-tp tp-rt-gc1-top () '(face bold))
- (with-current-buffer buf
- (insert "0123456789")
- (tp-set 1 6 '(face (:foreground $tp-rt-gc1-color)))
- (setq name (get-text-property 1 'tp-name))
- (should name)
- (tp-push-layer 1 6 'tp-rt-gc1-top)
- ;; Now buried: direct tp-name is the pushed top's.
- (should (eq (get-text-property 1 'tp-name) 'tp-rt-gc1-top))
- ;; The buffer is live and still holds the layer: GC must
- ;; keep it.
- (should-not (memq name (tp-gc-anonymous-layers)))
- (should (assoc name tp-layer-alist))
- ;; Reactivity survives: pop and update.
- (tp-pop-layer 1 6)
- (setq tp-rt-gc1-color "red")
- (should (equal (get-text-property 1 'face)
- '(:foreground "red")))))
- (kill-buffer buf)
- (when (and name (assoc name tp-layer-alist))
- (tp-undefine-layer name))
- (tp-undefine-layer 'tp-rt-gc1-top)
- (setq tp-rt-gc1-color nil))))
-
-(ert-deftest tp-render-test-gc-keeps-hidden-layer ()
- "GC keeps an anonymous layer hidden via tp-hide-layer.
-An all-hidden run carries no direct tp-name at all; the layer lives
-only inside `tp-layers' storage yet is queryable and re-showable, so
-GC must not collect it and show+setq must still re-render (GC-1,
-XM-02)."
- (setq tp-rt-gc1b-color "green")
- (let ((buf (generate-new-buffer " tp-rt-gc1b"))
- (name nil))
- (unwind-protect
- (with-current-buffer buf
- (insert "abcdefghij")
- (tp-set 1 6 '(face (:foreground $tp-rt-gc1b-color)))
- (setq name (get-text-property 1 'tp-name))
- (should name)
- (tp-hide-layer 1 6 name)
- (should-not (get-text-property 1 'tp-name))
- ;; Live buffer still holds the hidden layer: keep it.
- (should-not (memq name (tp-gc-anonymous-layers)))
- (should (assoc name tp-layer-alist))
- ;; Show and update: reactivity must be intact.
- (tp-show-layer 1 6 name)
- (setq tp-rt-gc1b-color "purple")
- (should (equal (get-text-property 1 'face)
- '(:foreground "purple"))))
- (kill-buffer buf)
- (when (and name (assoc name tp-layer-alist))
- (tp-undefine-layer name))
- (setq tp-rt-gc1b-color nil))))
-
-(ert-deftest tp-render-test-track-buffer-finds-buried-and-hidden-layers ()
- "tp-reactive-track-buffer registers layers buried or hidden in storage.
-A propertized string carrying a stacked (buried) layer and an
-all-hidden string are inserted into a fresh buffer; the track scan
-must register every layer name, not just the rendered top ones
-\(GC-1, XM-04)."
- (setq tp-rt-gc1c-color "gold")
- (let ((buf (generate-new-buffer " tp-rt-gc1c"))
- (name nil))
- (unwind-protect
- (progn
- (define-tp tp-rt-gc1c-top () '(face bold))
- (define-tp tp-rt-gc1c-hidden () '(face italic))
- (let ((s (with-temp-buffer
- (insert "trackme")
- (tp-set 1 6 '(face (:foreground $tp-rt-gc1c-color)))
- (setq name (get-text-property 1 'tp-name))
- (tp-push-layer 1 6 'tp-rt-gc1c-top)
- (buffer-string)))
- (h (let ((h (copy-sequence " hideme")))
- (tp-push-layer h 'tp-rt-gc1c-hidden)
- (tp-hide-layer h 'tp-rt-gc1c-hidden)
- h)))
- (with-current-buffer buf
- (insert s)
- (insert h)
- (let ((found (tp-reactive-track-buffer)))
- ;; Rendered top, buried layer, and all-hidden layer.
- (should (memq 'tp-rt-gc1c-top found))
- (should (memq name found))
- (should (memq 'tp-rt-gc1c-hidden found)))
- (should (memq buf (tp-reactive-layer-buffers name)))
- (should (memq buf (tp-reactive-layer-buffers
- 'tp-rt-gc1c-hidden))))))
- (kill-buffer buf)
- (when (and name (assoc name tp-layer-alist))
- (tp-undefine-layer name))
- (tp-undefine-layer 'tp-rt-gc1c-top)
- (tp-undefine-layer 'tp-rt-gc1c-hidden)
- (setq tp-rt-gc1c-color nil))))
-
-(provide 'tp-render-tests)
-;;; tp-render-tests.el ends here
diff --git a/tests/tp-search-tests.el b/tests/tp-search-tests.el
index 62766f1..ef75f39 100644
--- a/tests/tp-search-tests.el
+++ b/tests/tp-search-tests.el
@@ -364,7 +364,7 @@ with predicate t, where VALUE nil matches property-absent runs."
(should (null (get-text-property 0 'face str)))
(should (eq (get-text-property 0 'marker str) t))))
-;;; Guard: nil return still means "no replacement" (used by tp-render)
+;;; Guard: nil return still means "no replacement".
(ert-deftest tp-search-test-search-map-nil-return-no-replacement ()
"A callback returning nil leaves text and properties untouched."
@@ -616,80 +616,6 @@ value changes when a non-nil predicate is given."
(should (= (tp-forward-do #'upcase 'lvl 2 s) 1))
(should (equal (substring-no-properties s) "abc DEF"))))
-;;; REG-1: pattern-apply paths must register buffers in the reactive registry
-
-(defvar tp-search-reg1-color nil)
-(defvar tp-search-reg1b-color nil)
-
-(ert-deftest tp-search-test-regexp-add-registers-reactive-buffer ()
- "tp-regexp-add in a second buffer keeps reactive updates flowing there.
-The deep-merge apply path stamps `tp-name' but never registered the
-buffer, so once the layer was known from a `tp-set' elsewhere the
-regexp-applied buffer went permanently stale (REG-1)."
- (setq tp-search-reg1-color "red")
- (unwind-protect
- (progn
- (tp-layer-reset)
- (define-tp tp-search-reg1-layer ()
- :props '(face (:foreground $tp-search-reg1-color)))
- (let ((a (generate-new-buffer " *tp-sreg1-a*"))
- (b (generate-new-buffer " *tp-sreg1-b*")))
- (unwind-protect
- (progn
- (with-current-buffer a (insert "foo bar"))
- (with-current-buffer b (insert "foo bar"))
- (tp-set 1 4 'tp-search-reg1-layer a) ; registers A
- (tp-regexp-add "foo" 'tp-search-reg1-layer b)
- (let ((bufs (tp-reactive-layer-buffers
- 'tp-search-reg1-layer)))
- (should (memq a bufs))
- (should (memq b bufs)))
- (setq tp-search-reg1-color "blue")
- (should (equal (with-current-buffer a
- (get-text-property 1 'face))
- '(:foreground "blue")))
- (should (equal (with-current-buffer b
- (get-text-property 1 'face))
- '(:foreground "blue"))))
- (kill-buffer a)
- (kill-buffer b))))
- (tp-layer-reset)
- (setq tp-search-reg1-color nil)))
-
-(ert-deftest tp-search-test-match-reset-registers-reactive-buffer ()
- "tp-match-reset in a second buffer keeps reactive updates flowing there.
-The reset-apply path stamps `tp-name' via `set-text-properties' but
-never registered the buffer (REG-1)."
- (setq tp-search-reg1b-color "red")
- (unwind-protect
- (progn
- (tp-layer-reset)
- (define-tp tp-search-reg1b-layer ()
- :props '(face (:foreground $tp-search-reg1b-color)))
- (let ((a (generate-new-buffer " *tp-sreg1b-a*"))
- (b (generate-new-buffer " *tp-sreg1b-b*")))
- (unwind-protect
- (progn
- (with-current-buffer a (insert "foo bar"))
- (with-current-buffer b (insert "foo bar"))
- (tp-set 1 4 'tp-search-reg1b-layer a)
- (tp-match-reset "foo" 'tp-search-reg1b-layer b)
- (let ((bufs (tp-reactive-layer-buffers
- 'tp-search-reg1b-layer)))
- (should (memq a bufs))
- (should (memq b bufs)))
- (setq tp-search-reg1b-color "blue")
- (should (equal (with-current-buffer a
- (get-text-property 1 'face))
- '(:foreground "blue")))
- (should (equal (with-current-buffer b
- (get-text-property 1 'face))
- '(:foreground "blue"))))
- (kill-buffer a)
- (kill-buffer b))))
- (tp-layer-reset)
- (setq tp-search-reg1b-color nil)))
-
;;; SRC-1: reversed START/END bounds are swapped on both object paths
(ert-deftest tp-search-test-reversed-bounds-string-swaps ()
diff --git a/tests/tp-stack-tests.el b/tests/tp-stack-tests.el
deleted file mode 100644
index 2d96719..0000000
--- a/tests/tp-stack-tests.el
+++ /dev/null
@@ -1,1304 +0,0 @@
-;;; tp-stack-tests.el --- ERT regression tests for tp-stack.el -*- lexical-binding: t -*-
-
-;;; Commentary:
-
-;; Regression tests for confirmed bugs fixed in the layer-stack module
-;; (tp-stack.el). Each section is tagged with the canonical bug id it
-;; guards against.
-
-;;; Code:
-
-(require 'ert)
-(require 'tp)
-
-(defmacro tp-stack-tests--with-env (&rest body)
- "Run BODY in a temp buffer with a clean tp layer state.
-Layer registries are reset before BODY and again afterwards so
-definitions cannot leak between tests."
- (declare (indent 0))
- `(unwind-protect
- (with-temp-buffer
- (tp-layer-reset)
- ,@body)
- (tp-layer-reset)))
-
-(defun tp-stack-tests--has-prop-p (pos prop &optional object)
- "Return non-nil if PROP is present (even with value nil) at POS of OBJECT."
- (and (plist-member (text-properties-at pos object) prop) t))
-
-;;; B28: region ops must not mutate text outside [START, END)
-
-(ert-deftest tp-stack-test-delete-layer-subregion-keeps-outside ()
- "Deleting a layer on a sub-region leaves the rest of the stack alone."
- (tp-stack-tests--with-env
- (insert "abcdefghij")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 11 'layer1)
- (tp-push-layer 1 11 'layer2)
- (tp-delete-layer 3 6 'layer2)
- ;; Inside [3, 6): layer2 gone, layer1 now on top.
- (should (eq (get-text-property 3 'tp-name) 'layer1))
- (should (eq (get-text-property 5 'tp-name) 'layer1))
- (should-not (tp-layer-exists-p 3 6 'layer2))
- ;; Outside the region: the full 2-layer stack survives.
- (should (eq (get-text-property 1 'tp-name) 'layer2))
- (should (eq (get-text-property 2 'tp-name) 'layer2))
- (should (eq (get-text-property 6 'tp-name) 'layer2))
- (should (eq (get-text-property 10 'tp-name) 'layer2))
- (should (tp-layer-exists-p 1 3 'layer1))
- (should (tp-layer-exists-p 6 11 'layer1))))
-
-(ert-deftest tp-stack-test-push-layer-subregion-keeps-outside ()
- "Pushing onto a sub-region does not smear over the whole interval."
- (tp-stack-tests--with-env
- (insert "abcdefghij")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 4 'layer1)
- (tp-push-layer 3 8 'layer2)
- ;; [1, 3): still only layer1.
- (should (eq (get-text-property 1 'tp-name) 'layer1))
- (should (eq (get-text-property 2 'tp-name) 'layer1))
- (should-not (tp-layer-exists-p 1 3 'layer2))
- ;; [3, 4): layer2 stacked over layer1.
- (should (eq (get-text-property 3 'tp-name) 'layer2))
- (should (tp-layer-exists-p 3 4 'layer1))
- ;; [4, 8): only layer2.
- (should (eq (get-text-property 5 'tp-name) 'layer2))
- (should-not (tp-layer-exists-p 4 8 'layer1))
- ;; [8, 11): untouched bare text.
- (should (null (text-properties-at 8)))
- (should (null (text-properties-at 10)))))
-
-(ert-deftest tp-stack-test-push-layer-subregion-string ()
- "Region-form push on a string only affects the requested sub-range."
- (tp-stack-tests--with-env
- (let ((str (copy-sequence "abcdef")))
- (define-tp layer1 () '(face bold))
- (tp-put-layer 2 5 'layer1 0 str)
- (should (null (text-properties-at 0 str)))
- (should (null (text-properties-at 1 str)))
- (should (eq (get-text-property 2 'tp-name str) 'layer1))
- (should (eq (get-text-property 4 'tp-name str) 'layer1))
- (should (null (text-properties-at 5 str))))))
-
-;;; B29: tp-put-layer must be region-local, not whole-object
-
-(ert-deftest tp-stack-test-put-layer-bare-region-distant-props ()
- "Putting a layer on a bare region ignores properties elsewhere."
- (tp-stack-tests--with-env
- (insert "abcdefghij")
- (define-tp layer1 () '(face bold))
- (put-text-property 8 10 'help-echo "far")
- (tp-push-layer 1 4 'layer1)
- ;; The layer covers exactly [1, 4).
- (should (eq (get-text-property 1 'tp-name) 'layer1))
- (should (eq (get-text-property 3 'tp-name) 'layer1))
- (should (null (text-properties-at 4)))
- (should (null (text-properties-at 7)))
- ;; The distant properties are untouched.
- (should (equal (get-text-property 8 'help-echo) "far"))
- (should (null (get-text-property 8 'tp-name)))))
-
-(ert-deftest tp-stack-test-put-layer-same-result-with-or-without-distant-props ()
- "Distant properties do not change the public managed stack."
- (tp-stack-tests--with-env
- (define-tp layer1 () '(face bold))
- (let (props-bare props-distant)
- (with-temp-buffer
- (insert "abcdefghij")
- (tp-push-layer 1 4 'layer1)
- (setq props-bare (tp-layer-stack-at 1)))
- (with-temp-buffer
- (insert "abcdefghij")
- (put-text-property 8 10 'help-echo "far")
- (tp-push-layer 1 4 'layer1)
- (setq props-distant (tp-layer-stack-at 1)))
- (should (equal props-bare props-distant)))))
-
-;;; B30: inline plists with ordinary (non-keyword) properties
-
-(ert-deftest tp-stack-test-put-layer-inline-plist-plain ()
- "An inline plist like (face bold) is a valid layer spec."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (tp-put-layer 1 6 '(face bold) 0)
- (should (eq (get-text-property 1 'face) 'bold))))
-
-(ert-deftest tp-stack-test-put-layer-inline-plist-nested ()
- "An inline plist with a nested value list is a valid layer spec."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (tp-put-layer 1 6 '(face (:foreground "red")) 0)
- (should (equal (get-text-property 1 'face) '(:foreground "red")))))
-
-(ert-deftest tp-stack-test-put-layer-inline-plist-multi-pair ()
- "A multi-pair inline plist is applied as one layer."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (tp-put-layer 1 6 '(face bold help-echo "tip") 0)
- (should (eq (get-text-property 1 'face) 'bold))
- (should (equal (get-text-property 1 'help-echo) "tip"))
- (should (= (tp-layer-count 1 6) 1))))
-
-(ert-deftest tp-stack-test-put-layer-named-inline-still-works ()
- "A named inline layer (NAME PROP VAL ...) keeps its old meaning."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (tp-put-layer 1 6 '(mylayer face bold) 0)
- (should (eq (get-text-property 1 'tp-name) 'mylayer))
- (should (eq (get-text-property 1 'face) 'bold))))
-
-;;; B31: list of layer names
-
-(ert-deftest tp-stack-test-put-layer-list-of-names ()
- "A list of defined layer names pushes each as its own layer."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer-a () '(face bold))
- (define-tp layer-b () '(help-echo "b"))
- (tp-put-layer 1 5 '(layer-a layer-b) 0)
- (should (= (tp-layer-count 1 5) 2))
- (should (eq (tp-layer-top 1 5) 'layer-a))
- (should (tp-layer-exists-p 1 5 'layer-a))
- (should (tp-layer-exists-p 1 5 'layer-b))))
-
-(ert-deftest tp-stack-test-put-layer-mixed-list ()
- "A list mixing a layer name and an inline plist works."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer-a () '(face bold))
- (tp-put-layer 1 5 '(layer-a (help-echo "inline")) 0)
- (should (= (tp-layer-count 1 5) 2))
- (should (eq (tp-layer-top 1 5) 'layer-a))))
-
-;;; B32: parameterized groups
-
-(ert-deftest tp-stack-test-put-layer-parameterized-group ()
- "A (GROUP-NAME ARG) spec resolves a parameterized group."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp pcolor (c) `(face (:foreground ,c)))
- (define-tps pgroup (c) `(pcolor ,c))
- (tp-put-layer 1 6 '(pgroup "red") 0)
- (should (equal (get-text-property 1 'face) '(:foreground "red")))
- (should (eq (get-text-property 1 'tp-name) 'pcolor))))
-
-(ert-deftest tp-stack-test-put-layer-parameterized-group-without-arg-errors ()
- "A bare parameterized group name signals instead of silently no-oping."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp pcolor (c) `(face (:foreground ,c)))
- (define-tps pgroup (c) `(pcolor ,c))
- (should-error (tp-put-layer 1 6 'pgroup 0))))
-
-;;; B33: tp-region-layer-props string positions
-
-(ert-deftest tp-stack-test-region-layer-props-string-subrange ()
- "String sub-range queries return absolute in-bounds string positions."
- (tp-stack-tests--with-env
- (let ((str (copy-sequence "abcdef")))
- (define-tp layer1 () '(face bold))
- (tp-push-layer str 'layer1)
- (let ((result (tp-region-layer-props 2 5 'layer1 str)))
- (should (= (length result) 1))
- (should (= (nth 0 (car result)) 2))
- (should (= (nth 1 (car result)) 5))
- (should (<= (nth 1 (car result)) (length str)))
- (should (eq (plist-get (nth 2 (car result)) 'tp-name) 'layer1))))))
-
-(ert-deftest tp-stack-test-region-layer-props-buffer-subrange ()
- "Buffer queries return 1-based positions clipped to the region."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer1 () '(face bold))
- (tp-push-layer 1 7 'layer1)
- (let ((result (tp-region-layer-props 2 4 'layer1)))
- (should (equal (list (nth 0 (car result)) (nth 1 (car result)))
- '(2 4))))))
-
-;;; string/buffer path convergence for region-form mutators
-
-(ert-deftest tp-stack-test-delete-layer-string-region-form ()
- "Region-form delete on a string works and stays inside the range."
- (tp-stack-tests--with-env
- (let ((str (copy-sequence "abcdef")))
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer str 'layer1)
- (tp-push-layer str 'layer2)
- (tp-delete-layer 2 5 'layer2 str)
- (should (eq (get-text-property 2 'tp-name str) 'layer1))
- (should (eq (get-text-property 4 'tp-name str) 'layer1))
- ;; Outside [2, 5) both layers survive.
- (should (eq (get-text-property 0 'tp-name str) 'layer2))
- (should (eq (get-text-property 5 'tp-name str) 'layer2))
- (should (tp-layer-exists-p 0 2 'layer1 str))
- (should (tp-layer-exists-p 5 6 'layer1 str)))))
-
-;;; B34: explicit nil values survive merge/flatten precedence
-
-(ert-deftest tp-stack-test-merge-layers-explicit-nil-wins ()
- "An explicitly-nil value in a higher-precedence layer is kept."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp lower () '(face bold))
- (define-tp upper () '(face nil help-echo "u"))
- (tp-push-layer 1 6 'lower)
- (tp-push-layer 1 6 'upper)
- (tp-merge-layers 1 6 'merged '(upper lower))
- (should (tp-stack-tests--has-prop-p 1 'face))
- (should (null (get-text-property 1 'face)))
- (should (equal (get-text-property 1 'help-echo) "u"))
- (should (eq (get-text-property 1 'tp-name) 'merged))))
-
-(ert-deftest tp-stack-test-flatten-layers-explicit-nil-wins ()
- "Flattening keeps an explicit nil from a higher layer over lower values."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp lower () '(face bold help-echo "low"))
- (define-tp upper () '(face nil))
- (tp-push-layer 1 6 'lower)
- (tp-push-layer 1 6 'upper)
- (tp-flatten-layers 1 6 'flat)
- (should (tp-stack-tests--has-prop-p 1 'face))
- (should (null (get-text-property 1 'face)))
- (should (equal (get-text-property 1 'help-echo) "low"))
- (should (eq (get-text-property 1 'tp-name) 'flat))))
-
-;;; B35: a single managed layer has non-nil authoritative storage
-
-(ert-deftest tp-stack-test-single-layer-has-authoritative-storage ()
- "Pushing one layer stores one metadata entry, never tp-layers nil."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer1 () '(face bold))
- (tp-push-layer 1 6 'layer1)
- (should (= (length (get-text-property 1 'tp-layers)) 1))
- (should (plist-get (car (get-text-property 1 'tp-layers)) 'tp-meta))
- (should-not (plist-member (tp-layer-stack-at 1) 'tp-meta))
- (should (eq (get-text-property 1 'face) 'bold))))
-
-(ert-deftest tp-stack-test-delete-to-single-layer-keeps-metadata-storage ()
- "Deleting down to one layer keeps one authoritative metadata entry."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; With two layers the below-stack is a real, non-nil list.
- (should (get-text-property 1 'tp-layers))
- (tp-delete-layer 1 6 'layer2)
- (should (= (length (get-text-property 1 'tp-layers)) 1))
- (should (eq (get-text-property 1 'tp-name) 'layer1))))
-
-(ert-deftest tp-stack-test-pop-to-single-layer-keeps-metadata-storage ()
- "Popping down to one layer keeps one authoritative metadata entry."
- (tp-stack-tests--with-env
- (let ((str (copy-sequence "abcdef")))
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer str 'layer1)
- (tp-push-layer str 'layer2)
- (tp-pop-layer str)
- (should (= (length (get-text-property 0 'tp-layers str)) 1))
- (should (eq (get-text-property 0 'tp-name str) 'layer1)))))
-
-(ert-deftest tp-stack-test-absent-tp-layers-tolerated-by-stack-ops ()
- "Stacks without a tp-layers property still work with every operation."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1) ; single layer, no tp-layers prop
- (should (= (tp-layer-count 1 6) 1))
- (should (equal (tp-layer-list 1 6) '(layer1)))
- (should (tp-layer-exists-p 1 6 'layer1))
- (should (eq (tp-layer-top 1 6) 'layer1))
- (tp-push-layer 1 6 'layer2) ; stacking on top still works
- (should (= (tp-layer-count 1 6) 2))
- (should (eq (tp-layer-top 1 6) 'layer2))
- (should (tp-layer-exists-p 1 6 'layer1))))
-
-;;; B36: tp-layer-top respects the whole region
-
-(ert-deftest tp-stack-test-layer-top-mid-region-layer ()
- "A layer starting after bare text is still found by tp-layer-top."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer1 () '(face bold))
- (tp-push-layer 3 6 'layer1)
- (should (eq (tp-layer-top 1 6) 'layer1))))
-
-(ert-deftest tp-stack-test-layer-top-respects-end ()
- "tp-layer-top does not report layers that lie beyond END."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer1 () '(face bold))
- (tp-push-layer 4 6 'layer1)
- (should (null (tp-layer-top 1 3)))))
-
-(ert-deftest tp-stack-test-layer-top-first-named-run-wins ()
- "The first run with a named top layer determines the result."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp layer-a () '(face bold))
- (define-tp layer-b () '(face italic))
- (tp-push-layer 1 3 'layer-a)
- (tp-push-layer 3 6 'layer-b)
- (should (eq (tp-layer-top 1 6) 'layer-a))
- (should (eq (tp-layer-top 3 6) 'layer-b))))
-
-;;; Shared argument normalizer: both calling conventions still work
-
-(ert-deftest tp-stack-test-normalizer-string-forms ()
- "Whole-string forms of the routed mutators behave as before."
- (tp-stack-tests--with-env
- (let ((str (copy-sequence "abcdef")))
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer str 'layer1)
- (tp-push-layer str 'layer2)
- (tp-push-layer str 'layer3)
- (should (eq (tp-layer-top 0 6 str) 'layer3))
- (tp-rotate-layer str)
- (should (eq (tp-layer-top 0 6 str) 'layer2))
- (tp-pin-layer str 'layer1)
- (should (eq (tp-layer-top 0 6 str) 'layer1))
- (tp-pop-layer str)
- (should (eq (tp-layer-top 0 6 str) 'layer2))
- (tp-delete-layer str 'layer3)
- (should (equal (tp-layer-list 0 6 str) '(layer2)))
- (should (eq (tp-push-layer str 'layer1) str)))))
-
-(ert-deftest tp-stack-test-normalizer-invalid-first-arg-signals ()
- "A non-string, non-number first argument signals a clear error."
- (tp-stack-tests--with-env
- (define-tp layer1 () '(face bold))
- (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 metadata-backed storage."
- (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 (= (length (get-text-property 1 'tp-layers)) 1)))))
-
-(ert-deftest tp-stack-test-hidden-direct-edit-signals-before-stack-write ()
- "A hidden-range direct edit raises a conflict instead of being discarded."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp tp-st-a10-layer () '(face bold))
- (tp-push-layer 1 6 'tp-st-a10-layer)
- (tp-hide-layer 1 6 'tp-st-a10-layer)
- (put-text-property 1 6 'help-echo "external")
- (let ((before (text-properties-at 1)))
- (should-error (tp-show-layer 1 6 'tp-st-a10-layer)
- :type 'tp-layer-conflict)
- (should (equal (text-properties-at 1) before))
- (should (equal (get-text-property 1 'help-echo) "external")))))
-
-(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)))))
-
-(ert-deftest tp-stack-test-noerror-does-not-catch-layer-body-errors ()
- "NOERROR suppresses unresolved names, not errors from a resolved body."
- (tp-stack-tests--with-env
- (insert "abcdef")
- (define-tp tp-st-a06-boom (_value)
- (error "tp-a06 body failure"))
- (should-error
- (tp-push-layer 1 6 '(tp-st-a06-boom 1) nil t)
- :type 'error)
- (should-not (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)))
-
-;;; Stage 2 canonical layer-operation ranges
-
-(ert-deftest tp-stack-test-parser-resolves-canonical-native-object ()
- "Layer argument parsing resolves nil to a concrete buffer object."
- (with-temp-buffer
- (insert "hello")
- (pcase-let ((`(,start ,end ,object ,layer)
- (tp--parse-layer-args 2 (list 5 'example nil) 1)))
- (should (= start 2))
- (should (= end 5))
- (should (eq object (current-buffer)))
- (should (eq layer 'example)))))
-
-(provide 'tp-stack-tests)
-;;; tp-stack-tests.el ends here
diff --git a/tests/tp-style-tests.el b/tests/tp-style-tests.el
index 107c253..4697f3d 100644
--- a/tests/tp-style-tests.el
+++ b/tests/tp-style-tests.el
@@ -1,10 +1,12 @@
-;;; tp-style-tests.el --- Tests for TP style cascade -*- lexical-binding: t; -*-
+;;; tp-style-tests.el --- Tests for TP property policies -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
-;; Contract tests for the TP 1.0 schema-driven cascade kernel.
+;; Contract tests for CSS-independent native property policies, direct
+;; declarations, and explicit computed values.
;;; Code:
@@ -13,76 +15,124 @@
(require 'tp-layer)
(defmacro tp-style-test--isolated (&rest body)
- "Run BODY with empty TP style registries."
+ "Run BODY with isolated TP property and named-style registries."
(declare (indent 0) (debug t))
- `(let ((tp--property-schemas (make-hash-table :test #'eq))
- (tp--property-schema-order nil)
- (tp--named-styles (make-hash-table :test #'eq))
- (tp--stylesheet-rules nil)
- (tp--cascade-layers nil)
- (tp--style-source-order 0))
- (tp-style-reset)
+ `(let ((tp--property-policies (make-hash-table :test #'eq))
+ (tp--property-policy-order nil)
+ (tp--named-styles (make-hash-table :test #'eq)))
+ (tp--register-default-text-properties)
,@body))
-(defun tp-style-test--color-schema (&optional inherits)
- "Register and return the demo color schema using INHERITS."
- (tp-define-property
+(defun tp-style-test--color-policy ()
+ "Register and return a direct demo color policy."
+ (tp-define-property-policy
'demo/color
- :initial "black"
- :inherits inherits
:normalizer #'downcase
:validator #'stringp
:equality #'equal
:projector (lambda (value)
(list 'face (list :foreground value)))))
-(defun tp-style-test--values (subject &rest args)
- "Return computed values for SUBJECT using ARGS."
- (tp-computed-style-values
- (apply #'tp-compute-style subject args)))
-
-(ert-deftest tp-style-test-schema-registration-is-atomic-and-defensive ()
- "Invalid replacement leaves the previous valid schema installed."
+(ert-deftest tp-style-test-policy-registration-is-atomic ()
+ "Invalid replacement leaves the previous valid policy installed."
(tp-style-test--isolated
- (let ((schema (tp-style-test--color-schema t)))
- (should (eq schema (tp-property-schema 'demo/color)))
+ (let ((policy (tp-style-test--color-policy)))
+ (should (eq policy (tp-property-policy 'demo/color)))
(should-error
- (tp-define-property 'demo/color :normalizer 42)
- :type 'tp-invalid-property-schema)
- (should (eq schema (tp-property-schema 'demo/color)))
+ (tp-define-property-policy 'demo/color :normalizer 42)
+ :type 'tp-invalid-property-policy)
+ (should (eq policy (tp-property-policy 'demo/color)))
(should-error
- (tp-define-property 'color :initial "black")
- :type 'tp-invalid-property-schema))))
+ (tp-define-property-policy 'color)
+ :type 'tp-invalid-property-policy))))
-(ert-deftest tp-style-test-shorthand-expands-before-cascade-once ()
- "A shorthand expands once into registered canonical longhands."
+(ert-deftest tp-style-test-policy-rejects-css-schema-options ()
+ "TP property policies reject CSS inheritance and shorthand fields."
(tp-style-test--isolated
- (let ((calls 0))
- (tp-define-property 'demo/top :initial 0 :validator #'natnump)
- (tp-define-property 'demo/right :initial 0 :validator #'natnump)
- (tp-define-property
- 'demo/inset
- :shorthand (lambda (value)
- (cl-incf calls)
- (list 'demo/top value 'demo/right value)))
- (let ((values (tp-style-test--values
- (tp-subject-create :type 'box)
- :declarations '(demo/inset 7))))
- (should (= calls 1))
- (should (= (plist-get values 'demo/top) 7))
- (should (= (plist-get values 'demo/right) 7))
- (should-not (plist-member values 'demo/inset))))))
+ (dolist (options '((:initial "black")
+ (:inherits t)
+ (:shorthand identity)))
+ (should-error
+ (apply #'tp-define-property-policy 'demo/color options)
+ :type 'tp-invalid-property-policy))))
+
+(ert-deftest tp-style-test-direct-declarations-require-registered-properties ()
+ "Direct declarations cannot silently introduce an unknown vocabulary."
+ (tp-style-test--isolated
+ (tp-style-test--color-policy)
+ (should
+ (equal (tp-merge-declarations
+ '(demo/color "red")
+ '(demo/color nil))
+ '(demo/color nil)))
+ (should-error
+ (tp-merge-declarations '(demo/unknown 1))
+ :type 'tp-invalid-declaration)))
+
+(ert-deftest tp-style-test-text-declarations-copy-mutable-values ()
+ "Text declarations do not retain caller-owned strings or vectors."
+ (tp-style-test--isolated
+ (let* ((caller-string (copy-sequence "label"))
+ (caller-vector (vector (copy-sequence "display")))
+ (declarations
+ (tp-text-declarations
+ (list 'help-echo caller-string 'display caller-vector)))
+ (copied-string (plist-get declarations 'text/help-echo))
+ (copied-vector (plist-get declarations 'text/display)))
+ (should-not (eq copied-string caller-string))
+ (should-not (eq copied-vector caller-vector))
+ (should-not (eq (aref copied-vector 0) (aref caller-vector 0)))
+ (aset caller-string 0 ?L)
+ (aset (aref caller-vector 0) 0 ?D)
+ (should (equal copied-string "label"))
+ (should (equal copied-vector ["display"]))
+ (aset copied-string 1 ?A)
+ (aset (aref copied-vector 0) 1 ?I)
+ (should (equal caller-string "Label"))
+ (should (equal caller-vector ["Display"])))))
+
+(ert-deftest tp-style-test-direct-merge-defensively-copies-values ()
+ "Merged declarations isolate mutable values and preserve functions."
+ (tp-style-test--isolated
+ (dolist (property '(demo/string demo/vector demo/callback))
+ (tp-define-property-policy property))
+ (let* ((calls 0)
+ (caller-string (copy-sequence "source"))
+ (caller-vector (vector (copy-sequence "nested")))
+ (callback (lambda () (cl-incf calls)))
+ (merged
+ (tp-merge-declarations
+ (list 'demo/string caller-string
+ 'demo/vector caller-vector
+ 'demo/callback callback)))
+ (merged-string (plist-get merged 'demo/string))
+ (merged-vector (plist-get merged 'demo/vector))
+ (merged-callback (plist-get merged 'demo/callback)))
+ (should-not (eq merged-string caller-string))
+ (should-not (eq merged-vector caller-vector))
+ (should-not (eq (aref merged-vector 0) (aref caller-vector 0)))
+ (should (eq merged-callback callback))
+ (should (functionp merged-callback))
+ (should (= calls 0))
+ (aset caller-string 0 ?S)
+ (aset (aref caller-vector 0) 0 ?N)
+ (should (equal merged-string "source"))
+ (should (equal merged-vector ["nested"]))
+ (aset merged-string 1 ?O)
+ (aset (aref merged-vector 0) 1 ?E)
+ (should (equal caller-string "Source"))
+ (should (equal caller-vector ["Nested"])))))
(ert-deftest tp-style-test-literal-functions-are-never-called ()
"Function values remain data unless wrapped by `tp-computed'."
(tp-style-test--isolated
(let* ((calls 0)
(callback (lambda () (cl-incf calls))))
- (tp-define-property 'text/help :initial nil)
- (let ((values (tp-style-test--values
- (tp-subject-create :type 'label)
- :declarations (list 'text/help callback))))
- (should (eq (plist-get values 'text/help) callback))
+ (tp-define-property-policy
+ 'demo/help :projector (lambda (value) (list 'help-echo value)))
+ (let ((projected
+ (tp--project-declarations (list 'demo/help callback))))
+ (should (eq (plist-get projected 'help-echo) callback))
(should (= calls 0))))))
(ert-deftest tp-style-test-computed-runs-once-and-result-stays-literal ()
@@ -92,436 +142,94 @@
(result-calls 0)
result-function)
(setq result-function (lambda () (cl-incf result-calls)))
- (tp-define-property 'text/help :initial nil)
- (let ((values
- (tp-style-test--values
- (tp-subject-create :type 'label)
- :declarations
- (list 'text/help
+ (tp-define-property-policy
+ 'demo/help :projector (lambda (value) (list 'help-echo value)))
+ (let ((projected
+ (tp--project-declarations
+ (list 'demo/help
(tp-computed
(lambda ()
(cl-incf compute-calls)
result-function))))))
- (should (eq (plist-get values 'text/help) result-function))
+ (should (eq (plist-get projected 'help-echo) result-function))
(should (= compute-calls 1))
(should (= result-calls 0))))))
-(ert-deftest tp-style-test-inheritance-is-property-specific ()
- "Only schemas marked inheriting read their parent's computed value."
- (tp-style-test--isolated
- (tp-style-test--color-schema t)
- (tp-define-property 'demo/background :initial "transparent"
- :validator #'stringp)
- (let* ((parent (tp-subject-create :type 'panel))
- (child (tp-subject-create :type 'label :parent parent))
- (parent-result
- (tp-compute-style
- parent :declarations
- '(demo/color "NAVY" demo/background "white")))
- (values
- (tp-style-test--values
- child :parent-style parent-result)))
- (should (equal (plist-get values 'demo/color) "navy"))
- (should (equal (plist-get values 'demo/background) "transparent")))))
+(ert-deftest tp-style-test-public-resolver-only-executes-computed-sources ()
+ "The public resolver preserves literal functions and evaluates tags."
+ (let ((literal (lambda () 'literal))
+ (calls 0))
+ (should (eq (tp-resolve-value literal) literal))
+ (should
+ (equal (tp-resolve-value
+ (tp-computed (lambda () (cl-incf calls) '(computed value))))
+ '(computed value)))
+ (should (= calls 1))))
-(ert-deftest tp-style-test-explicit-nil-is-not-absence ()
- "An explicit nil declaration overrides an inherited non-nil value."
+(ert-deftest tp-style-test-policy-normalizes-validates-and-projects ()
+ "A direct value passes through one policy pipeline exactly once."
(tp-style-test--isolated
- (tp-define-property 'text/keymap :initial 'default-map :inherits t)
- (let* ((parent (tp-subject-create :type 'panel))
- (child (tp-subject-create :type 'button :parent parent))
- (parent-result
- (tp-compute-style parent :declarations '(text/keymap parent-map)))
- (values
- (tp-style-test--values
- child :parent-style parent-result
- :declarations '(text/keymap nil))))
- (should (plist-member values 'text/keymap))
- (should-not (plist-get values 'text/keymap)))))
-
-(ert-deftest tp-style-test-structured-selectors-cover-public-combinators ()
- "Structured selectors match identity, attributes, state, and relations."
- (tp-style-test--isolated
- (let* ((root (tp-subject-create :type 'panel :id "root"))
- (first (tp-subject-create :type 'button :id "cancel"
- :classes '(secondary)))
- (second (tp-subject-create
- :type 'button :id "save" :classes '(primary rounded)
- :attributes '((role . action)) :state '(active)))
- (_children (tp-subject-set-children root (list first second))))
+ (let ((normalizations 0) (validations 0) (projections 0))
+ (tp-define-property-policy
+ 'demo/color
+ :normalizer (lambda (value) (cl-incf normalizations) (downcase value))
+ :validator (lambda (value) (cl-incf validations) (stringp value))
+ :projector (lambda (value)
+ (cl-incf projections)
+ (list 'face (list :foreground value))))
(should
- (tp-selector-match-p
- '(:and (:type button) (:id "save") (:class primary)
- (:attr role action) (:state active)
- (:not (:class disabled)))
- second))
- (should (tp-selector-match-p
- '(:child (:id "root") (:class primary)) second))
- (should (tp-selector-match-p
- '(:descendant (:type panel) (:id "save")) second))
- (should (tp-selector-match-p
- '(:adjacent (:id "cancel") (:id "save")) second))
- (should (tp-selector-match-p
- '(:sibling (:class secondary) (:id "save")) second))
- (should (tp-selector-match-p
- '(:is (:id "missing") (:class primary)) second))
- (should (tp-selector-match-p
- '(:where (:type button) (:class missing)) second)))))
-
-(ert-deftest tp-style-test-subject-class-and-state-tokens-use-value-equality ()
- "Selectors match generic string tokens without requiring symbol identity."
- (tp-style-test--isolated
- (let ((subject (tp-subject-create
- :type 'button
- :classes (list (copy-sequence "primary"))
- :state (list (copy-sequence "active")))))
- (should (tp-selector-match-p '(:class "primary") subject))
- (should (tp-selector-match-p '(:state "active") subject)))))
-
-(ert-deftest tp-style-test-stylesheet-instances-isolate-rules-and-layers ()
- "Independent stylesheets cannot leak rules or layer order into each other."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((left (tp-stylesheet-create))
- (right (tp-stylesheet-create))
- (subject (tp-subject-create :type 'button)))
- (tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
- :layer 'base :stylesheet left)
- (tp-stylesheet-add-rule '(:type button) '(demo/color "red")
- :layer 'components :stylesheet left)
- (tp-stylesheet-add-rule '(:type button) '(demo/color "green")
- :layer 'components :stylesheet right)
- (tp-stylesheet-add-rule '(:type button) '(demo/color "purple")
- :layer 'base :stylesheet right)
- (should (equal (plist-get
- (tp-style-test--values subject :rules left)
- 'demo/color)
- "red"))
- (should (equal (plist-get
- (tp-style-test--values subject :rules right)
- 'demo/color)
- "purple"))
- (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
- "black"))
- (tp-style-reset-rules left)
- (should (equal (plist-get
- (tp-style-test--values subject :rules left)
- 'demo/color)
- "black"))
- (should (equal (plist-get
- (tp-style-test--values subject :rules right)
- 'demo/color)
- "purple")))))
-
-(ert-deftest tp-style-test-origin-importance-and-specificity-are-ordered ()
- "Importance, origin, and selector specificity decide the winner in order."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((subject (tp-subject-create :type 'button :id "save"
- :classes '(primary))))
- (tp-stylesheet-add-rule '(:id "save") '(demo/color "green")
- :origin 'theme)
- (tp-stylesheet-add-rule '(:type button) '(demo/color "red")
- :origin 'author)
- (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
- "red"))
- (tp-stylesheet-add-rule
- '(:class primary)
- (list 'demo/color (tp-important "purple"))
- :origin 'theme)
- (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
- "purple")))))
-
-(ert-deftest tp-style-test-layer-order-reverses-for-important ()
- "Normal declarations prefer later layers; important declarations reverse."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((subject (tp-subject-create :type 'button)))
- (tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
- :layer 'base)
- (tp-stylesheet-add-rule '(:type button) '(demo/color "red")
- :layer 'components)
- (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
- "red"))
- (tp-style-reset-rules)
- (tp-stylesheet-add-rule
- '(:type button) (list 'demo/color (tp-important "blue"))
- :layer 'base)
- (tp-stylesheet-add-rule
- '(:type button) (list 'demo/color (tp-important "red"))
- :layer 'components)
- (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
- "blue")))))
-
-(ert-deftest tp-style-test-unlayered-normal-beats-layered-normal ()
- "An unlayered normal declaration outranks layered declarations."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((subject (tp-subject-create :type 'button)))
- (tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
- :layer 'components)
- (tp-stylesheet-add-rule '(:type button) '(demo/color "red"))
- (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
- "red")))))
-
-(ert-deftest tp-style-test-source-order-breaks-complete-ties ()
- "The last matching rule wins after all stronger dimensions tie."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((subject (tp-subject-create :type 'button)))
- (tp-stylesheet-add-rule '(:type button) '(demo/color "blue"))
- (tp-stylesheet-add-rule '(:type button) '(demo/color "red"))
- (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
- "red")))))
-
-(ert-deftest tp-style-test-later-duplicate-declaration-wins-stably ()
- "The later declaration wins when one rule repeats a property."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (tp-stylesheet-add-rule
- '(:type label) '(demo/color "red" demo/color "green"))
- (let ((values
- (tp-style-test--values (tp-subject-create :type 'label))))
- (should (equal (plist-get values 'demo/color) "green")))))
-
-(ert-deftest tp-style-test-computation-is-deterministic ()
- "Equivalent calls return structurally equal computed styles."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (tp-stylesheet-add-rule '(:class primary) '(demo/color "purple"))
- (let ((subject (tp-subject-create :type 'label :classes '(primary))))
- (should (equal (tp-compute-style subject :provenance t)
- (tp-compute-style subject :provenance t))))))
-
-(ert-deftest tp-style-test-custom-properties-have-canonical-order ()
- "Computed custom properties use deterministic symbol-name order."
- (tp-style-test--isolated
- (let* ((result
- (tp-compute-style
- (tp-subject-create :type 'label)
- :declarations '(--zeta 1 --alpha 2 --middle 3)))
- (custom (tp-computed-style-custom-properties result)))
- (should (equal custom '(--alpha 2 --middle 3 --zeta 1))))))
-
-(ert-deftest tp-style-test-computation-does-not-mutate-current-buffer ()
- "Cascade computation never mutates the current buffer."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (with-temp-buffer
- (insert "stable")
- (add-text-properties 1 4 '(face bold marker original))
- (let ((before-text (buffer-string))
- (before-properties (text-properties-at 2)))
- (cl-letf (((symbol-function 'add-text-properties)
- (lambda (&rest _) (error "buffer mutation")))
- ((symbol-function 'put-text-property)
- (lambda (&rest _) (error "buffer mutation")))
- ((symbol-function 'remove-text-properties)
- (lambda (&rest _) (error "buffer mutation")))
- ((symbol-function 'set-text-properties)
- (lambda (&rest _) (error "buffer mutation")))
- ((symbol-function 'insert)
- (lambda (&rest _) (error "buffer mutation")))
- ((symbol-function 'delete-region)
- (lambda (&rest _) (error "buffer mutation")))
- ((symbol-function 'erase-buffer)
- (lambda (&rest _) (error "buffer mutation"))))
- (tp-compute-style
- (tp-subject-create :type 'label)
- :declarations '(demo/color "red")))
- (should (equal (buffer-string) before-text))
- (should (equal (text-properties-at 2) before-properties))))))
-
-(ert-deftest tp-style-test-compute-error-leaves-cascade-state-unchanged ()
- "A failing computed source does not mutate registered cascade state."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (tp-stylesheet-add-rule '(:type label) '(demo/color "blue"))
- (let ((rules-before (copy-tree tp--stylesheet-rules))
- (order-before tp--style-source-order))
+ (equal (tp--project-declarations '(demo/color "RED"))
+ '(face (:foreground "red"))))
+ (should (equal (list normalizations validations projections) '(1 1 1)))
(should-error
- (tp-compute-style
- (tp-subject-create :type 'label)
- :declarations
- (list 'demo/color (tp-computed (lambda () (error "broken"))))))
- (should (equal tp--stylesheet-rules rules-before))
- (should (= tp--style-source-order order-before)))))
+ (tp--project-declarations '(demo/color 42))
+ :type 'tp-invalid-declaration))))
-(ert-deftest tp-style-test-nearer-scope-wins-after-specificity ()
- "A rule scoped to the nearest matching ancestor wins a tie."
+(ert-deftest tp-style-test-validator-rejection-is-explicit ()
+ "A false validator result raises a direct declaration error."
(tp-style-test--isolated
- (tp-style-test--color-schema)
- (let* ((root (tp-subject-create :type 'panel :id "root"))
- (section (tp-subject-create :type 'section :id "section"))
- (button (tp-subject-create :type 'button)))
- (tp-subject-set-children root (list section))
- (tp-subject-set-children section (list button))
- (tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
- :scope '(:id "root"))
- (tp-stylesheet-add-rule '(:type button) '(demo/color "red")
- :scope '(:id "section"))
- (should (equal (plist-get (tp-style-test--values button) 'demo/color)
- "red")))))
+ (tp-define-property-policy 'demo/count :validator #'natnump)
+ (should-error
+ (tp--project-declarations '(demo/count -1))
+ :type 'tp-invalid-declaration)))
-(ert-deftest tp-style-test-css-wide-values-are-tagged-not-reserved-symbols ()
- "Tagged wide values work while an ordinary `inherit' symbol stays literal."
- (tp-style-test--isolated
- (tp-style-test--color-schema t)
- (tp-define-property 'demo/token :initial 'initial-token :validator #'symbolp)
- (let* ((parent (tp-subject-create :type 'panel))
- (child (tp-subject-create :type 'label :parent parent))
- (parent-result
- (tp-compute-style parent :declarations '(demo/color "red")))
- (values
- (tp-style-test--values
- child :parent-style parent-result
- :declarations
- (list 'demo/color (tp-wide-value 'inherit)
- 'demo/token 'inherit))))
- (should (equal (plist-get values 'demo/color) "red"))
- (should (eq (plist-get values 'demo/token) 'inherit)))))
-
-(ert-deftest tp-style-test-revert-and-revert-layer-select-lower-candidates ()
- "Revert skips an origin and revert-layer skips only the winning layer."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((subject (tp-subject-create :type 'button)))
- (tp-stylesheet-add-rule '(:type button) '(demo/color "green")
- :origin 'theme)
- (tp-stylesheet-add-rule '(:type button) '(demo/color "red")
- :origin 'author :layer 'base)
- (tp-stylesheet-add-rule
- '(:type button)
- (list 'demo/color (tp-wide-value 'revert-layer))
- :origin 'author :layer 'components)
- (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
- "red"))
- (should
- (equal
- (plist-get
- (tp-style-test--values
- subject
- :declarations
- (list 'demo/color (tp-wide-value 'revert)))
- 'demo/color)
- "red")))))
-
-(ert-deftest tp-style-test-custom-properties-inherit-and-support-fallback ()
- "Custom properties inherit and `tp-var' resolves an explicit fallback."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let* ((parent (tp-subject-create :type 'panel))
- (child (tp-subject-create :type 'label :parent parent))
- (parent-result
- (tp-compute-style parent :declarations '(--accent "NAVY")))
- (inherited
- (tp-style-test--values
- child :parent-style parent-result
- :declarations (list 'demo/color (tp-var '--accent))))
- (fallback
- (tp-style-test--values
- child :declarations
- (list 'demo/color (tp-var '--missing "GRAY")))))
- (should (equal (plist-get inherited 'demo/color) "navy"))
- (should (equal (plist-get fallback 'demo/color) "gray")))))
-
-(ert-deftest tp-style-test-custom-property-cycle-uses-outer-fallback ()
- "A custom-property cycle is invalid and activates the outer fallback."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((values
- (tp-style-test--values
- (tp-subject-create :type 'label)
- :declarations
- (list '--a (tp-var '--b)
- '--b (tp-var '--a)
- 'demo/color (tp-var '--a "SAFE")))))
- (should (equal (plist-get values 'demo/color) "safe")))))
-
-(ert-deftest tp-style-test-invalid-value-falls-back-to-inherited-or-initial ()
- "Invalid-at-computed-value declarations use the property's default path."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((values
- (tp-style-test--values
- (tp-subject-create :type 'label)
- :declarations (list 'demo/color (tp-var '--missing)))))
- (should (equal (plist-get values 'demo/color) "black")))))
-
-(ert-deftest tp-style-test-invalid-winner-does-not-recascade ()
- "An invalid winner uses its default instead of a lower declaration."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (tp-stylesheet-add-rule '(:type label) '(demo/color "blue"))
- (tp-stylesheet-add-rule
- '(:type label) (list 'demo/color (tp-var '--missing)))
- (let ((values
- (tp-style-test--values (tp-subject-create :type 'label))))
- (should (equal (plist-get values 'demo/color) "black")))))
-
-(ert-deftest tp-style-test-provenance-identifies-winning-declaration ()
- "The optional read-only provenance records the winning rule facts."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (tp-stylesheet-add-rule '(:class primary) '(demo/color "purple")
- :origin 'author :layer 'components)
- (let* ((result
- (tp-compute-style
- (tp-subject-create :type 'button :classes '(primary))
- :provenance t))
- (entry (plist-get (tp-computed-style-provenance result)
- 'demo/color)))
- (should (equal (plist-get entry :selector) '(:class primary)))
- (should (eq (plist-get entry :origin) 'author))
- (should (eq (plist-get entry :layer) 'components)))))
-
-(ert-deftest tp-style-test-projector-produces-final-emacs-properties ()
- "Projection converts canonical computed values to Emacs properties."
- (tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((result
- (tp-compute-style
- (tp-subject-create :type 'label)
- :declarations '(demo/color "RED"))))
- (should (equal (tp-project-style result)
- '(face (:foreground "red")))))))
-
-(ert-deftest tp-style-test-native-text-schemas-preserve-functions-and-nil ()
- "Native projectors keep callback functions literal and explicit nil present."
+(ert-deftest tp-style-test-native-properties-preserve-functions-and-nil ()
+ "Native projectors keep callbacks literal and explicit nil present."
(tp-style-test--isolated
(let* ((callback (lambda (_window _object _position) "help"))
- (declarations
- (tp-text-declarations
- (list 'help-echo callback 'keymap nil 'display '(space :width 4))))
- (result
- (tp-compute-style (tp-subject-create :type 'label)
- :declarations declarations))
- (projected (tp-project-style result)))
+ (projected
+ (tp--project-text-declarations
+ (list 'help-echo callback
+ 'keymap nil
+ 'display '(space :width 4)))))
(should (eq (plist-get projected 'help-echo) callback))
(should (plist-member projected 'keymap))
(should-not (plist-get projected 'keymap))
(should (equal (plist-get projected 'display) '(space :width 4))))))
-(ert-deftest tp-style-test-inactive-nil-native-properties-do-not-project ()
- "Default nil schemas do not create absent Emacs properties."
+(ert-deftest tp-style-test-native-face-policy-merges-contributions ()
+ "The native face policy retains TP's established face merge semantics."
(tp-style-test--isolated
- (let ((result (tp-compute-style (tp-subject-create :type 'label))))
- (should-not (tp-project-style result)))))
+ (let* ((policy (tp-register-text-property 'face))
+ (merge (tp-property-policy-merge policy)))
+ (should
+ (equal (funcall merge '(:foreground "red") '(:weight bold))
+ '(:foreground "red" :weight bold))))))
-(ert-deftest tp-style-test-define-tp-compiles-static-layer-declarations ()
- "A static `define-tp' layer also becomes a canonical named style."
+(ert-deftest tp-style-test-define-tp-compiles-static-direct-declarations ()
+ "A static `define-tp' layer compiles into a named direct style."
(tp-style-test--isolated
(unwind-protect
(progn
(define-tp tp-style-test-layer ()
- '(face (:weight bold) help-echo "Demo" tp-text "content"))
+ '(face (:weight bold) help-echo "Demo"))
(should
(equal (tp-style-declarations 'tp-style-test-layer)
'(text/face (:weight bold) text/help-echo "Demo"))))
(tp-undefine-layer 'tp-style-test-layer))))
-(ert-deftest tp-style-test-parameterized-redefinition-removes-static-style ()
- "A parameterized redefinition cannot leave a frozen static style behind."
+(ert-deftest tp-style-test-parameterized-layer-has-no-frozen-style ()
+ "A parameterized redefinition removes its former static style."
(tp-style-test--isolated
(unwind-protect
(progn
@@ -533,7 +241,7 @@
(tp-undefine-layer 'tp-style-test-layer))))
(ert-deftest tp-style-test-static-group-element-compiles-style ()
- "A generated static group layer becomes a canonical named style."
+ "A generated static group layer becomes a named direct style."
(tp-style-test--isolated
(unwind-protect
(progn
@@ -544,19 +252,48 @@
'(text/face italic text/mouse-face highlight))))
(tp-undefine-group 'tp-style-test-group))))
-(ert-deftest tp-style-test-named-style-definitions-are-defensive ()
- "Named styles own their declarations instead of caller mutable plists."
+(ert-deftest tp-style-test-named-styles-are-defensive ()
+ "Named styles own declarations and return defensive copies."
(tp-style-test--isolated
- (tp-style-test--color-schema)
- (let ((declarations (list 'demo/color "red")))
- (tp-define-style 'demo/button declarations)
- (setcar (cdr declarations) "blue")
- (should (equal (tp-style-declarations 'demo/button)
- '(demo/color "red")))
- (let ((copy (tp-style-declarations 'demo/button)))
- (setcar (cdr copy) "green")
- (should (equal (tp-style-declarations 'demo/button)
- '(demo/color "red")))))))
+ (dolist (property '(demo/title demo/layout))
+ (tp-define-property-policy property))
+ (let* ((title (copy-sequence "button"))
+ (layout (vector (copy-sequence "row")))
+ (merged
+ (tp-merge-declarations
+ (list 'demo/title title 'demo/layout layout))))
+ (tp-define-style 'demo/button merged)
+ (aset (plist-get merged 'demo/title) 0 ?B)
+ (aset (aref (plist-get merged 'demo/layout) 0) 0 ?R)
+ (should
+ (equal (tp-style-declarations 'demo/button)
+ '(demo/title "button" demo/layout ["row"])))
+ (let* ((first (tp-style-declarations 'demo/button))
+ (first-title (plist-get first 'demo/title))
+ (first-layout (plist-get first 'demo/layout)))
+ (aset first-title 1 ?U)
+ (aset (aref first-layout 0) 1 ?O)
+ (should (equal (plist-get merged 'demo/title) "Button"))
+ (should (equal (plist-get merged 'demo/layout) ["Row"]))
+ (should
+ (equal (tp-style-declarations 'demo/button)
+ '(demo/title "button" demo/layout ["row"])))))))
+
+(ert-deftest tp-style-test-css-engine-symbols-are-not-owned-by-tp ()
+ "TP does not expose the CSS cascade surface migrated to ECSS."
+ (dolist (symbol '(tp-subject-create
+ tp-subject-set-children
+ tp-selector-match-p
+ tp-selector-specificity
+ tp-stylesheet-create
+ tp-stylesheet-add-rule
+ tp-compute-style
+ tp-project-style
+ tp-wide-value
+ tp-important
+ tp-var))
+ (should-not (fboundp symbol)))
+ (should-not (featurep 'ecss)))
(provide 'tp-style-tests)
;;; tp-style-tests.el ends here
diff --git a/tests/tp-surface-tests.el b/tests/tp-surface-tests.el
index b5ca9da..9550a09 100644
--- a/tests/tp-surface-tests.el
+++ b/tests/tp-surface-tests.el
@@ -52,9 +52,103 @@
:key 'root :kind 'group
:children (list (tp-surface-test--leaf 'same "A")
(tp-surface-test--leaf 'same "B"))
- :capability 'content)
+ :capability 'content)
:type 'tp-duplicate-object-key)))
+(ert-deftest tp-surface-test-plan-copy-obeys-value-identity-rules ()
+ "Plan data is copied while opaque records and functions keep identity."
+ (with-temp-buffer
+ (let* ((caller-string (copy-sequence "tag"))
+ (caller-vector (vector (copy-sequence "nested")))
+ (record (tp--make-native-range (current-buffer) :buffer 1 1))
+ (calls 0)
+ (callback (lambda () (cl-incf calls)))
+ (table (make-hash-table :test #'equal))
+ (marker (copy-marker (point-min)))
+ (tags (list caller-string caller-vector record callback table
+ marker (current-buffer)))
+ (plan (tp-surface-plan-create
+ :key 'root :kind 'text :text "x" :tags tags
+ :capability 'content))
+ (copy (tp-surface-plan-tags plan)))
+ (should-not (eq copy tags))
+ (should-not (eq (nth 0 copy) caller-string))
+ (should-not (eq (nth 1 copy) caller-vector))
+ (should-not (eq (aref (nth 1 copy) 0) (aref caller-vector 0)))
+ (should (eq (nth 2 copy) record))
+ (should (eq (nth 3 copy) callback))
+ (should (eq (nth 4 copy) table))
+ (should (eq (nth 5 copy) marker))
+ (should (eq (nth 6 copy) (current-buffer)))
+ (should (= calls 0)))))
+
+(ert-deftest tp-surface-test-retained-options-own-mutable-containers ()
+ "Surface options copy data containers without cloning opaque identities."
+ (tp-surface-test--with-buffer
+ (let* ((caller-string (copy-sequence "state"))
+ (caller-vector (vector (copy-sequence "nested")))
+ (record (tp--make-native-range buffer :buffer 1 1))
+ (calls 0)
+ (callback (lambda () (cl-incf calls)))
+ (table (make-hash-table :test #'equal))
+ (start (copy-marker (point-min)))
+ (end (copy-marker (point-max) t))
+ (client-state
+ (list caller-string caller-vector record callback table buffer))
+ (options
+ (list :capability 'content :start start :end end
+ :client-state client-state))
+ (surface (tp--create-surface buffer 'content options))
+ (stored-options (tp--surface-options surface))
+ (stored-state (plist-get stored-options :client-state)))
+ (should-not (eq stored-state client-state))
+ (should-not (eq (nth 0 stored-state) caller-string))
+ (should-not (eq (nth 1 stored-state) caller-vector))
+ (should-not (eq (aref (nth 1 stored-state) 0)
+ (aref caller-vector 0)))
+ (should (eq (nth 2 stored-state) record))
+ (should (eq (nth 3 stored-state) callback))
+ (should (eq (nth 4 stored-state) table))
+ (should (eq (nth 5 stored-state) buffer))
+ (should (eq (plist-get stored-options :start) start))
+ (should (eq (plist-get stored-options :end) end))
+ (should (= calls 0))
+ (aset caller-string 0 ?S)
+ (aset (aref caller-vector 0) 0 ?N)
+ (should (equal (nth 0 stored-state) "state"))
+ (should (equal (nth 1 stored-state) ["nested"])))))
+
+(ert-deftest tp-surface-test-report-copy-is-deep-for-data-values ()
+ "Public reports cannot mutate retained data and preserve opaque identities."
+ (with-temp-buffer
+ (let* ((report-string (copy-sequence "report"))
+ (report-vector (vector (copy-sequence "nested")))
+ (record (tp--make-native-range (current-buffer) :buffer 1 1))
+ (calls 0)
+ (callback (lambda () (cl-incf calls)))
+ (table (make-hash-table :test #'equal))
+ (marker (copy-marker (point-min)))
+ (payload (list report-string report-vector record callback table
+ marker (current-buffer)))
+ (surface (tp--make-surface :report (list :payload payload)))
+ (first-payload (plist-get (tp-surface-report surface) :payload)))
+ (should-not (eq (nth 0 first-payload) report-string))
+ (should-not (eq (nth 1 first-payload) report-vector))
+ (should-not (eq (aref (nth 1 first-payload) 0)
+ (aref report-vector 0)))
+ (should (eq (nth 2 first-payload) record))
+ (should (eq (nth 3 first-payload) callback))
+ (should (eq (nth 4 first-payload) table))
+ (should (eq (nth 5 first-payload) marker))
+ (should (eq (nth 6 first-payload) (current-buffer)))
+ (should (= calls 0))
+ (aset (nth 0 first-payload) 0 ?R)
+ (aset (aref (nth 1 first-payload) 0) 0 ?N)
+ (let ((second-payload
+ (plist-get (tp-surface-report surface) :payload)))
+ (should (equal (nth 0 second-payload) "report"))
+ (should (equal (nth 1 second-payload) ["nested"]))))))
+
(ert-deftest tp-surface-test-materialize-producer-is-ephemeral ()
"Pure materialization leaves no live object, binding, or subscription."
(let ((signal (tp-signal-create 7)) object binding)
@@ -266,6 +360,45 @@
(should (= (plist-get report :scope-range-count) 1))
(should (= (plist-get report :property-operations) 1))))))
+(ert-deftest tp-surface-test-sparse-property-update-does-not-scan-between-anchors ()
+ "A sparse properties update inspects only owned anchor intervals."
+ (tp-surface-test--with-buffer
+ (insert (make-string 120 ?x))
+ (let* ((left-anchor (tp-range-anchor-create buffer 2 3))
+ (right-anchor (tp-range-anchor-create buffer 100 101))
+ (left-face 'bold)
+ (producer
+ (lambda (context)
+ (let ((root (tp-object-ensure context nil 'root 'group)))
+ (let ((left (tp-object-ensure context root 'left 'range))
+ (right (tp-object-ensure context root 'right 'range)))
+ (tp-object-attach-range context left left-anchor)
+ (tp-object-attach-range context right right-anchor)))
+ (tp-surface-plan-create
+ :key 'root :kind 'group :capability 'properties
+ :children
+ (list
+ (tp-surface-plan-create
+ :key 'left :kind 'range :props (list 'face left-face)
+ :capability 'properties)
+ (tp-surface-plan-create
+ :key 'right :kind 'range :props '(face italic)
+ :capability 'properties)))))
+ (surface
+ (tp-surface-mount buffer producer '(:capability properties))))
+ (setq left-face 'underline)
+ (let ((original (symbol-function 'next-single-property-change)))
+ (cl-letf (((symbol-function 'next-single-property-change)
+ (lambda (position property &optional object limit)
+ (unless (or (and (>= position 2) (< position 3))
+ (and (>= position 100) (< position 101)))
+ (error "Unexpected sparse scan at %s for %s"
+ position property))
+ (funcall original position property object limit))))
+ (tp-surface-update surface producer)))
+ (should (eq (get-text-property 2 'face) 'underline))
+ (should (eq (get-text-property 100 'face) 'italic)))))
+
(ert-deftest tp-surface-test-scoped-update-can-explicitly-fall-back-to-root ()
"A scoped mismatch should publish the root only when explicitly requested."
(tp-surface-test--with-buffer
@@ -533,6 +666,82 @@
(tp-surface-unmount surface)
(should (equal (get-text-property 2 'help-echo) "external")))))
+(ert-deftest tp-surface-test-property-update-uses-policy-equality ()
+ "Retained property comparison uses the registered text-property policy."
+ (tp-surface-test--with-buffer
+ (insert "host")
+ (let* ((old-policy (tp-property-policy 'text/help-echo))
+ (anchor (tp-range-anchor-create buffer 1 5))
+ (value "A")
+ surface)
+ (unwind-protect
+ (progn
+ (tp-define-property-policy
+ 'text/help-echo
+ :equality (lambda (left right)
+ (string-equal (downcase left) (downcase right)))
+ :merge (lambda (_old new) new)
+ :projector (lambda (v) (list 'help-echo v)))
+ (setq surface
+ (tp-surface-mount
+ buffer
+ (lambda (context)
+ (let ((object (tp-object-ensure
+ context nil 'root 'range)))
+ (tp-object-attach-range context object anchor))
+ (tp-surface-plan-create
+ :key 'root :kind 'range
+ :props (list 'help-echo value)
+ :capability 'properties))
+ '(:capability properties)))
+ (let ((revision (tp-surface-revision surface)))
+ (setq value "a")
+ (tp-surface-update surface (tp--surface-producer surface))
+ (should (= (tp-surface-revision surface) revision))
+ (should (= (plist-get (tp-surface-report surface)
+ :property-operations)
+ 1))
+ (should (equal (get-text-property 2 'help-echo) "A"))))
+ (when old-policy
+ (puthash 'text/help-echo old-policy tp--property-policies))
+ (when (and surface (tp-surface-live-p surface))
+ (tp-surface-unmount surface))))))
+
+(ert-deftest tp-surface-test-content-property-diff-uses-policy-equality ()
+ "Content publication skips policy-equal property writes."
+ (tp-surface-test--with-buffer
+ (let ((old-policy (tp-property-policy 'text/help-echo))
+ (value "A")
+ (client-state 1)
+ surface producer)
+ (unwind-protect
+ (progn
+ (tp-define-property-policy
+ 'text/help-echo
+ :equality (lambda (left right)
+ (string-equal (downcase left) (downcase right)))
+ :merge (lambda (_old new) new)
+ :projector (lambda (current) (list 'help-echo current)))
+ (setq producer
+ (lambda (context)
+ (tp-object-ensure context nil 'root 'text)
+ (tp-surface-result-create
+ (tp-surface-test--leaf
+ 'root "text" (list 'help-echo value))
+ (list :state client-state)))
+ surface (tp-surface-mount
+ buffer producer '(:capability content)))
+ (let ((revision (tp-surface-revision surface)))
+ (setq value "a" client-state 2)
+ (let ((report (tp-surface-update surface producer)))
+ (should (= (tp-surface-revision surface) (1+ revision)))
+ (should (= (plist-get report :property-operations) 0))
+ (should (equal (get-text-property 1 'help-echo) "A")))))
+ (when old-policy
+ (puthash 'text/help-echo old-policy tp--property-policies))
+ (when (and surface (tp-surface-live-p surface))
+ (tp-surface-unmount surface))))))
+
(ert-deftest tp-surface-test-unmount-preserves-conflicting-host-value ()
"Unmount removes only TP's still-current property contribution."
(tp-surface-test--with-buffer
@@ -554,6 +763,123 @@
(should-not (tp-surface-live-p surface))
(should-not (tp-range-anchor-live-p anchor)))))
+(ert-deftest tp-surface-test-complete-anchor-deletion-applies-boundary-policy ()
+ "Deleting an entire anchor span applies stale, shorten, and remove policy."
+ (dolist (case '((stale . t) (shorten . nil) (remove . remove)))
+ (tp-surface-test--with-buffer
+ (insert "abcd")
+ (let* ((policy (car case))
+ (expected (cdr case))
+ (anchor (tp-range-anchor-create
+ buffer 2 4 :boundary-policy policy))
+ (producer
+ (lambda (context)
+ (let ((object (tp-object-ensure context nil 'root 'range)))
+ (tp-object-attach-range context object anchor))
+ (tp-surface-plan-create
+ :key 'root :kind 'range :props '(help-echo "tp")
+ :capability 'properties)))
+ (surface
+ (tp-surface-mount buffer producer '(:capability properties))))
+ (delete-region 2 4)
+ (should (eq (tp--anchor-stale anchor) expected))
+ (when expected
+ (should-error (tp-surface-update surface producer)
+ :type 'tp-stale-mount))))))
+
+(ert-deftest tp-surface-test-complete-content-deletion-marks-surface-stale ()
+ "Deleting a content surface's full span makes the mount stale."
+ (tp-surface-test--with-buffer
+ (let ((surface
+ (tp-surface-mount buffer (tp-surface-test--leaf 'root "abc")
+ '(:capability content))))
+ (delete-region 1 4)
+ (should (tp--surface-stale surface))
+ (should-error
+ (tp-surface-update surface (tp-surface-test--leaf 'root "next"))
+ :type 'tp-stale-mount))))
+
+(ert-deftest tp-surface-test-failed-prepare-rolls-back-direct-buffer-mutation ()
+ "Producer buffer edits during prepare roll back when preparation fails."
+ (tp-surface-test--with-buffer
+ (let* ((surface
+ (tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
+ '(:capability content)))
+ (revision (tp-surface-revision surface)))
+ (should-error
+ (tp-surface-update
+ surface
+ (lambda (context)
+ (goto-char (point-min))
+ (insert "BAD")
+ (tp-object-ensure context nil 'other 'text)
+ (tp-surface-test--leaf 'root "new")))
+ :type 'tp-surface-error)
+ (should (equal (buffer-string) "old"))
+ (should-not (tp--surface-stale surface))
+ (should (= (tp-surface-revision surface) revision)))))
+
+(ert-deftest tp-surface-test-successful-prepare-rejects-direct-buffer-mutation ()
+ "Producers cannot commit live surface buffers outside TP publication."
+ (tp-surface-test--with-buffer
+ (let* ((surface
+ (tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
+ '(:capability content)))
+ (revision (tp-surface-revision surface)))
+ (should-error
+ (tp-surface-update
+ surface
+ (lambda (context)
+ (tp-object-ensure context nil 'root 'text)
+ (goto-char (point-min))
+ (insert "BAD")
+ (tp-surface-test--leaf 'root "new")))
+ :type 'tp-surface-error)
+ (should (equal (buffer-string) "old"))
+ (should-not (tp--surface-stale surface))
+ (should (= (tp-surface-revision surface) revision)))))
+
+(ert-deftest tp-surface-test-prepare-rejects-direct-property-mutation ()
+ "Producers cannot write live surface properties during prepare."
+ (tp-surface-test--with-buffer
+ (let* ((surface
+ (tp-surface-mount
+ buffer (tp-surface-test--leaf 'root "old" '(help-echo "old"))
+ '(:capability content)))
+ (revision (tp-surface-revision surface)))
+ (should-error
+ (tp-surface-update
+ surface
+ (lambda (context)
+ (tp-object-ensure context nil 'root 'text)
+ (put-text-property (point-min) (1+ (point-min))
+ 'help-echo "BAD")
+ (tp-surface-test--leaf 'root "new" '(help-echo "new"))))
+ :type 'tp-producer-buffer-mutation)
+ (should (equal (buffer-string) "old"))
+ (should (equal (get-text-property 1 'help-echo) "old"))
+ (should-not (tp--surface-stale surface))
+ (should (= (tp-surface-revision surface) revision)))))
+
+(ert-deftest tp-surface-test-boundary-crossing-uses-pre-edit-ranges ()
+ "A deletion crossing the old right boundary marks retained ranges stale."
+ (tp-surface-test--with-buffer
+ (insert "abcd")
+ (let* ((anchor (tp-range-anchor-create buffer 2 4))
+ (producer
+ (lambda (context)
+ (let ((object (tp-object-ensure context nil 'root 'range)))
+ (tp-object-attach-range context object anchor))
+ (tp-surface-plan-create
+ :key 'root :kind 'range :props '(help-echo "tp")
+ :capability 'properties)))
+ (surface (tp-surface-mount
+ buffer producer '(:capability properties))))
+ (delete-region 3 5)
+ (should (tp--anchor-stale anchor))
+ (should-error (tp-surface-update surface producer)
+ :type 'tp-stale-mount))))
+
(ert-deftest tp-surface-test-content-external-edit-marks-mount-stale ()
"An external edit inside content-owned text prevents silent overwrite."
(tp-surface-test--with-buffer
@@ -619,6 +945,58 @@
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
(when (buffer-live-p second-buffer) (kill-buffer second-buffer)))))
+(ert-deftest tp-surface-test-two-buffer-identities-are-isolated ()
+ "The same keyed producer creates separate object identity per surface."
+ (let* ((first-buffer (generate-new-buffer " *tp-surface-first*"))
+ (second-buffer (generate-new-buffer " *tp-surface-second*"))
+ (producer (lambda (context)
+ (tp-object-ensure context nil 'root 'text)
+ (tp-surface-test--leaf 'root
+ (buffer-name (current-buffer)))))
+ first second)
+ (unwind-protect
+ (progn
+ (setq first (tp-surface-mount
+ first-buffer producer '(:capability content))
+ second (tp-surface-mount
+ second-buffer producer '(:capability content)))
+ (should-not (eq (tp-object-resolve first '(root))
+ (tp-object-resolve second '(root))))
+ (should-error
+ (tp-surface-update-scoped
+ first (list (tp-object-resolve second '(root))) producer)
+ :type 'tp-cross-surface-object))
+ (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
+ (when (buffer-live-p second-buffer) (kill-buffer second-buffer)))))
+
+(ert-deftest tp-surface-test-unmount-cleans-weak-registry-and-markers ()
+ "Unmount releases weak surface registration and marker-backed state."
+ (tp-surface-test--with-buffer
+ (insert "host")
+ (let* ((anchor (tp-range-anchor-create buffer 1 5))
+ (producer
+ (lambda (context)
+ (let ((object (tp-object-ensure context nil 'root 'range)))
+ (tp-object-attach-range context object anchor))
+ (tp-surface-plan-create
+ :key 'root :kind 'range :props '(help-echo "tp")
+ :capability 'properties)))
+ (surface (tp-surface-mount
+ buffer producer '(:capability properties)))
+ (id (tp--surface-id surface))
+ (ledger (tp--surface-ledger surface))
+ (mounts (tp--surface-mounts surface)))
+ (should (eq (gethash id tp--surfaces) surface))
+ (tp-surface-unmount surface)
+ (should-not (gethash id tp--surfaces))
+ (should-not (tp-range-anchor-live-p anchor))
+ (dolist (entry ledger)
+ (should-not (marker-position (tp--property-ledger-start entry)))
+ (should-not (marker-position (tp--property-ledger-end entry))))
+ (dolist (mount mounts)
+ (should-not (marker-position (tp--surface-mount-start mount)))
+ (should-not (marker-position (tp--surface-mount-end mount)))))))
+
(ert-deftest tp-surface-test-materialize-matches-first-content-mount ()
"Pure and live publication produce identical propertized text."
(tp-surface-test--with-buffer
diff --git a/tests/tp-tests.el b/tests/tp-tests.el
index 6f599bf..0250628 100644
--- a/tests/tp-tests.el
+++ b/tests/tp-tests.el
@@ -1,4157 +1,138 @@
-;;; tp-tests.el --- ERT tests for tp.el -*- lexical-binding: t -*-
+;;; tp-tests.el --- Public TP facade tests -*- lexical-binding: t; -*-
-;; Copyright (C) 2024-2026
+;; Copyright (C) 2024-2026 Geekinney
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
-;; Comprehensive test suite for tp.el using ERT (Emacs Lisp Regression Testing).
-;; Run with:
-;; emacs --batch -L . -L tests -l tp.el -l tp-tests.el \
-;; -f ert-run-tests-batch-and-exit
+;; Focused end-to-end tests for the stateless public property facade. Retained
+;; and reactive behavior is covered by tp-surface-tests and tp-binding-tests.
;;; Code:
(require 'ert)
-(require 'cl-lib)
-(require 'tp-palette)
(require 'tp)
-;;; ============================================================
-;;; Test Utilities
-;;; ============================================================
-
(defmacro tp-test-with-temp-buffer (&rest body)
- "Execute BODY in a temporary buffer with a clean tp state.
-All layer registries, transforms and reactive watchers are cleared
-before BODY runs and again afterwards (teardown), so state cannot
-leak between tests regardless of how BODY exits."
- (declare (indent 0))
+ "Run BODY in a temporary buffer with isolated declaration recipes."
+ (declare (indent 0) (debug t))
`(unwind-protect
(with-temp-buffer
(tp-layer-reset)
,@body)
(tp-layer-reset)))
-;; 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
-;;; ============================================================
-
-(ert-deftest tp-test-put-and-get ()
- "Test tp-set and tp-get basic functionality."
+(ert-deftest tp-test-set-get-and-member-preserve-presence ()
+ "Set/get APIs preserve explicit nil separately from absence."
(tp-test-with-temp-buffer
- (insert "Hello World")
- ;; Set a single property
- (tp-set 1 6 '(face bold))
- (should (eq (tp-at 1 'face) 'bold))
- (should (eq (tp-at 3 'face) 'bold))
- (should (null (tp-at 7 'face)))
- ;; Set multiple properties
- (tp-set 7 12 '(face italic help-echo "test"))
- (should (eq (tp-at 7 'face) 'italic))
- (should (equal (tp-at 7 'help-echo) "test"))))
-
-(ert-deftest tp-test-put-with-list ()
- "Test tp-set accepts properties as a list."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold help-echo "greeting"))
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "greeting"))))
-
-(ert-deftest tp-test-put-returns-region ()
- "Test tp-set returns the modified region."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (let ((result (tp-set 1 6 '(face bold))))
- (should (equal result '(1 . 6))))))
-
-(ert-deftest tp-test-remove ()
- "Test tp-remove removes a specific property."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold help-echo "test"))
- (should (eq (tp-at 1 'face) 'bold))
- (tp-remove 1 6 'face)
- (should (null (tp-at 1 'face)))
- (should (equal (tp-at 1 'help-echo) "test"))))
-
-(ert-deftest tp-test-clear ()
- "Test tp-clear removes all properties."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-clear 1 12)
- (should (null (tp-at 1 'face)))
- (should (null (tp-at 7 'face)))))
-
-(ert-deftest tp-test-clear-defaults-to-buffer ()
- "Test tp-clear defaults to entire buffer."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 12 '(face bold))
- (tp-clear)
- (should (null (tp-at 1 'face)))
- (should (null (tp-at 7 'face)))))
-
-(ert-deftest tp-test-at ()
- "Test tp-at returns all properties at point."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold help-echo "test"))
- (let ((props (tp-at 1)))
- (should (eq (plist-get props 'face) 'bold))
- (should (equal (plist-get props 'help-echo) "test")))))
-
-(ert-deftest tp-test-at-with-property ()
- "Test tp-at returns specific property at point."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold help-echo "test"))
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "test"))
- (should (null (tp-at 1 'mouse-face)))))
-
-(ert-deftest tp-test-at-with-object ()
- "Test tp-at with string object."
- (let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face bold help-echo "greeting") str)
- ;; All properties at position
- (let ((props (tp-at 0 str)))
- (should (eq (plist-get props 'face) 'bold))
- (should (equal (plist-get props 'help-echo) "greeting")))
- ;; Specific property at position
- (should (eq (tp-at 0 'face str) 'bold))
- (should (equal (tp-at 0 'help-echo str) "greeting"))))
-
-(ert-deftest tp-test-at-with-nested-path ()
- "Test tp-at with nested property path."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (put-text-property 1 6 'face '(:foreground "red" :box (:color "blue" :line-width 2)))
- (should (equal (tp-at 1 '(face :foreground)) "red"))
- (should (equal (tp-at 1 '(face :box)) '(:color "blue" :line-width 2)))
- (should (equal (tp-at 1 '(face :box :color)) "blue"))
- (should (equal (tp-at 1 '(face :box :line-width)) 2))))
-
-(ert-deftest tp-test-at-with-nested-path-on-string ()
- "Test tp-at with nested property path on string."
- (let ((str (copy-sequence "Hello World")))
- (put-text-property 0 5 'face '(:foreground "red" :underline (:style wave)) str)
- (should (equal (tp-at 0 '(face :foreground) str) "red"))
- (should (equal (tp-at 0 '(face :underline :style) str) 'wave))))
-
-(ert-deftest tp-test-at-defaults-to-point ()
- "Test tp-at works with current point."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold))
- (goto-char 3)
- (should (eq (plist-get (tp-at (point)) 'face) 'bold))))
-
-(ert-deftest tp-test-plist ()
- "Test tp-plist merges properties from region."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- ;; Put both properties on the same overlapping region for proper merging
- (tp-set 1 12 '(face bold))
- (tp-set 1 12 '(help-echo "test"))
- (let ((props (tp-plist 1 12)))
- (should (eq (plist-get props 'face) 'bold))
- (should (equal (plist-get props 'help-echo) "test")))))
-
-(ert-deftest tp-test-plist-on-string ()
- "Test tp-plist works on entire string."
- (let ((str (tp-set "Hello World" 'face 'bold 'help-echo "test")))
- (let ((props (tp-plist str)))
- (should (eq (plist-get props 'face) 'bold))
- (should (equal (plist-get props 'help-echo) "test")))))
-
-(ert-deftest tp-test-plist-on-string-range ()
- "Test tp-plist works on string range with object parameter."
- (let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face bold) str)
- (tp-set 6 11 '(help-echo "test") str)
- (let ((props-start (tp-plist 0 5 str))
- (props-end (tp-plist 6 11 str)))
- (should (eq (plist-get props-start 'face) 'bold))
- (should (equal (plist-get props-end 'help-echo) "test")))))
-
-;;; ============================================================
-;;; Text Property Interval Tests
-;;; ============================================================
-
-(ert-deftest tp-test-empty-p ()
- "Test tp-empty-p detects empty properties."
- (should (tp-empty-p "plain string"))
- (should-not (tp-empty-p (propertize "styled" 'face 'bold))))
-
-(ert-deftest tp-test-empty-p-with-nil ()
- "Test tp-empty-p with nil (current buffer)."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- ;; Empty buffer (no properties)
- (should (tp-empty-p nil))
- (should (tp-empty-p))
- ;; Add properties
- (tp-set 1 6 '(face bold))
- (should-not (tp-empty-p nil))
- (should-not (tp-empty-p))))
-
-(ert-deftest tp-test-empty-p-with-buffer ()
- "Test tp-empty-p with explicit buffer object."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (let ((buf (current-buffer)))
- ;; Empty (no properties)
- (should (tp-empty-p buf))
- ;; Add properties
- (tp-set 1 6 '(face bold))
- (should-not (tp-empty-p buf)))))
-
-(ert-deftest tp-test-intervals ()
- "Test tp-intervals returns property intervals."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (let ((intervals (tp-intervals 1 12)))
- (should (>= (length intervals) 2)))))
-
-;;; ============================================================
-;;; Layer Definition Tests (using define-tp)
-;;; ============================================================
-
-(ert-deftest tp-test-layer-props ()
- "Test tp-layer-props returns properties, and tp-name when requested."
- (tp-test-with-temp-buffer
- (define-tp my-layer ()
- '(face bold))
- ;; Without tp-name (default for direct property setting)
- (let ((props (tp-layer-props 'my-layer)))
- (should (eq (plist-get props 'face) 'bold))
- (should-not (plist-get props 'tp-name)))
- ;; With tp-name (for layer stack functions)
- (let ((props (tp-layer-props 'my-layer t)))
- (should (eq (plist-get props 'face) 'bold))
- (should (eq (plist-get props 'tp-name) 'my-layer)))))
-
-(ert-deftest tp-test-layer-props-returns-nil-for-undefined ()
- "Test tp-layer-props returns nil for undefined layer."
- (tp-test-with-temp-buffer
- (should (null (tp-layer-props 'undefined-layer)))))
-
-(ert-deftest tp-test-layer-undefine ()
- "Test tp-undefine-layer removes layer definition."
- (tp-test-with-temp-buffer
- (define-tp test-layer ()
- '(face bold))
- (should (assoc 'test-layer tp-layer-alist))
- (tp-undefine-layer 'test-layer)
- (should-not (assoc 'test-layer tp-layer-alist))))
-
-;;; ============================================================
-;;; Layer Group Tests (using define-tps)
-;;; ============================================================
-
-(ert-deftest tp-test-group-props ()
- "Test tp-group-props returns all layer properties."
- (tp-test-with-temp-buffer
- (define-tp layer1 ()
- '(face bold))
- (define-tp layer2 ()
- '(face italic))
- (define-tps my-group ()
- 'layer1
- 'layer2)
- (let ((props-list (tp-group-props 'my-group)))
- (should (= (length props-list) 2))
- ;; Check that both layers are present
- (let ((faces (mapcar (lambda (p) (plist-get p 'face)) props-list)))
- (should (memq 'bold faces))
- (should (memq 'italic faces))))))
-
-(ert-deftest tp-test-group-undefine ()
- "Test tp-undefine-group removes group definition."
- (tp-test-with-temp-buffer
- (define-tp layer1 ()
- '(face bold))
- (define-tps my-group ()
- 'layer1)
- (should (assoc 'my-group tp-layer-groups))
- (tp-undefine-group 'my-group)
- (should-not (assoc 'my-group tp-layer-groups))))
-
-(ert-deftest tp-test-layer-reset ()
- "Test tp-layer-reset clears all definitions."
- (tp-test-with-temp-buffer
- (define-tp layer1 ()
- '(face bold))
- (define-tp layer2 ()
- '(face italic))
- (define-tps group1 ()
- 'layer1
- 'layer2)
- (should tp-layer-alist)
- (should tp-layer-groups)
- (tp-layer-reset)
- (should-not tp-layer-alist)
- (should-not tp-layer-groups)))
-
-;;; ============================================================
-;;; Layer Stack Operations Tests (New API)
-;;; ============================================================
-
-(ert-deftest tp-test-push-layer ()
- "Test tp-push-layer adds layer to stack."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (tp-push-layer 1 6 'layer1)
- (should (eq (tp-at 1 'face) 'bold))
- (should (eq (tp-at 1 'tp-name) 'layer1))))
-
-(ert-deftest tp-test-push-layer-multiple ()
- "Test pushing multiple layers."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; layer2 should be on top (visible)
- (should (eq (tp-at 1 'face) 'italic))
- (should (eq (tp-at 1 'tp-name) 'layer2))
- ;; layer1 should be in the stack below
- (should (tp-at 1 'tp-layers))))
-
-(ert-deftest tp-test-delete-layer ()
- "Test tp-delete-layer removes layer from stack."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; Delete top layer
- (tp-delete-layer 1 6 'layer2)
- ;; layer1 should now be visible
- (should (eq (tp-at 1 'face) 'bold))
- (should (eq (tp-at 1 'tp-name) 'layer1))))
-
-(ert-deftest tp-test-delete-layer-from-middle ()
- "Test deleting layer from middle of stack."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; Delete middle layer
- (tp-delete-layer 1 6 'layer2)
- ;; Top layer should still be visible
- (should (eq (tp-at 1 'tp-name) 'layer3))
- ;; layer2 should not exist anymore
- (should-not (tp-layer-exists-p 1 6 'layer2))))
-
-(ert-deftest tp-test-pop-layer ()
- "Test tp-pop-layer removes top layer."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; Pop top layer
- (tp-pop-layer 1 6)
- ;; layer1 should now be visible
- (should (eq (tp-at 1 'tp-name) 'layer1))))
-
-(ert-deftest tp-test-rotate-layer ()
- "Test tp-rotate-layer cycles layers."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; layer3 is on top
- (should (eq (tp-layer-top 1 6) 'layer3))
- ;; Rotate once - layer2 should be on top
- (tp-rotate-layer 1 6)
- (should (eq (tp-layer-top 1 6) 'layer2))
- ;; Rotate again - layer1 should be on top
- (tp-rotate-layer 1 6)
- (should (eq (tp-layer-top 1 6) 'layer1))
- ;; Rotate again - layer3 should be on top (cycled back)
- (tp-rotate-layer 1 6)
- (should (eq (tp-layer-top 1 6) 'layer3))))
-
-(ert-deftest tp-test-pin-layer ()
- "Test tp-pin-layer brings layer to top."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; Pin layer1 to top
- (tp-pin-layer 1 6 'layer1)
- (should (eq (tp-layer-top 1 6) 'layer1))))
-
-(ert-deftest tp-test-raise-layer ()
- "Test tp-raise-layer moves layer up."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; layer3 is at idx 0, layer2 at 1, layer1 at 2
- ;; Raise layer1 by 2 (move to top)
- (tp-raise-layer 1 6 'layer1 2)
- (should (eq (tp-layer-top 1 6) 'layer1))))
-
-(ert-deftest tp-test-switch-layer ()
- "Test tp-switch-layer swaps two layers."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; layer2 is on top
- (should (eq (tp-layer-top 1 6) 'layer2))
- ;; Switch layer1 and layer2
- (tp-switch-layer 1 6 'layer1 'layer2)
- ;; layer1 should now be on top
- (should (eq (tp-layer-top 1 6) 'layer1))))
-
-(ert-deftest tp-test-move-layer-by-index ()
- "Test tp-move-layer moves layer by index."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; Stack: layer3 (0), layer2 (1), layer1 (2)
- (should (eq (tp-layer-top 1 6) 'layer3))
- ;; Move layer at index 2 (layer1) to index 0 (top)
- (tp-move-layer 1 6 2 0)
- ;; layer1 should now be on top
- (should (eq (tp-layer-top 1 6) 'layer1))))
-
-(ert-deftest tp-test-move-layer-by-name ()
- "Test tp-move-layer moves layer by name."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; Stack: layer3 (0), layer2 (1), layer1 (2)
- (should (eq (tp-layer-top 1 6) 'layer3))
- ;; Move layer1 to index 0 (top)
- (tp-move-layer 1 6 'layer1 0)
- ;; layer1 should now be on top
- (should (eq (tp-layer-top 1 6) 'layer1))))
-
-(ert-deftest tp-test-move-layer-negative-index ()
- "Test tp-move-layer with negative indices."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; Stack: layer3 (0/-3), layer2 (1/-2), layer1 (2/-1)
- (should (eq (tp-layer-top 1 6) 'layer3))
- ;; Move top layer (0) to bottom (-1)
- (tp-move-layer 1 6 0 -1)
- ;; layer2 should now be on top
- (should (eq (tp-layer-top 1 6) 'layer2))))
-
-(ert-deftest tp-test-move-layer-on-string ()
- "Test tp-move-layer works on strings."
- (let ((str (copy-sequence "Hello")))
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer str 'layer1)
- (tp-push-layer str 'layer2)
- ;; layer2 is on top
- (should (eq (tp-at 0 'tp-name str) 'layer2))
- ;; Move layer1 to top
- (tp-move-layer str 'layer1 0)
- ;; layer1 should now be on top
- (should (eq (tp-at 0 'tp-name str) 'layer1))))
-
-(ert-deftest tp-test-put-layer-at-idx ()
- "Test tp-put-layer inserts layer at specified index."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; Insert layer3 at index 1 (between layer2 and layer1)
- (tp-put-layer 1 6 'layer3 1)
- ;; layer2 should still be on top
- (should (eq (tp-layer-top 1 6) 'layer2))
- ;; Should have 3 layers
- (should (= (tp-layer-count 1 6) 3))))
-
-(ert-deftest tp-test-merge-layers ()
- "Test tp-merge-layers merges specified layers."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(help-echo "test"))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; Merge layer1 and layer2 into merged-layer
- (tp-merge-layers 1 6 'merged-layer '(layer1 layer2))
- ;; Should have 1 layer now
- (should (= (tp-layer-count 1 6) 1))
- ;; The merged layer should have properties from both
- (should (eq (tp-at 1 'tp-name) 'merged-layer))))
-
-(ert-deftest tp-test-flatten-layers ()
- "Test tp-flatten-layers flattens all layers."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(help-echo "test"))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; Flatten all layers into flat-layer
- (tp-flatten-layers 1 6 'flat-layer)
- ;; Should have 1 layer now
- (should (= (tp-layer-count 1 6) 1))
- (should (eq (tp-at 1 'tp-name) 'flat-layer))))
-
-;;; ============================================================
-;;; Layer Query Tests
-;;; ============================================================
-
-(ert-deftest tp-test-layer-list ()
- "Test tp-layer-list returns all layer names."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- (let ((layers (tp-layer-list 1 6)))
- (should (= (length layers) 3))
- (should (memq 'layer1 layers))
- (should (memq 'layer2 layers))
- (should (memq 'layer3 layers)))))
-
-(ert-deftest tp-test-layer-count ()
- "Test tp-layer-count returns correct count."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1)
- (should (= (tp-layer-count 1 6) 1))
- (tp-push-layer 1 6 'layer2)
- (should (= (tp-layer-count 1 6) 2))))
-
-(ert-deftest tp-test-layer-exists-p ()
- "Test tp-layer-exists-p correctly detects layers."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (tp-push-layer 1 6 'layer1)
- (should (tp-layer-exists-p 1 6 'layer1))
- (should-not (tp-layer-exists-p 1 6 'layer2))))
-
-(ert-deftest tp-test-layer-top ()
- "Test tp-layer-top returns top layer name."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1)
- (should (eq (tp-layer-top 1 6) 'layer1))
- (tp-push-layer 1 6 'layer2)
- (should (eq (tp-layer-top 1 6) 'layer2))))
-
-;;; ============================================================
-;;; Match and Regexp Tests
-;;; ============================================================
-
-(ert-deftest tp-test-match-set ()
- "Test tp-match-set sets properties on string matches."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (let ((regions (tp-match-set "Hello" '(face bold))))
- (should (= (length regions) 2))
- (should (eq (tp-at 1 'face) 'bold))
- (should (eq (tp-at 13 'face) 'bold)))))
-
-(ert-deftest tp-test-match-set-returns-regions ()
- "Test tp-match-set returns correct region pairs."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (let ((regions (tp-match-set "Hello" nil)))
- (should (= (length regions) 2))
- (should (equal (car regions) '(1 . 6)))
- (should (equal (cadr regions) '(13 . 18))))))
-
-(ert-deftest tp-test-regexp-set ()
- "Test tp-regexp-set sets properties on regexp matches."
- (tp-test-with-temp-buffer
- (insert "abc 123 def 456")
- (let ((regions (tp-regexp-set "[0-9]+" '(face bold))))
- (should (= (length regions) 2))
- (should (eq (tp-at 5 'face) 'bold))
- (should (eq (tp-at 13 'face) 'bold)))))
-
-(ert-deftest tp-test-regexp-set-returns-regions ()
- "Test tp-regexp-set returns correct region pairs."
- (tp-test-with-temp-buffer
- (insert "abc 123 def 456")
- (let ((regions (tp-regexp-set "[0-9]+" nil)))
- (should (= (length regions) 2)))))
-
-;;; ============================================================
-;;; Search and Navigation Tests
-;;; ============================================================
-
-(ert-deftest tp-test-forward ()
- "Test tp-forward finds next property."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 7 12 '(face bold))
- (goto-char 1)
- (let ((match (tp-forward 'face)))
- (should match)
- (should (= (prop-match-beginning match) 7))
- (should (= (prop-match-end match) 12)))))
-
-(ert-deftest tp-test-forward-on-string ()
- "Test tp-forward works on string objects."
- (let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- (let ((matches (tp-forward 'marker tp-any-value str 2)))
- (should (= (length matches) 2))
- (should (equal (car matches) '(0 5 t)))
- (should (equal (cadr matches) '(12 17 t))))))
-
-(ert-deftest tp-test-forward-with-n ()
- "Test tp-forward with N parameter."
- (tp-test-with-temp-buffer
- (insert "Hello World Test Again")
- (tp-set 1 6 '(face bold))
- (tp-set 7 12 '(face italic))
- (tp-set 13 17 '(face bold))
- (goto-char 1)
- ;; Search twice should find third match
- (let ((match (tp-forward 'face tp-any-value nil 2)))
- (should match))))
-
-(ert-deftest tp-test-backward ()
- "Test tp-backward finds previous property."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (goto-char 12)
- ;; Explicit VALUE finds the previous region carrying that value.
- (let ((match (tp-backward 'face 'bold)))
- (should match)
- (should (= (prop-match-beginning match) 1)))
- ;; Omitting VALUE matches any directly present property value.
- (goto-char 12)
- (let ((match (tp-backward 'face)))
- (should match)
- (should (= (prop-match-beginning match) 1))
- (should (= (prop-match-end match) 6)))))
-
-(ert-deftest tp-test-backward-on-string ()
- "Test tp-backward works on string objects."
- (let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- (let ((matches (tp-backward 'marker tp-any-value str 2)))
- (should (= (length matches) 2))
- ;; Backward returns matches in reverse order
- (should (equal (car matches) '(12 17 t)))
- (should (equal (cadr matches) '(0 5 t))))))
-
-;;; tp-forward-do / tp-backward-do tests (new API)
-
-(ert-deftest tp-test-forward-do-on-string ()
- "Test tp-forward-do on string: applies function to the last match."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Search 2 times, function only applied to the last match
- (let ((count (tp-forward-do #'upcase 'marker tp-any-value str 2)))
- (should (= count 2))
- ;; First match should NOT be upcased
- (should (equal (substring str 0 5) "hello"))
- ;; Only the last (2nd) match should be upcased
- (should (equal (substring str 12 17) "HELLO")))))
-
-(ert-deftest tp-test-forward-do-on-string-with-range ()
- "Test tp-forward-do on string with start/end range.
-TIMES targets the TIMES-th match specifically; with only one match in
-range, asking for the 2nd applies nothing (all-or-nothing, matching
-the buffer path) and returns the available count."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Search only in range 6-17 (after first match)
- (let ((count
- (tp-forward-do #'upcase 'marker tp-any-value str 2 6 17)))
- (should (= count 1)) ; Only one match in range 6-17
- ;; First match should NOT be upcased
- (should (equal (substring str 0 5) "hello"))
- ;; The requested 2nd match does not exist: nothing is applied
- (should (equal (substring str 12 17) "hello")))))
-
-(ert-deftest tp-test-forward-do-function-receives-start-end ()
- "Test tp-forward-do passes start and end to function."
- (let ((str (copy-sequence "hello World hello"))
- (starts nil)
- (ends nil))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Function accepts text, start, end
- (let ((count (tp-forward-do (lambda (txt start end)
- (push start starts)
- (push end ends)
- (upcase txt))
- 'marker tp-any-value str 2)))
- (should (= count 2))
- ;; Only the last match positions were passed to function
- (should (equal starts '(12)))
- (should (equal ends '(17)))
- ;; Only the last match should be upcased
- (should (equal (substring str 0 5) "hello"))
- (should (equal (substring str 12 17) "HELLO")))))
-
-(ert-deftest tp-test-forward-do-single-arg-function ()
- "Test tp-forward-do with single-argument function."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Use #'upcase which only takes one argument
- (tp-forward-do #'upcase 'marker tp-any-value str 2)
- ;; Only the last match should be upcased
- (should (equal (substring str 0 5) "hello"))
- (should (equal (substring str 12 17) "HELLO"))))
-
-(ert-deftest tp-test-backward-do-on-string ()
- "Test tp-backward-do on string: applies function to the last match."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Search backward 2 times, function only applied to the last match
- (let ((count (tp-backward-do
- #'upcase 'marker tp-any-value str 2)))
- (should (= count 2))
- ;; Only the last (2nd) match should be upcased (first in order)
- (should (equal (substring str 0 5) "HELLO"))
- ;; First match (searched backward) should NOT be upcased
- (should (equal (substring str 12 17) "hello")))))
-
-(ert-deftest tp-test-backward-do-on-string-with-range ()
- "Test tp-backward-do on string with start/end range.
-All-or-nothing: with one match in range, requesting the 2nd applies
-nothing and returns the available count."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Search only in range 0-10 (before second match)
- (let ((count
- (tp-backward-do #'upcase 'marker tp-any-value str 2 0 10)))
- (should (= count 1)) ; Only one match in range 0-10
- ;; The requested 2nd match does not exist: nothing is applied
- (should (equal (substring str 0 5) "hello"))
- (should (equal (substring str 12 17) "hello")))))
-
-(ert-deftest tp-test-backward-do-function-receives-start-end ()
- "Test tp-backward-do passes start and end to function."
- (let ((str (copy-sequence "hello World hello"))
- (starts nil)
- (ends nil))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Function accepts text, start, end
- (let ((count (tp-backward-do (lambda (txt start end)
- (push start starts)
- (push end ends)
- (upcase txt))
- 'marker tp-any-value str 2)))
- (should (= count 2))
- ;; Only the last match positions were passed to function
- (should (equal starts '(0)))
- (should (equal ends '(5)))
- ;; Only the last match should be upcased
- (should (equal (substring str 0 5) "HELLO"))
- (should (equal (substring str 12 17) "hello")))))
-
-(ert-deftest tp-test-backward-do-single-arg-function ()
- "Test tp-backward-do with single-argument function."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Use #'upcase which only takes one argument
- (tp-backward-do #'upcase 'marker tp-any-value str 2)
- ;; Only the last match should be upcased
- (should (equal (substring str 0 5) "HELLO"))
- (should (equal (substring str 12 17) "hello"))))
-
-(ert-deftest tp-test-search-on-string ()
- "Test tp-search finds all matching properties in a string."
- (let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- (let ((matches (tp-search str 'marker)))
- (should (= (length matches) 2))
- (should (equal (car matches) '(0 5 t)))
- (should (equal (cadr matches) '(12 17 t))))))
-
-(ert-deftest tp-test-search-on-string-with-value ()
- "Test tp-search filters by value in a string."
- (let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(type heading) str)
- (tp-set 6 11 '(type paragraph) str)
- (tp-set 12 17 '(type heading) str)
- (let ((matches (tp-search str 'type 'heading)))
- (should (= (length matches) 2))
- (should (equal (caddr (car matches)) 'heading))
- (should (equal (caddr (cadr matches)) 'heading)))))
-
-(ert-deftest tp-test-search-in-range ()
- "Test tp-search finds all matching properties in a buffer range."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (tp-set 1 6 '(marker t))
- (tp-set 13 18 '(marker t))
- (let ((matches (tp-search 1 18 'marker)))
- (should (= (length matches) 2))
- (should (equal (car matches) '(1 6 t)))
- (should (equal (cadr matches) '(13 18 t))))))
-
-(ert-deftest tp-test--search-do-on-string ()
- "Test tp--search-do applies function to all matches in a string (internal API)."
- (let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- (let ((result nil))
- (tp--search-do
- (lambda (match _obj)
- (push (car match) result))
- 'marker tp-any-value str)
- (should (= (length result) 2))
- (should (member 0 result))
- (should (member 12 result)))))
-
-(ert-deftest tp-test--search-do-in-range ()
- "Test tp--search-do applies function to all matches in a buffer range (internal API)."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (tp-set 1 6 '(marker t))
- (tp-set 13 18 '(marker t))
- (let ((result nil))
- (tp--search-do
- (lambda (match _obj)
- (push (car match) result))
- 'marker tp-any-value nil 1 18)
- (should (= (length result) 2))
- (should (member 1 result))
- (should (member 13 result)))))
-
-(ert-deftest tp-test-search-map-on-string ()
- "Test tp-search-map applies function to matched text in a string."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- (let ((count (tp-search-map #'upcase 'marker tp-any-value str)))
- (should (= count 2))
- ;; Check that text was upcased
- (should (equal (substring str 0 5) "HELLO"))
- (should (equal (substring str 12 17) "HELLO")))))
-
-(ert-deftest tp-test-search-map-in-range ()
- "Test tp-search-map applies function to matched text in a buffer range."
- (tp-test-with-temp-buffer
- (insert "hello World hello")
- (tp-set 1 6 '(marker t))
- (tp-set 13 18 '(marker t))
- (let ((count
- (tp-search-map #'upcase 'marker tp-any-value nil 1 18)))
- (should (= count 2))
- ;; Check that text was upcased
- (should (equal (buffer-substring 1 6) "HELLO"))
- (should (equal (buffer-substring 13 18) "HELLO")))))
-
-(ert-deftest tp-test-search-map-property-modification ()
- "Test tp-search-map applies property modifications to matched text."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; First upcase the text
- (tp-search-map #'upcase 'marker tp-any-value str)
- ;; Then add face property
- (tp-search-map (lambda (txt)
- (tp-add txt 'face '(:background "orange")))
- 'marker tp-any-value str)
- ;; Check text was upcased
- (should (equal (substring str 0 5) "HELLO"))
- (should (equal (substring str 12 17) "HELLO"))
- ;; Check face property was added
- (let ((props-0 (text-properties-at 0 str))
- (props-12 (text-properties-at 12 str)))
- (should (equal (plist-get (plist-get props-0 'face) :background) "orange"))
- (should (equal (plist-get (plist-get props-12 'face) :background) "orange")))))
-
-(ert-deftest tp-test-search-map-with-start-end-idx ()
- "Test tp-search-map passes start, end, and index to function."
- (let ((str (copy-sequence "aaa bbb ccc"))
- (positions nil))
- (tp-set 0 3 '(marker t) str)
- (tp-set 4 7 '(marker t) str)
- (tp-set 8 11 '(marker t) str)
- ;; Use a function that accepts text, start, end, idx
- (tp-search-map (lambda (txt start end idx)
- (push (list start end idx) positions)
- (upcase txt))
- 'marker tp-any-value str)
- ;; Check positions and indices were passed in order (reversed due to push)
- (should (equal (reverse positions) '((0 3 0) (4 7 1) (8 11 2))))
- ;; Check text was transformed (uppercased)
- (should (equal (substring str 0 3) "AAA"))
- (should (equal (substring str 4 7) "BBB"))
- (should (equal (substring str 8 11) "CCC"))))
-
-(ert-deftest tp-test-search-map-with-start-end-in-buffer ()
- "Test tp-search-map passes start and end to function in buffer range."
- (tp-test-with-temp-buffer
- (insert "aaa bbb ccc")
- (tp-set 1 4 '(marker t))
- (tp-set 5 8 '(marker t))
- (tp-set 9 12 '(marker t))
- (let ((positions nil))
- (tp-search-map (lambda (_txt start end idx)
- (push (list start end idx) positions)
- (format "[%d]" idx))
- 'marker tp-any-value nil 1 12)
- ;; Check positions and indices were passed in order
- (should (equal (reverse positions) '((1 4 0) (5 8 1) (9 12 2))))
- ;; Check text was replaced with index markers
- (should (string-match-p "\\[0\\]" (buffer-string)))
- (should (string-match-p "\\[1\\]" (buffer-string)))
- (should (string-match-p "\\[2\\]" (buffer-string))))))
-
-(ert-deftest tp-test-search-map-backward-compat ()
- "Test tp-search-map still works with single-argument functions."
- (let ((str (copy-sequence "hello world")))
- (tp-set 0 5 '(marker t) str)
- ;; Use #'upcase which only takes one argument
- (tp-search-map #'upcase 'marker tp-any-value str)
- (should (equal (substring str 0 5) "HELLO"))))
-
-(ert-deftest tp-test-search-map-with-range ()
- "Test tp-search-map with start and end range."
- (let ((str (copy-sequence "hello World hello")))
- (tp-set 0 5 '(marker t) str)
- (tp-set 12 17 '(marker t) str)
- ;; Only search in range 0-10 (first match only)
- (let ((count
- (tp-search-map #'upcase 'marker tp-any-value str 0 10)))
- (should (= count 1))
- ;; First match should be upcased
- (should (equal (substring str 0 5) "HELLO"))
- ;; Second match should NOT be upcased
- (should (equal (substring str 12 17) "hello")))))
-
-;;; ============================================================
-;;; Utility Function Tests
-;;; ============================================================
-
-;; Tests for tp-search are in Search and Navigation Tests section above
-
-;;; ============================================================
-;;; Edge Case Tests
-;;; ============================================================
-
-(ert-deftest tp-test-empty-region ()
- "Test operations on empty buffer."
- (tp-test-with-temp-buffer
- (should (null (tp-at 1)))
- (should (tp-empty-p))))
-
-(ert-deftest tp-test-overlapping-regions ()
- "Test overlapping property regions."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 8 '(prop1 val1))
- (tp-set 5 12 '(prop2 val2))
- (should (eq (tp-at 1 'prop1) 'val1))
- (should (null (tp-at 1 'prop2)))
- (should (eq (tp-at 6 'prop1) 'val1))
- (should (eq (tp-at 6 'prop2) 'val2))
- (should (null (tp-at 10 'prop1)))
- (should (eq (tp-at 10 'prop2) 'val2))))
-
-(ert-deftest tp-test-single-char-region ()
- "Test operations on single character."
- (tp-test-with-temp-buffer
- (insert "H")
- (tp-set 1 2 '(face bold))
- (should (eq (tp-at 1 'face) 'bold))))
-
-(ert-deftest tp-test-layer-on-string ()
- "Test layer operations on string object."
- (let ((str (copy-sequence "Hello")))
- (set-text-properties 0 5 nil str)
- (should (tp-empty-p str))))
-
-;;; ============================================================
-;;; Object Parameter Support Tests
-;;; ============================================================
-
-(ert-deftest tp-test-put-on-string ()
- "Test tp-set works on string objects."
- (let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face bold) str)
- (should (eq (get-text-property 0 'face str) 'bold))
- (should (null (get-text-property 6 'face str)))))
-
-(ert-deftest tp-test-put-on-string-returns-string ()
- "Test tp-set returns the modified string."
- (let* ((str (copy-sequence "Hello"))
- (result (tp-set 0 5 '(face bold) str)))
- (should (stringp result))
- (should (eq (get-text-property 0 'face result) 'bold))))
-
-(ert-deftest tp-test-put-entire-string ()
- "Test tp-set applies to entire string with flat properties."
- (let* ((str (copy-sequence "Hello"))
- (result (tp-set str 'face 'bold 'help-echo "test")))
- (should (stringp result))
+ (insert "hello")
+ (should (equal (tp-set 1 6 '(face bold help-echo nil)) '(1 . 6)))
+ (should (eq (tp-at 2 'face) 'bold))
+ (should (equal (tp-member 2 'help-echo) '(help-echo nil)))
+ (should-not (tp-member 2 'mouse-face))
+ (should (equal (tp-get 1 6 'help-echo) '((1 6 nil))))))
+
+(ert-deftest tp-test-set-string-whole-object-is-nondestructive ()
+ "Whole-string mutation returns a copy and leaves its input untouched."
+ (let* ((source (copy-sequence "hello"))
+ (result (tp-set source 'face 'bold 'help-echo "tip")))
+ (should-not (eq source result))
+ (should-not (text-properties-at 0 source))
(should (eq (get-text-property 0 'face result) 'bold))
- (should (equal (get-text-property 0 'help-echo result) "test"))
- (should (eq (get-text-property 4 'face result) 'bold))))
-
-(ert-deftest tp-test-match-set-on-string ()
- "Test tp-match-set works on string objects."
- (let* ((str (copy-sequence "Hello World Hello"))
- (result (tp-match-set "Hello" '(face bold) str)))
- (should (stringp result))
- (should (eq (get-text-property 0 'face result) 'bold))
- (should (eq (get-text-property 12 'face result) 'bold))
- (should (null (get-text-property 6 'face result)))))
-
-(ert-deftest tp-test-regexp-set-on-string ()
- "Test tp-regexp-set works on string objects."
- (let* ((str (copy-sequence "abc 123 def 456"))
- (result (tp-regexp-set "[0-9]+" '(face bold) str)))
- (should (stringp result))
- (should (eq (get-text-property 4 'face result) 'bold))
- (should (eq (get-text-property 12 'face result) 'bold))
- (should (null (get-text-property 0 'face result)))))
-
-;;; ============================================================
-;;; Enhanced tp-get Tests
-;;; ============================================================
-
-(ert-deftest tp-test-get-single-position ()
- "Test tp-get with single position."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold))
- (should (eq (tp-at 1 'face) 'bold))
- (should (eq (tp-at 3 'face) 'bold))))
-
-(ert-deftest tp-test-get-range-property ()
- "Test tp-get with range and specific property.
-Returns list of (START END VALUE) intervals."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- (should (equal (tp-get 1 6 'face) '((1 6 bold))))
- (should (null (tp-get 7 12 'face)))))
-
-(ert-deftest tp-test-get-range-all-properties ()
- "Test tp-get with range returns all property intervals."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold help-echo "test"))
- (let ((intervals (tp-get 1 6)))
- (should (= (length intervals) 1))
- (let ((props (caddr (car intervals))))
- (should (eq (plist-get props 'face) 'bold))
- (should (equal (plist-get props 'help-echo) "test"))))))
-
-(ert-deftest tp-test-get-range-on-string ()
- "Test tp-get with range on string object.
-Returns list of (START END VALUE) intervals."
- (let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face bold) str)
- (should (equal (tp-get 0 5 'face str) '((0 5 bold))))
- (should (null (tp-get 6 11 'face str)))))
-
-;;; ============================================================
-;;; New API Tests (tp-reset, tp-set, tp-set-face, tp-set-display, tp-add)
-;;; ============================================================
-
-(ert-deftest tp-test-reset ()
- "Test tp-reset completely replaces all properties."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold help-echo "test"))
- ;; tp-reset should completely replace
- (tp-reset 1 6 '(mouse-face highlight))
- (should (eq (tp-at 1 'mouse-face) 'highlight))
- (should (null (tp-at 1 'face)))
- (should (null (tp-at 1 'help-echo)))))
-
-(ert-deftest tp-test-reset-on-string ()
- "Test tp-reset on string."
- (let ((str (copy-sequence "Hello World")))
- (tp-set 0 5 '(face bold help-echo "test") str)
- (tp-reset 0 5 '(mouse-face highlight) str)
- (should (eq (get-text-property 0 'mouse-face str) 'highlight))
- (should (null (get-text-property 0 'face str)))))
-
-(ert-deftest tp-test-reset-entire-string ()
- "Test tp-reset on entire string."
- (let* ((str (tp-set "Hello" 'face 'bold 'help-echo "test"))
- (result (tp-reset str 'mouse-face 'highlight)))
- (should (eq (get-text-property 0 'mouse-face result) 'highlight))
- (should (null (get-text-property 0 'face result)))))
-
-(ert-deftest tp-test-set-preserves-other-properties ()
- "Test tp-set preserves unspecified properties."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold help-echo "test"))
- ;; tp-set should only replace specified properties
- (tp-set 1 6 '(face italic))
- (should (eq (tp-at 1 'face) 'italic))
- (should (equal (tp-at 1 'help-echo) "test"))))
-
-(ert-deftest tp-test-add ()
- "Test tp-add adds/updates properties without replacing."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face bold help-echo "test"))
- (tp-add 1 6 '(mouse-face highlight))
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "test"))
- (should (eq (tp-at 1 'mouse-face) 'highlight))))
-
-(ert-deftest tp-test-add-deep-merge ()
- "Test tp-add deeply merges nested properties."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (tp-set 1 6 '(face (:foreground "red" :weight bold)))
- (tp-add 1 6 '(face (:background "blue")))
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "red"))
- (should (eq (plist-get face :weight) 'bold))
- (should (equal (plist-get face :background) "blue")))))
-
-(ert-deftest tp-test-add-face-subprop-override ()
- "Test tp-add correctly merges face sub-properties.
-Later values should override earlier values for the same sub-property."
- ;; The original issue: (tp-add (tp-add (tp-set \"emacs\" 'face 'bold)
- ;; 'face '(:foreground \"red\")) 'face '(bold (:foreground \"green\")))
- ;; should result in :foreground \"green\", not both \"red\" and \"green\"
- (let* ((base (tp-set "emacs" 'face 'bold))
- (with-red (tp-add base 'face '(:foreground "red")))
- (with-green (tp-add with-red 'face '(bold (:foreground "green")))))
- ;; Final result should have only one :foreground which is "green"
- (let ((face3 (get-text-property 0 'face with-green)))
- (should (listp face3))
- (should (member 'bold face3))
- ;; Extract the plist part
- (let ((plist-part (cl-find-if (lambda (f)
- (and (listp f) (keywordp (car-safe f))))
- face3)))
- (should plist-part)
- (should (equal (plist-get plist-part :foreground) "green"))
- ;; Ensure there's no duplicate :foreground
- (let ((plist-count (cl-count-if (lambda (f)
- (and (listp f) (keywordp (car-safe f))))
- face3)))
- (should (= plist-count 1)))))))
-
-(ert-deftest tp-test-add-on-string ()
- "Test tp-add on string."
- (let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-add 0 5 '(help-echo "test") str)
- (should (eq (get-text-property 0 'face str) 'bold))
- (should (equal (get-text-property 0 'help-echo str) "test"))))
-
-;;; ============================================================
-;;; Enhanced tp-at Tests
-;;; ============================================================
-
-(ert-deftest tp-test-at-nested-sub-property ()
- "Test tp-at with nested sub-properties."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (put-text-property 1 6 'face '(:foreground "red" :box (:color "blue" :line-width 2)))
- (should (equal (tp-at 1 '(face :foreground)) "red"))
- (should (equal (tp-at 1 '(face :box :color)) "blue"))
- (should (equal (tp-at 1 '(face :box :line-width)) 2))))
-
-(ert-deftest tp-test-at-display-sub-property ()
- "Test tp-at with display sub-properties that are plists."
- (tp-test-with-temp-buffer
- (insert "Hello")
- ;; Use a plist-style display property
- (put-text-property 1 6 'display '(:height 1.5 :width 10))
- (should (equal (tp-at 1 '(display :height)) 1.5))
- (should (equal (tp-at 1 '(display :width)) 10))))
-
-;;; ============================================================
-;;; Enhanced tp-remove Tests
-;;; ============================================================
-
-(ert-deftest tp-test-remove-sub-property-with-path ()
- "Test tp-remove with sub-property path."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (put-text-property 1 6 'face '(:foreground "red" :underline (:style wave :color "blue")))
- ;; Remove just :underline from face
- (tp-remove 1 6 '(face :underline))
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "red"))
- (should (null (plist-get face :underline))))))
-
-(ert-deftest tp-test-remove-nested-sub-properties ()
- "Test tp-remove with nested sub-properties."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (put-text-property 1 6 'face '(:foreground "red" :underline (:style wave :position t :color "blue")))
- ;; Remove :style and :position from :underline, keep :color
- (tp-remove 1 6 '(face :underline (:style :position)))
- (let* ((face (tp-at 1 'face))
- (underline (plist-get face :underline)))
- (should (equal (plist-get face :foreground) "red"))
- (should (equal (plist-get underline :color) "blue"))
- (should (null (plist-get underline :style)))
- (should (null (plist-get underline :position))))))
-
-;;; ============================================================
-;;; Match Pattern Format Tests
-;;; ============================================================
-
-(ert-deftest tp-test-match-set-multiple-patterns ()
- "Test tp-match-set with multiple patterns (list of patterns)."
- (tp-test-with-temp-buffer
- (insert "Hello world, Hello again")
- ;; Match both "world" and "Hello" - both should get properties applied
- (let ((regions (tp-match-set '("world" "Hello") '(face bold))))
- ;; Should find 3 matches: "Hello", "world", "Hello"
- (should (= (length regions) 3))
- ;; Check that "Hello" at position 1 has face bold
- (should (eq (tp-at 1 'face) 'bold))
- ;; Check that "world" at position 7 has face bold
- (should (eq (tp-at 7 'face) 'bold))
- ;; Check that "Hello" at position 14 has face bold
- (should (eq (tp-at 14 'face) 'bold)))))
-
-(ert-deftest tp-test-match-set-multiple-patterns-on-string ()
- "Test tp-match-set with multiple patterns on string."
- (let* ((str (copy-sequence "Hello world, Hello again"))
- (result (tp-match-set '("world" "Hello") '(face bold) str)))
- (should (stringp result))
- ;; Check that "Hello" at position 0 has face bold
- (should (eq (get-text-property 0 'face result) 'bold))
- ;; Check that "world" at position 6 has face bold
- (should (eq (get-text-property 6 'face result) 'bold))
- ;; Check that "Hello" at position 13 has face bold
- (should (eq (get-text-property 13 'face result) 'bold))))
-
-(ert-deftest tp-test-match-reset ()
- "Test tp-match-reset completely replaces properties."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (tp-set 1 6 '(help-echo "original"))
- (tp-match-reset "Hello" '(face bold))
- (should (eq (tp-at 1 'face) 'bold))
- ;; Properties should be completely replaced
- (should (null (tp-at 1 'help-echo)))))
-
-(ert-deftest tp-test-match-add ()
- "Test tp-match-add adds/updates properties."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (tp-set 1 6 '(help-echo "original"))
- (tp-match-add "Hello" '(face bold))
- (should (eq (tp-at 1 'face) 'bold))
- ;; Original properties should be preserved
- (should (equal (tp-at 1 'help-echo) "original"))))
-
-(ert-deftest tp-test-regexp-reset ()
- "Test tp-regexp-reset completely replaces properties."
- (tp-test-with-temp-buffer
- (insert "abc 123 def 456")
- (tp-set 5 8 '(help-echo "original"))
- (tp-regexp-reset "[0-9]+" '(face bold))
- (should (eq (tp-at 5 'face) 'bold))
- ;; Properties should be completely replaced
- (should (null (tp-at 5 'help-echo)))))
-
-(ert-deftest tp-test-regexp-add ()
- "Test tp-regexp-add adds/updates properties."
- (tp-test-with-temp-buffer
- (insert "abc 123 def 456")
- (tp-set 5 8 '(help-echo "original"))
- (tp-regexp-add "[0-9]+" '(face bold))
- (should (eq (tp-at 5 'face) 'bold))
- ;; Original properties should be preserved
- (should (equal (tp-at 5 'help-echo) "original"))))
-
-(ert-deftest tp-test-match-reset-on-string ()
- "Test tp-match-reset on string."
- (let* ((str (copy-sequence "Hello World Hello"))
- (result (tp-match-reset "Hello" '(face bold) str)))
- (should (eq (get-text-property 0 'face result) 'bold))
- (should (eq (get-text-property 12 'face result) 'bold))))
-
-(ert-deftest tp-test-regexp-add-on-string ()
- "Test tp-regexp-add on string.
-For strings, returns a NEW string (original is not modified)."
- (let ((str (copy-sequence "abc 123 def 456")))
- (tp-set 4 7 '(help-echo "original") str)
- (let ((result (tp-regexp-add "[0-9]+" '(face bold) str)))
- ;; Result should have both properties (face added, help-echo preserved)
- (should (eq (get-text-property 4 'face result) 'bold))
- (should (equal (get-text-property 4 'help-echo result) "original"))
- ;; Original should NOT have face property added by tp-regexp-add
- (should (null (get-text-property 4 'face str))))))
-
-(ert-deftest tp-test-match-set-string-as-last-arg ()
- "Test tp-match-set with string as last argument."
- (let ((str (copy-sequence "Hello World Hello")))
- (let ((result (tp-match-set "Hello" '(face bold) str)))
- (should (stringp result))
- (should (eq (get-text-property 0 'face result) 'bold))
- (should (eq (get-text-property 12 'face result) 'bold))
- (should (null (get-text-property 6 'face result))))))
-
-(ert-deftest tp-test-regexp-set-string-as-last-arg ()
- "Test tp-regexp-set with string as last argument."
- (let ((str (copy-sequence "abc 123 def 456")))
- (let ((result (tp-regexp-set "[0-9]+" '(face italic) str)))
- (should (stringp result))
- (should (eq (get-text-property 4 'face result) 'italic))
- (should (eq (get-text-property 12 'face result) 'italic))
- (should (null (get-text-property 0 'face result))))))
-
-(ert-deftest tp-test-regexp-set-multiple-patterns ()
- "Test tp-regexp-set with multiple patterns (list of regexps)."
- (tp-test-with-temp-buffer
- (insert "abc 123 def 456 ghi")
- ;; Match both numbers and "abc" - all should get properties applied
- (let ((regions (tp-regexp-set '("[0-9]+" "abc") '(face bold))))
- ;; Should find 3 matches: "abc", "123", "456"
- (should (= (length regions) 3))
- ;; Check that "abc" at position 1 has face bold
- (should (eq (tp-at 1 'face) 'bold))
- ;; Check that "123" at position 5 has face bold
- (should (eq (tp-at 5 'face) 'bold))
- ;; Check that "456" at position 13 has face bold
- (should (eq (tp-at 13 'face) 'bold))
- ;; Check that "def" does NOT have face bold
- (should (null (tp-at 9 'face))))))
-
-(ert-deftest tp-test-regexp-set-multiple-patterns-on-string ()
- "Test tp-regexp-set with multiple patterns on string."
- (let* ((str (copy-sequence "abc 123 def 456"))
- (result (tp-regexp-set '("[0-9]+" "abc") '(face italic) str)))
- (should (stringp result))
- ;; Check that "abc" at position 0 has face italic
- (should (eq (get-text-property 0 'face result) 'italic))
- ;; Check that "123" at position 4 has face italic
- (should (eq (get-text-property 4 'face result) 'italic))
- ;; Check that "456" at position 12 has face italic
- (should (eq (get-text-property 12 'face result) 'italic))
- ;; Check that "def" does NOT have face italic
- (should (null (get-text-property 8 'face result)))))
-
-(ert-deftest tp-test-get-range-multiple-intervals ()
- "Test tp-get returns all property intervals in a range."
- (let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-set 12 17 '(face italic) str)
- (let ((intervals (tp-get 0 17 'face str)))
- (should (= (length intervals) 2))
- (should (equal (car intervals) '(0 5 bold)))
- (should (equal (cadr intervals) '(12 17 italic))))))
-
-;;; ============================================================
-;;; New API Tests - Issue 1: tp-add face prepending
-;;; ============================================================
-
-(ert-deftest tp-test-add-face-prepend-symbol ()
- "Test tp-add prepends face symbol to existing face."
- (let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-add 0 5 '(face shadow) str)
- (let ((face (get-text-property 0 'face str)))
- ;; New face should be prepended, creating a list
- (should (equal face '(shadow bold))))))
-
-(ert-deftest tp-test-add-face-prepend-to-list ()
- "Test tp-add prepends face to existing face list."
- (let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face (bold italic)) str)
- (tp-add 0 5 '(face shadow) str)
- (let ((face (get-text-property 0 'face str)))
- ;; New face should be prepended
- (should (equal face '(shadow bold italic))))))
-
-(ert-deftest tp-test-add-face-plist-merge ()
- "Test tp-add merges face plist with existing face."
- (let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face (:foreground "red")) str)
- (tp-add 0 5 '(face (:background "blue")) str)
- (let ((face (get-text-property 0 'face str)))
- (should (equal (plist-get face :foreground) "red"))
- (should (equal (plist-get face :background) "blue")))))
-
-(ert-deftest tp-test-add-face-symbol-no-dup ()
- "Test tp-add doesn't duplicate faces."
- (let ((str (copy-sequence "Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-add 0 5 '(face bold) str)
- (let ((face (get-text-property 0 'face str)))
- ;; Should not duplicate
- (should (eq face 'bold)))))
-
-;;; ============================================================
-;;; New API Tests - Issue 2: tp-remove for strings
-;;; ============================================================
-
-(ert-deftest tp-test-remove-entire-string-single-prop ()
- "Test tp-remove removes single property from entire string."
- (let* ((str (tp-set "Hello" 'face 'bold 'help-echo "test"))
- (result (tp-remove str 'face)))
- (should (null (get-text-property 0 'face result)))
- (should (equal (get-text-property 0 'help-echo result) "test"))))
-
-(ert-deftest tp-test-remove-entire-string-multiple-props ()
- "Test tp-remove removes multiple properties from entire string."
- (let* ((str (tp-set "Hello" 'face 'bold 'help-echo "test" 'mouse-face 'highlight))
- (result (tp-remove str 'face 'help-echo)))
- (should (null (get-text-property 0 'face result)))
- (should (null (get-text-property 0 'help-echo result)))
- (should (eq (get-text-property 0 'mouse-face result) 'highlight))))
-
-(ert-deftest tp-test-remove-entire-string-sub-prop ()
- "Test tp-remove removes sub-property from entire string."
- (let* ((str (copy-sequence "Hello"))
- (_ (put-text-property 0 5 'face '(:foreground "red" :underline t) str))
- (result (tp-remove str 'face :underline)))
- (let ((face (get-text-property 0 'face result)))
- (should (equal (plist-get face :foreground) "red"))
- (should (null (plist-get face :underline))))))
-
-(ert-deftest tp-test-remove-entire-string-nested-sub-prop ()
- "Test tp-remove removes nested sub-properties from entire string."
- (let* ((str (copy-sequence "Hello"))
- (_ (put-text-property 0 5 'face '(:foreground "red" :underline (:style wave :color "blue")) str))
- (result (tp-remove str 'face :underline '(:style))))
- (let* ((face (get-text-property 0 'face result))
- (underline (plist-get face :underline)))
- (should (equal (plist-get face :foreground) "red"))
- (should (equal (plist-get underline :color) "blue"))
- (should (null (plist-get underline :style))))))
-
-(ert-deftest tp-test-remove-entire-string-single-nested-key ()
- "Test tp-remove removes a single nested key from a sub-property.
-This tests the fix for the bug where (tp-remove str 'face :underline :position)
-was removing the entire :underline instead of just :position."
- (let* ((str (tp-set "happy hacking emacs"
- 'face '(:foreground "red" :underline (:position t :color "green"))
- 'line-prefix ">> " 'other "other"))
- (result (tp-remove str 'face :underline :position)))
- (let* ((face (get-text-property 0 'face result))
- (underline (plist-get face :underline)))
- ;; :foreground should be preserved
- (should (equal (plist-get face :foreground) "red"))
- ;; :underline should still exist but without :position
- (should underline)
- (should (equal (plist-get underline :color) "green"))
- (should (null (plist-get underline :position)))
- ;; Other properties should be preserved
- (should (equal (get-text-property 0 'line-prefix result) ">> "))
- (should (equal (get-text-property 0 'other result) "other")))))
-
-;;; ============================================================
-;;; New API Tests - Issue 3 & 4: tp-get for strings and new API
-;;; ============================================================
-
-(ert-deftest tp-test-get-entire-string-all-props ()
- "Test tp-get returns all property intervals from entire string."
- (let ((str (tp-set "Hello" 'face 'bold 'help-echo "test")))
- (let ((intervals (tp-get str)))
- (should (= (length intervals) 1))
- (let ((props (caddr (car intervals))))
- (should (eq (plist-get props 'face) 'bold))
- (should (equal (plist-get props 'help-echo) "test"))))))
-
-(ert-deftest tp-test-get-entire-string-single-prop ()
- "Test tp-get returns single property intervals from entire string."
- (let ((str (tp-set "Hello" 'face 'bold 'help-echo "test")))
- (let ((face-intervals (tp-get str 'face))
- (help-intervals (tp-get str 'help-echo)))
- (should (= (length face-intervals) 1))
- (should (eq (caddr (car face-intervals)) 'bold))
- (should (= (length help-intervals) 1))
- (should (equal (caddr (car help-intervals)) "test")))))
-
-(ert-deftest tp-test-get-entire-string-nested-prop ()
- "Test tp-get returns nested property intervals from entire string."
- (let ((str (copy-sequence "Hello")))
- (put-text-property 0 5 'face '(:foreground "red" :box (:color "blue" :line-width 2)) str)
- (let ((fg-intervals (tp-get str 'face :foreground))
- (box-color-intervals (tp-get str 'face :box :color))
- (box-width-intervals (tp-get str 'face :box :line-width)))
- (should (= (length fg-intervals) 1))
- (should (equal (caddr (car fg-intervals)) "red"))
- (should (= (length box-color-intervals) 1))
- (should (equal (caddr (car box-color-intervals)) "blue"))
- (should (= (length box-width-intervals) 1))
- (should (equal (caddr (car box-width-intervals)) 2)))))
-
-(ert-deftest tp-test-get-range-with-list-prop-path ()
- "Test tp-get with property path as list.
-Returns list of (START END VALUE) intervals."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (put-text-property 1 6 'face '(:foreground "red" :underline (:style wave)) nil)
- ;; Get with list path - returns intervals
- (should (equal (tp-get 1 6 '(face)) '((1 6 (:foreground "red" :underline (:style wave))))))
- (should (equal (tp-get 1 6 '(face :foreground)) '((1 6 "red"))))
- (should (equal (tp-get 1 6 '(face :underline :style)) '((1 6 wave))))))
-
-(ert-deftest tp-test-get-range-with-list-prop-path-on-string ()
- "Test tp-get with property path as list on string.
-Returns list of (START END VALUE) intervals."
- (let ((str (copy-sequence "Hello World")))
- (put-text-property 0 5 'face '(:foreground "red" :underline (:style wave)) str)
- ;; Get with list path and object - returns intervals
- (should (equal (tp-get 0 5 '(face) str) '((0 5 (:foreground "red" :underline (:style wave))))))
- (should (equal (tp-get 0 5 '(face :foreground) str) '((0 5 "red"))))
- (should (equal (tp-get 0 5 '(face :underline :style) str) '((0 5 wave))))))
-
-(ert-deftest tp-test-get-entire-string-with-list-prop-path ()
- "Test tp-get with property path as list on entire string.
-Returns list of (START END VALUE) intervals."
- (let ((str (copy-sequence "Hello World Hello")))
- (put-text-property 0 5 'face '(:foreground "red") str)
- (put-text-property 12 17 'face '(:foreground "blue") str)
- ;; Get with list path for entire string
- (let ((intervals (tp-get str '(face :foreground))))
- (should (= (length intervals) 2))
- (should (equal (car intervals) '(0 5 "red")))
- (should (equal (cadr intervals) '(12 17 "blue"))))))
-
-(ert-deftest tp-test-get-entire-string-multiple-intervals ()
- "Test tp-get returns multiple intervals from entire string."
- (let ((str (copy-sequence "Hello World Hello")))
- (tp-set 0 5 '(face bold) str)
- (tp-set 12 17 '(face italic) str)
- (let ((intervals (tp-get str 'face)))
- (should (= (length intervals) 2))
- (should (equal (car intervals) '(0 5 bold)))
- (should (equal (cadr intervals) '(12 17 italic))))))
-
-(ert-deftest tp-test-get-deeply-nested-property ()
- "Test tp-get with deeply nested property path."
- (let ((str (copy-sequence "Hello World")))
- (put-text-property 0 5 'face '(:foreground "red" :underline (:color "green" :style wave)) str)
- (put-text-property 6 11 'face '(:foreground "blue" :underline (:color "yellow" :style line)) str)
- ;; Test deeply nested single key from entire string
- (let ((intervals (tp-get str 'face :underline :color)))
- (should (= (length intervals) 2))
- (should (equal (caddr (car intervals)) "green"))
- (should (equal (caddr (cadr intervals)) "yellow")))
- ;; Test range with deeply nested key
- (let ((intervals (tp-get 0 7 '(face :underline :color) str)))
- (should (= (length intervals) 2))
- (should (equal (caddr (car intervals)) "green")))))
-
-(ert-deftest tp-test-get-multiple-nested-keys ()
- "Test tp-get with multiple keys from nested property."
- (let ((str (copy-sequence "Hello World")))
- (put-text-property 0 5 'face '(:foreground "red" :underline (:color "green" :style wave)) str)
- (put-text-property 6 11 'face '(:foreground "blue" :underline (:color "yellow" :style line)) str)
- ;; Test extracting multiple keys from entire string
- (let ((intervals (tp-get str 'face :underline '(:color :style))))
- (should (= (length intervals) 2))
- (let ((val1 (caddr (car intervals)))
- (val2 (caddr (cadr intervals))))
- (should (equal (plist-get val1 :color) "green"))
- (should (eq (plist-get val1 :style) 'wave))
- (should (equal (plist-get val2 :color) "yellow"))
- (should (eq (plist-get val2 :style) 'line))))
- ;; Test range with multiple keys
- (let ((intervals (tp-get 0 7 '(face :underline (:color :style)) str)))
- (should (= (length intervals) 2)))))
-
-;;; ============================================================
-;;; tp-add-to-layers and tp-add-to-all-layers Tests
-;;; ============================================================
-
-(ert-deftest tp-test-add-to-layers-buffer ()
- "Test tp-add-to-layers adds properties to specified layers in buffer."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; Add help-echo to layer1 and layer3
- (tp-add-to-layers '(layer1 layer3) 1 6 '(help-echo "test"))
- ;; layer3 is on top, should have help-echo
- (should (equal (tp-at 1 'help-echo) "test"))
- ;; Check layer1 also got help-echo
- (let ((layer1-props (car (tp-region-layer-props 1 6 'layer1))))
- (should (equal (plist-get (caddr layer1-props) 'help-echo) "test")))
- ;; layer2 should NOT have help-echo
- (let ((layer2-props (car (tp-region-layer-props 1 6 'layer2))))
- (should (null (plist-get (caddr layer2-props) 'help-echo))))))
-
-(ert-deftest tp-test-add-to-layers-by-index ()
- "Test tp-add-to-layers with layer indices."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; Stack is: layer3 (0), layer2 (1), layer1 (2)
- ;; Add help-echo to indices 0 and 2 (layer3 and layer1)
- (tp-add-to-layers '(0 2) 1 6 '(help-echo "indexed"))
- ;; layer3 (top) should have help-echo
- (should (equal (tp-at 1 'help-echo) "indexed"))
- ;; Check layer1 also got help-echo
- (let ((layer1-props (car (tp-region-layer-props 1 6 'layer1))))
- (should (equal (plist-get (caddr layer1-props) 'help-echo) "indexed")))
- ;; layer2 (index 1) should NOT have help-echo
- (let ((layer2-props (car (tp-region-layer-props 1 6 'layer2))))
- (should (null (plist-get (caddr layer2-props) 'help-echo))))))
-
-(ert-deftest tp-test-add-to-layers-string ()
- "Test tp-add-to-layers works on entire string."
- (let ((str (copy-sequence "Hello")))
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer str 'layer1)
- (tp-push-layer str 'layer2)
- ;; Add help-echo to layer1
- (tp-add-to-layers '(layer1) str 'help-echo "test")
- ;; Check layer1 got help-echo
- (let ((layer1-props (car (tp-region-layer-props 0 5 'layer1 str))))
- (should (equal (plist-get (caddr layer1-props) 'help-echo) "test")))
- ;; layer2 (top) should NOT have help-echo
- (should (null (tp-at 0 'help-echo str)))))
-
-(ert-deftest tp-test-add-to-layers-deep-merge ()
- "Test tp-add-to-layers deeply merges properties."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face (:foreground "red")))
- (tp-push-layer 1 6 'layer1)
- ;; Add background to layer1 - should merge with existing face
- (tp-add-to-layers '(layer1) 1 6 '(face (:background "blue")))
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "red"))
- (should (equal (plist-get face :background) "blue")))))
-
-(ert-deftest tp-test-add-to-all-layers-buffer ()
- "Test tp-add-to-all-layers adds properties to all layers in buffer."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (define-tp layer3 () '(face underline))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- (tp-push-layer 1 6 'layer3)
- ;; Add help-echo to all layers
- (tp-add-to-all-layers 1 6 '(help-echo "all"))
- ;; layer3 (top) should have help-echo
- (should (equal (tp-at 1 'help-echo) "all"))
- ;; Check all layers got help-echo
- (let ((layer1-props (car (tp-region-layer-props 1 6 'layer1)))
- (layer2-props (car (tp-region-layer-props 1 6 'layer2)))
- (layer3-props (car (tp-region-layer-props 1 6 'layer3))))
- (should (equal (plist-get (caddr layer1-props) 'help-echo) "all"))
- (should (equal (plist-get (caddr layer2-props) 'help-echo) "all"))
- (should (equal (plist-get (caddr layer3-props) 'help-echo) "all")))))
-
-(ert-deftest tp-test-add-to-all-layers-string ()
- "Test tp-add-to-all-layers works on entire string."
- (let ((str (copy-sequence "Hello")))
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer str 'layer1)
- (tp-push-layer str 'layer2)
- ;; Add help-echo to all layers
- (tp-add-to-all-layers str 'help-echo "all")
- ;; Check all layers got help-echo
- (let ((layer1-props (car (tp-region-layer-props 0 5 'layer1 str)))
- (layer2-props (car (tp-region-layer-props 0 5 'layer2 str))))
- (should (equal (plist-get (caddr layer1-props) 'help-echo) "all"))
- (should (equal (plist-get (caddr layer2-props) 'help-echo) "all")))))
-
-(ert-deftest tp-test-add-to-all-layers-deep-merge ()
- "Test tp-add-to-all-layers deeply merges properties."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face (:foreground "red")))
- (define-tp layer2 () '(face (:foreground "blue")))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; Add background to all layers
- (tp-add-to-all-layers 1 6 '(face (:background "green")))
- ;; Top layer (layer2) should have merged face
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "blue"))
- (should (equal (plist-get face :background) "green")))
- ;; layer1 should also have merged face
- (let* ((layer1-props (car (tp-region-layer-props 1 6 'layer1)))
- (face (plist-get (caddr layer1-props) 'face)))
- (should (equal (plist-get face :foreground) "red"))
- (should (equal (plist-get face :background) "green")))))
-
-(ert-deftest tp-test-add-to-layers-negative-index ()
- "Test tp-add-to-layers with negative index (-1 means bottom)."
- (tp-test-with-temp-buffer
- (insert "Hello")
- (define-tp layer1 () '(face bold))
- (define-tp layer2 () '(face italic))
- (tp-push-layer 1 6 'layer1)
- (tp-push-layer 1 6 'layer2)
- ;; Stack is: layer2 (0), layer1 (1)
- ;; Add help-echo to index -1 (bottom = layer1)
- (tp-add-to-layers '(-1) 1 6 '(help-echo "bottom"))
- ;; layer2 (top) should NOT have help-echo
- (should (null (tp-at 1 'help-echo)))
- ;; layer1 (bottom) should have help-echo
- (let ((layer1-props (car (tp-region-layer-props 1 6 'layer1))))
- (should (equal (plist-get (caddr layer1-props) 'help-echo) "bottom")))))
-
-(ert-deftest tp-test-add-to-layers-returns-string ()
- "Test tp-add-to-layers returns the modified string."
- (let ((str (copy-sequence "Hello")))
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (define-tp layer1 () '(face bold))
- (tp-push-layer str 'layer1)
- (let ((result (tp-add-to-layers '(layer1) str 'help-echo "test")))
- (should (stringp result))
- (should (eq result str)))))
-
-(ert-deftest tp-test-add-to-all-layers-returns-string ()
- "Test tp-add-to-all-layers returns the modified string."
- (let ((str (copy-sequence "Hello")))
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (define-tp layer1 () '(face bold))
- (tp-push-layer str 'layer1)
- (let ((result (tp-add-to-all-layers str 'help-echo "test")))
- (should (stringp result))
- (should (eq result str)))))
-
-;;; ============================================================
-;;; Reactive Text Properties Tests
-;;; ============================================================
-
-(ert-deftest tp-test-reactive-symbol-p ()
- "Test tp--reactive-symbol-p detects $-prefixed symbols."
- (should (tp--reactive-symbol-p '$foo))
- (should (tp--reactive-symbol-p '$my-color))
- (should-not (tp--reactive-symbol-p 'foo))
- (should-not (tp--reactive-symbol-p "string"))
- (should-not (tp--reactive-symbol-p 42)))
-
-(ert-deftest tp-test-reactive-var-symbol ()
- "Test tp--reactive-var-symbol converts $foo to foo."
- (should (eq (tp--reactive-var-symbol '$foo) 'foo))
- (should (eq (tp--reactive-var-symbol '$my-color) 'my-color))
- (should (null (tp--reactive-var-symbol 'foo)))
- (should (null (tp--reactive-var-symbol "string"))))
-
-(ert-deftest tp-test-collect-reactive-symbols ()
- "Test tp--collect-reactive-symbols finds all $-prefixed symbols."
- (should (equal (tp--collect-reactive-symbols '$foo) '($foo)))
- (should (equal (tp--collect-reactive-symbols '(face (:foreground $color)))
- '($color)))
- (should (equal (tp--collect-reactive-symbols '(face (:foreground $color :background $bg)))
- '($color $bg)))
- (should (null (tp--collect-reactive-symbols '(face bold)))))
-
-(ert-deftest tp-test-extract-reactive-props ()
- "Test tp--extract-reactive-props extracts only properties using a reactive var."
- ;; Single reactive property
- (should (equal (tp--extract-reactive-props '(help-echo "test" face (:foreground $color)) '$color)
- '(face (:foreground $color))))
- ;; Multiple properties, only one uses the variable - should extract only reactive sub-props
- (should (equal (tp--extract-reactive-props '(help-echo "test" face (:foreground $color :background "green")) '$color)
- '(face (:foreground $color))))
- ;; Nested plist with reactive variable - should extract only reactive nested sub-props
- (should (equal (tp--extract-reactive-props
- '(face (:foreground $color1 :underline (:style wave :color $color2 :position t)))
- '$color2)
- '(face (:underline (:color $color2)))))
- ;; No properties use the variable
- (should (null (tp--extract-reactive-props '(help-echo "test" face bold) '$color))))
-
-(ert-deftest tp-test-resolve-reactive-symbols ()
- "Test tp--resolve-reactive-symbols replaces $foo with variable values."
- ;; Use defvar to create dynamically-bound variables
- (defvar tp-test-my-color "red" "Test color variable.")
- (defvar tp-test-my-bg "blue" "Test background variable.")
- (unwind-protect
- (progn
- (should (equal (tp--resolve-reactive-symbols '$tp-test-my-color) "red"))
- (should (equal (tp--resolve-reactive-symbols '(face (:foreground $tp-test-my-color)))
- '(face (:foreground "red"))))
- (should (equal (tp--resolve-reactive-symbols '(face (:foreground $tp-test-my-color :background $tp-test-my-bg)))
- '(face (:foreground "red" :background "blue")))))
- ;; Cleanup
- (makunbound 'tp-test-my-color)
- (makunbound 'tp-test-my-bg)))
-
-(ert-deftest tp-test-define-layer-with-reactive ()
- "Test define-tp with reactive variables."
- (tp-test-with-temp-buffer
- (defvar tp-test-var-color "red" "Test color variable.")
- (unwind-protect
- (progn
- (define-tp test-reactive-layer () '(face (:foreground $tp-test-var-color)))
- ;; Check the layer is defined with resolved value
- (let ((props (cdr (assoc 'test-reactive-layer tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :foreground) "red")))
- ;; Check the dependency is registered with only reactive props
- (should (assoc 'tp-test-var-color tp-reactive-deps))
- ;; Check the stored reactive props only contain the face property
- (let* ((deps (cdr (assoc 'tp-test-var-color tp-reactive-deps)))
- (layer-dep (assoc 'test-reactive-layer deps)))
- (should layer-dep)
- ;; The stored props should be just the reactive portion
- (should (plist-get (cdr layer-dep) 'face))))
- ;; Cleanup
- (makunbound 'tp-test-var-color))))
-
-(ert-deftest tp-test-reactive-update-on-variable-change ()
- "Test that changing a reactive variable updates the layer."
- (tp-test-with-temp-buffer
- (defvar tp-test-reactive-color nil "Test variable for reactive properties.")
- (setq tp-test-reactive-color "red")
- (unwind-protect
- (progn
- (define-tp test-reactive-update () '(face (:foreground $tp-test-reactive-color)))
- ;; Verify initial value
- (let ((props (cdr (assoc 'test-reactive-update tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :foreground) "red")))
- ;; Change the variable
- (setq tp-test-reactive-color "blue")
- ;; Verify the layer definition is updated
- (let ((props (cdr (assoc 'test-reactive-update tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :foreground) "blue"))))
- ;; Cleanup
- (makunbound 'tp-test-reactive-color))))
-
-(ert-deftest tp-test-reactive-update-text-regions ()
- "Test that changing a reactive variable updates applied text regions."
- (tp-test-with-temp-buffer
- (defvar tp-test-region-color nil "Test variable for reactive regions.")
- (setq tp-test-region-color "red")
- (unwind-protect
- (progn
- (define-tp test-reactive-region () '(face (:foreground $tp-test-region-color)))
- (insert "Hello World")
- ;; Apply the layer to text
- (tp-push-layer 1 6 'test-reactive-region)
- ;; Verify initial properties
- (should (equal (plist-get (tp-at 1 'face) :foreground) "red"))
- ;; Change the variable
- (setq tp-test-region-color "green")
- ;; Verify the text is updated
- (should (equal (plist-get (tp-at 1 'face) :foreground) "green")))
- ;; Cleanup
- (makunbound 'tp-test-region-color))))
-
-(ert-deftest tp-test-reactive-reset ()
- "Test tp-reactive-reset clears all reactive dependencies."
- (tp-test-with-temp-buffer
- (defvar tp-test-reset-color nil "Test variable for reactive reset.")
- (setq tp-test-reset-color "red")
- (unwind-protect
- (progn
- (define-tp test-reactive-reset () '(face (:foreground $tp-test-reset-color)))
- (should tp-reactive-deps)
- (tp-reactive-reset)
- (should-not tp-reactive-deps))
- ;; Cleanup
- (makunbound 'tp-test-reset-color))))
-
-(ert-deftest tp-test-layer-reset-clears-reactive ()
- "Test tp-layer-reset also clears reactive dependencies."
- (tp-test-with-temp-buffer
- (defvar tp-test-reset2-color nil "Test variable for layer reset.")
- (setq tp-test-reset2-color "red")
- (unwind-protect
- (progn
- (define-tp test-reactive-reset2 () '(face (:foreground $tp-test-reset2-color)))
- (should tp-reactive-deps)
- (tp-layer-reset)
- (should-not tp-reactive-deps))
- ;; Cleanup
- (makunbound 'tp-test-reset2-color))))
-
-(ert-deftest tp-test-define-layer-group-with-reactive ()
- "Test define-tps with reactive variables."
- (tp-test-with-temp-buffer
- (defvar tp-test-group-color nil "Test variable for layer group.")
- (setq tp-test-group-color "red")
- (unwind-protect
- (progn
- (define-tps test-reactive-group ()
- '("first" :props (face (:foreground $tp-test-group-color)))
- '("second" :props (face (:foreground "blue"))))
- ;; Check the reactive layer is defined with resolved value
- (let ((props (cdr (assoc 'test-reactive-group-first tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :foreground) "red")))
- ;; Check the non-reactive layer is defined
- (let ((props (cdr (assoc 'test-reactive-group-second tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :foreground) "blue")))
- ;; Check the reactive layer is registered in tp-reactive-deps
- (should (assoc 'tp-test-group-color tp-reactive-deps))
- ;; The reactive layer should be in the dependencies
- (let* ((deps (cdr (assoc 'tp-test-group-color tp-reactive-deps)))
- (layer-dep (assoc 'test-reactive-group-first deps)))
- (should layer-dep)))
- ;; Cleanup
- (makunbound 'tp-test-group-color))))
-
-(ert-deftest tp-test-undefine-layer-clears-reactive ()
- "Test tp-undefine-layer clears reactive dependencies for that layer."
- (tp-test-with-temp-buffer
- (defvar tp-test-undef-color nil "Test variable for undefine.")
- (setq tp-test-undef-color "red")
- (unwind-protect
- (progn
- (define-tp test-undef-reactive () '(face (:foreground $tp-test-undef-color)))
- ;; Check the dependency is registered
- (should (assoc 'tp-test-undef-color tp-reactive-deps))
- (let* ((deps (cdr (assoc 'tp-test-undef-color tp-reactive-deps)))
- (layer-dep (assoc 'test-undef-reactive deps)))
- (should layer-dep))
- (tp-undefine-layer 'test-undef-reactive)
- ;; Dependency should be cleaned up if no other layers use it
- (should-not (cdr (assoc 'tp-test-undef-color tp-reactive-deps))))
- ;; Cleanup
- (makunbound 'tp-test-undef-color))))
-
-;;; ============================================================
-;;; Layer Name in Property-Setting APIs Tests
-;;; ============================================================
-
-(ert-deftest tp-test-set-with-layer-name ()
- "Test tp-set accepts a layer name defined by define-tp.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (define-tp my-style () '(face bold help-echo "tip"))
- ;; Use layer name instead of plist
- (tp-set 1 6 'my-style)
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "tip"))
- ;; tp-name should NOT be set for direct property setting
- (should-not (tp-at 1 'tp-name))))
-
-(ert-deftest tp-test-set-with-layer-name-on-string ()
- "Test tp-set accepts a layer name on string.
-When using tp-set (direct property setting), tp-name is NOT added."
- (let ((str (copy-sequence "Hello World")))
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (define-tp my-style () '(face italic))
- (tp-set 0 5 'my-style str)
- (should (eq (get-text-property 0 'face str) 'italic))
- ;; tp-name should NOT be set for direct property setting
- (should-not (get-text-property 0 'tp-name str))))
-
-(ert-deftest tp-test-set-entire-string-with-layer-name ()
- "Test tp-set with layer name on entire string (string form).
-This tests the fix for the bug where (tp-set str 'layer-name) would
-incorrectly generate an anonymous tp-name instead of using the layer name."
- (tp-test-with-temp-buffer
- ;; Define a layer with reactive variables
- (define-tp my-entire-string-layer () :props '(face (:background $my-entire-string-color))
- :data '((my-entire-string-color . "blue")))
- (let ((str (tp-set " " 'my-entire-string-layer)))
- ;; tp-name should be the defined layer name, not an anonymous tp-anon-X
- (should (eq (get-text-property 0 'tp-name str) 'my-entire-string-layer))
- ;; face should be correctly set
- (should (equal (plist-get (get-text-property 0 'face str) :background) "blue")))))
-
-(ert-deftest tp-test-reset-with-layer-name ()
- "Test tp-reset accepts a layer name defined by define-tp.
-When using tp-reset (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(mouse-face highlight))
- (define-tp my-style () '(face underline))
- ;; Use layer name - should completely replace
- (tp-reset 1 6 'my-style)
- (should (eq (tp-at 1 'face) 'underline))
- (should (null (tp-at 1 'mouse-face)))
- ;; tp-name should NOT be set for direct property setting
- (should-not (tp-at 1 'tp-name))))
-
-(ert-deftest tp-test-add-with-layer-name ()
- "Test tp-add accepts a layer name defined by define-tp.
-When using tp-add (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(help-echo "existing"))
- (define-tp my-style () '(face bold))
- ;; Use layer name - should preserve existing properties
- (tp-add 1 6 'my-style)
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "existing"))
- ;; tp-name should NOT be set for direct property setting
- (should-not (tp-at 1 'tp-name))))
-
-(ert-deftest tp-test-match-set-with-layer-name ()
- "Test tp-match-set accepts a layer name.
-When using tp-match-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (define-tp match-style () '(face bold help-echo "matched"))
- (tp-match-set "Hello" 'match-style)
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "matched"))
- (should (eq (tp-at 13 'face) 'bold))
- ;; tp-name should NOT be set for direct property setting
- (should-not (tp-at 1 'tp-name))))
-
-(ert-deftest tp-test-match-set-with-layer-name-on-string ()
- "Test tp-match-set accepts a layer name on string.
-When using tp-match-set (direct property setting), tp-name is NOT added.
-For strings, returns a NEW string (original is not modified)."
- (let ((str (copy-sequence "Hello World Hello")))
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (define-tp match-style () '(face italic))
- (let ((result (tp-match-set "Hello" 'match-style str)))
- ;; Result should have the properties
- (should (eq (get-text-property 0 'face result) 'italic))
- (should (eq (get-text-property 12 'face result) 'italic))
- ;; tp-name should NOT be set for direct property setting
- (should-not (get-text-property 0 'tp-name result))
- ;; Original should NOT be modified
- (should (null (get-text-property 0 'face str))))))
-
-(ert-deftest tp-test-match-reset-with-layer-name ()
- "Test tp-match-reset accepts a layer name."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (tp-set 1 6 '(mouse-face highlight))
- (define-tp match-style () '(face bold))
- (tp-match-reset "Hello" 'match-style)
- (should (eq (tp-at 1 'face) 'bold))
- (should (null (tp-at 1 'mouse-face)))))
-
-(ert-deftest tp-test-match-add-with-layer-name ()
- "Test tp-match-add accepts a layer name."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (tp-set 1 6 '(help-echo "original"))
- (define-tp match-style () '(face bold))
- (tp-match-add "Hello" 'match-style)
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "original"))))
-
-(ert-deftest tp-test-regexp-set-with-layer-name ()
- "Test tp-regexp-set accepts a layer name."
- (tp-test-with-temp-buffer
- (insert "abc 123 def 456")
- (define-tp number-style () '(face bold help-echo "number"))
- (tp-regexp-set "[0-9]+" 'number-style)
- (should (eq (tp-at 5 'face) 'bold))
- (should (equal (tp-at 5 'help-echo) "number"))
- (should (eq (tp-at 13 'face) 'bold))))
-
-(ert-deftest tp-test-regexp-set-with-layer-name-on-string ()
- "Test tp-regexp-set accepts a layer name on string.
-For strings, returns a NEW string (original is not modified)."
- (let ((str (copy-sequence "abc 123 def 456")))
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (define-tp number-style () '(face italic))
- (let ((result (tp-regexp-set "[0-9]+" 'number-style str)))
- ;; Result should have the properties
- (should (eq (get-text-property 4 'face result) 'italic))
- (should (eq (get-text-property 12 'face result) 'italic))
- ;; Original should NOT be modified
- (should (null (get-text-property 4 'face str))))))
-
-(ert-deftest tp-test-regexp-reset-with-layer-name ()
- "Test tp-regexp-reset accepts a layer name."
- (tp-test-with-temp-buffer
- (insert "abc 123 def 456")
- (tp-set 5 8 '(mouse-face highlight))
- (define-tp number-style () '(face bold))
- (tp-regexp-reset "[0-9]+" 'number-style)
- (should (eq (tp-at 5 'face) 'bold))
- (should (null (tp-at 5 'mouse-face)))))
-
-(ert-deftest tp-test-regexp-add-with-layer-name ()
- "Test tp-regexp-add accepts a layer name.
-When using tp-regexp-add (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (insert "abc 123 def 456")
- (tp-set 5 8 '(help-echo "original"))
- (define-tp number-style () '(face bold))
- (tp-regexp-add "[0-9]+" 'number-style)
- (should (eq (tp-at 5 'face) 'bold))
- (should (equal (tp-at 5 'help-echo) "original"))
- ;; tp-name should NOT be set for direct property setting
- (should-not (tp-at 5 'tp-name))))
-
-(ert-deftest tp-test-set-with-group-name ()
- "Test tp-set accepts a group name defined by define-tps.
-When using tp-set with a group, layers are set with tp-name and tp-layers."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (define-tps my-group ()
- '("style" . (face bold help-echo "grouped")))
- ;; Use group name
- (tp-set 1 6 'my-group)
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "grouped"))
- ;; tp-name should be set for layer groups
- (should (tp-at 1 'tp-name))))
-
-(ert-deftest tp-test-set-with-group-name-multiple-layers ()
- "Test tp-set with group containing multiple layers.
-When using tp-set with a group, all layers are set with tp-name and tp-layers."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (define-tps my-group ()
- '("first" . (face bold))
- '("second" . (face italic)))
- ;; Use group name - all layers are applied with tp-layers structure
- (tp-set 1 6 'my-group)
- ;; First layer's properties are applied at top
- (should (eq (tp-at 1 'face) 'bold))
- ;; tp-name should be set for the top layer
- (should (tp-at 1 'tp-name))
- ;; tp-layers should contain the rest of the layers
- (should (tp-at 1 'tp-layers))))
-
-(ert-deftest tp-test-match-set-with-group-name ()
- "Test tp-match-set accepts a group name.
-When using tp-match-set with a group, layers are set with tp-name."
- (tp-test-with-temp-buffer
- (insert "Hello World Hello")
- (define-tps my-group ()
- '("style" . (face italic)))
- (tp-match-set "Hello" 'my-group)
- (should (eq (tp-at 1 'face) 'italic))
- (should (eq (tp-at 13 'face) 'italic))
- ;; tp-name should be set for layer groups
- (should (tp-at 1 'tp-name))))
-
-(ert-deftest tp-test-resolve-props-returns-nil-for-unknown ()
- "Test tp--resolve-props returns nil for unknown layer name."
- (tp-test-with-temp-buffer
- (should (null (tp--resolve-props 'unknown-layer-name)))))
-
-(ert-deftest tp-test-set-with-complex-layer ()
- "Test tp-set with layer containing complex nested properties."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (define-tp complex-layer ()
- '(face (:foreground "red" :underline (:style wave))
- help-echo "complex"))
- (tp-set 1 6 'complex-layer)
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "red"))
- (should (equal (plist-get (plist-get face :underline) :style) 'wave)))
- (should (equal (tp-at 1 'help-echo) "complex"))))
-
-;;; ============================================================
-;;; Anonymous Layer and Reactive Text Property Tests
-;;; ============================================================
-
-(ert-deftest tp-test-set-anonymous-layer-no-tp-name-for-non-reactive ()
- "Test that tp-set with non-reactive plist does NOT get tp-name.
-Per requirement 1: non-reactive properties should not have tp-name added,
-preserving the native text property behavior."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold))
- ;; Non-reactive anonymous layer should NOT have tp-name
- (should-not (tp-at 1 'tp-name))
- ;; But the face property should still be set
- (should (eq (tp-at 1 'face) 'bold))))
-
-(ert-deftest tp-test-set-anonymous-reactive-layer ()
- "Test that tp-set with anonymous reactive plist works."
- (tp-test-with-temp-buffer
- (defvar tp-test-anon-color nil "Test variable for anonymous reactive layer.")
- (setq tp-test-anon-color "red")
- (unwind-protect
- (progn
- (insert "Hello World")
- ;; Set with anonymous reactive plist
- (tp-set 1 6 '(face (:foreground $tp-test-anon-color)))
- ;; Should have resolved the reactive variable
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "red")))
- ;; Should have a generated tp-name
- (should (tp-at 1 'tp-name))
- ;; The reactive variable should be registered in dependencies
- (should (assoc 'tp-test-anon-color tp-reactive-deps))
- ;; Change the variable - should update the text
- (setq tp-test-anon-color "blue")
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "blue"))))
- ;; Cleanup
- (makunbound 'tp-test-anon-color))))
-
-(ert-deftest tp-test-set-anonymous-layer-preserves-existing-tp-name ()
- "Test that tp-set with anonymous plist preserves existing tp-name property."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- ;; First set with a layer name - this does NOT set tp-name
- (define-tp my-existing-layer () '(face bold))
- (tp-set 1 6 'my-existing-layer)
- (should-not (tp-at 1 'tp-name)) ; no tp-name for direct setting
- ;; Now set with anonymous plist that has explicit tp-name
- (tp-set 1 6 '(face italic tp-name my-custom-name))
- ;; Explicit tp-name in plist should be preserved
- (should (eq (tp-at 1 'tp-name) 'my-custom-name))))
-
-(ert-deftest tp-test-match-set-anonymous-reactive-layer ()
- "Test that tp-match-set with anonymous reactive plist works."
- (tp-test-with-temp-buffer
- (defvar tp-test-match-color nil "Test variable for match reactive layer.")
- (setq tp-test-match-color "green")
- (unwind-protect
- (progn
- (insert "Hello World Hello")
- ;; Set with anonymous reactive plist
- (tp-match-set "Hello" '(face (:foreground $tp-test-match-color)))
- ;; Should have resolved the reactive variable
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "green")))
- ;; Should have a generated tp-name
- (should (tp-at 1 'tp-name))
- ;; Change the variable - should update the text
- (setq tp-test-match-color "yellow")
- (let ((face (tp-at 1 'face)))
- (should (equal (plist-get face :foreground) "yellow"))))
- ;; Cleanup
- (makunbound 'tp-test-match-color))))
-
-(ert-deftest tp-test-regexp-set-anonymous-reactive-layer ()
- "Test that tp-regexp-set with anonymous reactive plist works."
- (tp-test-with-temp-buffer
- (defvar tp-test-regexp-color nil "Test variable for regexp reactive layer.")
- (setq tp-test-regexp-color "purple")
- (unwind-protect
- (progn
- (insert "abc 123 def 456")
- ;; Set with anonymous reactive plist
- (tp-regexp-set "[0-9]+" '(face (:foreground $tp-test-regexp-color)))
- ;; Should have resolved the reactive variable
- (let ((face (tp-at 5 'face)))
- (should (equal (plist-get face :foreground) "purple")))
- ;; Should have a generated tp-name
- (should (tp-at 5 'tp-name))
- ;; Change the variable - should update the text
- (setq tp-test-regexp-color "orange")
- (let ((face (tp-at 5 'face)))
- (should (equal (plist-get face :foreground) "orange"))))
- ;; Cleanup
- (makunbound 'tp-test-regexp-color))))
-
-;;; ============================================================
-;;; :watch, :data, and :compute Tests (Vue 3 style reactivity)
-;;; ============================================================
-
-(ert-deftest tp-test-define-layer-with-watch ()
- "Test reactive layers with :watch for side effects."
- (tp-test-with-temp-buffer
- (defvar tp-test-watch-var nil "Test variable for watch.")
- (defvar tp-test-watch-log nil "Log of watch callback invocations.")
- (setq tp-test-watch-var "initial")
- (setq tp-test-watch-log nil)
- (unwind-protect
- (progn
- (define-tp test-watch-layer () :props '(face (:foreground $tp-test-watch-var))
- :watch '((tp-test-watch-var
- (lambda (new old layer)
- (push (list new old layer) tp-test-watch-log)))))
- ;; Check the layer is defined with resolved value
- (let ((props (cdr (assoc 'test-watch-layer tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :foreground) "initial")))
- ;; Check the watcher is registered
- (should (assoc 'test-watch-layer tp-layer-watchers))
- ;; Change the variable
- (setq tp-test-watch-var "changed")
- ;; Check the layer is updated
- (let ((props (cdr (assoc 'test-watch-layer tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :foreground) "changed")))
- ;; Check the watcher was called
- (should (= (length tp-test-watch-log) 1))
- (let ((log-entry (car tp-test-watch-log)))
- (should (equal (nth 0 log-entry) "changed"))
- (should (equal (nth 1 log-entry) "initial"))
- (should (eq (nth 2 log-entry) 'test-watch-layer))))
- ;; Cleanup
- (makunbound 'tp-test-watch-var)
- (makunbound 'tp-test-watch-log))))
-
-(ert-deftest tp-test-define-layer-with-data ()
- "Test reactive layers with :data for additional reactive variables."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- (define-tp test-data-layer () :props '(face (:foreground $tp-test-data-color))
- :data '(tp-test-data-extra))
- ;; Check that variables were auto-defined
- (should (boundp 'tp-test-data-color))
- (should (boundp 'tp-test-data-extra))
- ;; Check data is registered
- (should (assoc 'test-data-layer tp-layer-data))
- ;; Check the layer is defined
- (should (assoc 'test-data-layer tp-layer-alist)))
- ;; Cleanup
- (makunbound 'tp-test-data-color)
- (makunbound 'tp-test-data-extra))))
-
-(ert-deftest tp-test-define-layer-with-compute ()
- "Test reactive layers with :compute for computed reactive variables."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Set up the source variables
- (setq tp-test-first-name "John")
- (setq tp-test-last-name "Doe")
- (define-tp test-compute-layer ()
- :props '(help-echo $tp-test-full-name)
- :data '(tp-test-first-name tp-test-last-name)
- :compute '((tp-test-full-name
- (lambda ()
- (concat tp-test-first-name " " tp-test-last-name)))))
- ;; Check the layer is defined
- (should (assoc 'test-compute-layer tp-layer-alist))
- ;; Check the computed is registered
- (should (assoc 'test-compute-layer tp-layer-computed))
- ;; Check the computed variable has initial value
- (should (equal tp-test-full-name "John Doe"))
- ;; Check the layer property uses the computed value
- (let ((props (cdr (assoc 'test-compute-layer tp-layer-alist))))
- (should (equal (plist-get props 'help-echo) "John Doe"))))
- ;; Cleanup
- (makunbound 'tp-test-first-name)
- (makunbound 'tp-test-last-name)
- (makunbound 'tp-test-full-name))))
-
-(ert-deftest tp-test-define-layer-with-data-and-compute ()
- "Test reactive layers with :data and :compute together."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Set data values first
- (setq tp-test-dc-color "blue")
- (setq tp-test-dc-first "Jane")
- (setq tp-test-dc-last "Smith")
- ;; Define layer with :data and :compute
- (define-tp test-dc-layer ()
- :props '(face (:foreground $tp-test-dc-color) help-echo $tp-test-dc-full-name)
- :data '(tp-test-dc-first tp-test-dc-last)
- :compute '((tp-test-dc-full-name
- (lambda ()
- (concat tp-test-dc-first " " tp-test-dc-last)))))
- ;; Check data is registered
- (should (assoc 'test-dc-layer tp-layer-data))
- ;; Check computed is registered
- (should (assoc 'test-dc-layer tp-layer-computed))
- ;; Check the computed value
- (should (equal tp-test-dc-full-name "Jane Smith")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-dc-color))
- (ignore-errors (makunbound 'tp-test-dc-first))
- (ignore-errors (makunbound 'tp-test-dc-last))
- (ignore-errors (makunbound 'tp-test-dc-full-name)))))
-
-(ert-deftest tp-test-define-layer-watch-requires-props ()
- "Test that :watch requires :props to be explicitly specified."
- (tp-test-with-temp-buffer
- (should-error
- (define-tp test-invalid ()
- :watch '((some-var (lambda (new old layer) nil)))))))
-
-(ert-deftest tp-test-define-layer-compute-requires-props ()
- "Test that :compute requires :props to be explicitly specified."
- (tp-test-with-temp-buffer
- (should-error
- (define-tp test-invalid ()
- :compute '((some-var (lambda () "computed")))))))
-
-(ert-deftest tp-test-define-layer-data-requires-props ()
- "Test that :data requires :props to be explicitly specified."
- (tp-test-with-temp-buffer
- (should-error
- (define-tp test-invalid ()
- :data '(some-var)))))
-
-(ert-deftest tp-test-undefine-layer-clears-watch-compute-data ()
- "Test tp-undefine-layer clears watchers, computed, and data."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- (define-tp test-undef-wcd ()
- :props '(face (:foreground $tp-test-undef-color) help-echo $tp-test-undef-full)
- :data '(tp-test-undef-first tp-test-undef-last)
- :watch '((tp-test-undef-color (lambda (n o l) nil)))
- :compute '((tp-test-undef-full
- (lambda ()
- (concat tp-test-undef-first " " tp-test-undef-last)))))
- ;; Check registrations
- (should (assoc 'test-undef-wcd tp-layer-watchers))
- (should (assoc 'test-undef-wcd tp-layer-computed))
- (should (assoc 'test-undef-wcd tp-layer-data))
- ;; Undefine the layer
- (tp-undefine-layer 'test-undef-wcd)
- ;; Check all are cleaned up
- (should-not (assoc 'test-undef-wcd tp-layer-watchers))
- (should-not (assoc 'test-undef-wcd tp-layer-computed))
- (should-not (assoc 'test-undef-wcd tp-layer-data)))
- ;; Cleanup
- (makunbound 'tp-test-undef-color)
- (makunbound 'tp-test-undef-first)
- (makunbound 'tp-test-undef-last)
- (makunbound 'tp-test-undef-full))))
-
-(ert-deftest tp-test-define-layer-group-with-watch ()
- "Test define-tps with :watch (format-4)."
- (tp-test-with-temp-buffer
- (defvar tp-test-group-watch-var nil "Test variable for group watch.")
- (defvar tp-test-group-watch-log nil "Log of watch callback invocations.")
- (setq tp-test-group-watch-var "red")
- (setq tp-test-group-watch-log nil)
- (unwind-protect
- (progn
- (define-tps test-watch-group ()
- '("reactive" :props (face (:foreground $tp-test-group-watch-var))
- :watch ((tp-test-group-watch-var
- (lambda (new old layer)
- (push (list new old layer) tp-test-group-watch-log)))))
- '("static" :props (face (:foreground "blue"))))
- ;; Check the group is defined
- (should (assoc 'test-watch-group tp-layer-groups))
- ;; Check the reactive layer has its watcher registered
- (should (assoc 'test-watch-group-reactive tp-layer-watchers))
- ;; Static layer should not have a watcher
- (should-not (assoc 'test-watch-group-static tp-layer-watchers))
- ;; Change the variable
- (setq tp-test-group-watch-var "green")
- ;; Check the watcher was called
- (should (= (length tp-test-group-watch-log) 1)))
- ;; Cleanup
- (makunbound 'tp-test-group-watch-var)
- (makunbound 'tp-test-group-watch-log))))
-
-(ert-deftest tp-test-reactive-reset-clears-all ()
- "Test tp-reactive-reset clears watchers, computed, and data."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- (define-tp test-reset-all ()
- :props '(face (:foreground $tp-test-reset-color) help-echo $tp-test-reset-full)
- :data '(tp-test-reset-first tp-test-reset-last)
- :watch '((tp-test-reset-color (lambda (n o l) nil)))
- :compute '((tp-test-reset-full
- (lambda ()
- (concat tp-test-reset-first " " tp-test-reset-last)))))
- ;; Check registrations
- (should tp-layer-watchers)
- (should tp-layer-computed)
- (should tp-layer-data)
- ;; Reset reactive
- (tp-reactive-reset)
- ;; Check all are cleared
- (should-not tp-layer-watchers)
- (should-not tp-layer-computed)
- (should-not tp-layer-data))
- ;; Cleanup - variables may or may not be bound
- (ignore-errors (makunbound 'tp-test-reset-color))
- (ignore-errors (makunbound 'tp-test-reset-first))
- (ignore-errors (makunbound 'tp-test-reset-last))
- (ignore-errors (makunbound 'tp-test-reset-full)))))
-
-(ert-deftest tp-test-auto-define-variables ()
- "Test that reactive variables are auto-defined when not bound."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Variables should not exist before
- (should-not (boundp 'tp-test-auto-var1))
- (should-not (boundp 'tp-test-auto-var2))
- (define-tp test-auto-layer () :props '(face (:foreground $tp-test-auto-var1))
- :data '(tp-test-auto-var2))
- ;; Variables should now exist
- (should (boundp 'tp-test-auto-var1))
- (should (boundp 'tp-test-auto-var2)))
- ;; Cleanup
- (makunbound 'tp-test-auto-var1)
- (makunbound 'tp-test-auto-var2))))
-
-(ert-deftest tp-test-setq-local-triggers-update ()
- "Test that setq-local triggers reactive updates correctly."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Define layer with auto-created variable (nil initial value)
- (define-tp test-local-layer () :props '(face (:foreground $tp-test-local-color)))
- ;; Apply layer to text
- (insert "Hello World")
- (tp-set 1 6 'test-local-layer)
- ;; Initial value should be nil
- (should (equal (plist-get (get-text-property 1 'face) :foreground) nil))
- ;; Use setq-local to set the value
- (setq-local tp-test-local-color "red")
- ;; Text property should be updated
- (should (equal (plist-get (get-text-property 1 'face) :foreground) "red")))
- ;; Cleanup
- (makunbound 'tp-test-local-color))))
-
-(ert-deftest tp-test-data-setq-local-triggers-compute ()
- "Test that setq-local on :data variables triggers computed value updates."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Define layer with :data and :compute
- (define-tp test-data-compute-layer ()
- :props '(help-echo $tp-test-dc-full)
- :data '(tp-test-dc-first tp-test-dc-last)
- :compute '((tp-test-dc-full
- (lambda ()
- (concat tp-test-dc-first " " tp-test-dc-last)))))
- ;; Apply layer to text
- (insert "Hello World")
- (tp-set 1 6 'test-data-compute-layer)
- ;; Initial computed value should be " " (concat nil nil = " ")
- (should (equal (get-text-property 1 'help-echo) " "))
- ;; Use setq-local to set first name
- (setq-local tp-test-dc-first "Kinney")
- ;; Computed should be "Kinney " now
- (should (equal (get-text-property 1 'help-echo) "Kinney "))
- ;; Use setq-local to set last name
- (setq-local tp-test-dc-last "Zhang")
- ;; Computed should be "Kinney Zhang" now
- (should (equal (get-text-property 1 'help-echo) "Kinney Zhang")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-dc-first))
- (ignore-errors (makunbound 'tp-test-dc-last))
- (ignore-errors (makunbound 'tp-test-dc-full)))))
-
-(ert-deftest tp-test-data-with-initial-values ()
- "Test that :data supports initial values with cons cell format."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Define layer with :data having initial values
- (define-tp test-data-init-layer ()
- :props '(face (:foreground $tp-test-init-color) help-echo $tp-test-init-name)
- :data '((tp-test-init-color . "blue")
- (tp-test-init-name . "Initial Name")
- tp-test-init-other))
- ;; Check initial values
- (should (equal tp-test-init-color "blue"))
- (should (equal tp-test-init-name "Initial Name"))
- (should (equal tp-test-init-other nil))
- ;; Apply layer to text
- (insert "Hello World")
- (tp-set 1 6 'test-data-init-layer)
- ;; Check text properties have initial values
- (should (equal (plist-get (get-text-property 1 'face) :foreground) "blue"))
- (should (equal (get-text-property 1 'help-echo) "Initial Name")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-init-color))
- (ignore-errors (makunbound 'tp-test-init-name))
- (ignore-errors (makunbound 'tp-test-init-other)))))
-
-(ert-deftest tp-test-setq-local-only-updates-current-buffer ()
- "Test that setq-local only updates text properties in the current buffer."
- (let ((buf1 nil)
- (buf2 nil))
- (unwind-protect
- (progn
- ;; Define a reactive layer
- (define-tp test-multi-buf-layer () :props '(face (:foreground $tp-test-multi-color)))
- ;; Create first buffer with layer applied
- (setq buf1 (generate-new-buffer " *test-buf1*"))
- (with-current-buffer buf1
- (insert "Hello World")
- (tp-set 1 6 'test-multi-buf-layer))
- ;; Create second buffer with layer applied
- (setq buf2 (generate-new-buffer " *test-buf2*"))
- (with-current-buffer buf2
- (insert "Hello World")
- (tp-set 1 6 'test-multi-buf-layer))
- ;; Use setq-local in buf1
- (with-current-buffer buf1
- (setq-local tp-test-multi-color "red"))
- ;; buf1 should be updated
- (with-current-buffer buf1
- (should (equal (plist-get (get-text-property 1 'face) :foreground) "red")))
- ;; buf2 should NOT be updated (still nil)
- (with-current-buffer buf2
- (should (equal (plist-get (get-text-property 1 'face) :foreground) nil))))
- ;; Cleanup
- (when (buffer-live-p buf1) (kill-buffer buf1))
- (when (buffer-live-p buf2) (kill-buffer buf2))
- (ignore-errors (makunbound 'tp-test-multi-color)))))
-
-(ert-deftest tp-test-setq-updates-all-buffers-with-property ()
- "Test that setq updates text properties in all buffers that have the property."
- (let ((buf1 nil)
- (buf2 nil))
- (unwind-protect
- (progn
- ;; Define a reactive layer
- (define-tp test-global-layer () :props '(face (:foreground $tp-test-global-color)))
- ;; Create first buffer with layer applied
- (setq buf1 (generate-new-buffer " *test-buf1*"))
- (with-current-buffer buf1
- (insert "Hello World")
- (tp-set 1 6 'test-global-layer))
- ;; Create second buffer with layer applied
- (setq buf2 (generate-new-buffer " *test-buf2*"))
- (with-current-buffer buf2
- (insert "Hello World")
- (tp-set 1 6 'test-global-layer))
- ;; Use global setq
- (setq tp-test-global-color "blue")
- ;; Both buffers should be updated
- (with-current-buffer buf1
- (should (equal (plist-get (get-text-property 1 'face) :foreground) "blue")))
- (with-current-buffer buf2
- (should (equal (plist-get (get-text-property 1 'face) :foreground) "blue"))))
- ;; Cleanup
- (when (buffer-live-p buf1) (kill-buffer buf1))
- (when (buffer-live-p buf2) (kill-buffer buf2))
- (ignore-errors (makunbound 'tp-test-global-color)))))
-
-;;; ============================================================
-;;; Re-definition Tests (Issue: define-tp should update all properties on re-execution)
-;;; ============================================================
-
-(ert-deftest tp-test-redefine-layer-updates-data-initial-values ()
- "Test that re-defining a layer with different :data initial values updates the variable."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; First definition with gray color
- (define-tp test-redef-layer () :props '(face (:background $tp-test-redef-color))
- :data '((tp-test-redef-color . "gray")))
- ;; Check initial value
- (should (equal tp-test-redef-color "gray"))
- ;; Check layer props
- (let ((props (cdr (assoc 'test-redef-layer tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :background) "gray")))
- ;; Re-define with different color
- (define-tp test-redef-layer () :props '(face (:background $tp-test-redef-color))
- :data '((tp-test-redef-color . "blue")))
- ;; Check variable is updated
- (should (equal tp-test-redef-color "blue"))
- ;; Check layer props are updated
- (let ((props (cdr (assoc 'test-redef-layer tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :background) "blue"))))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-redef-color)))))
-
-(ert-deftest tp-test-redefine-layer-updates-props ()
- "Test that re-defining a layer updates :props correctly."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; First definition
- (define-tp test-redef-props () :props '(face (:foreground $tp-test-redef-fg))
- :data '((tp-test-redef-fg . "red")))
- (let ((props (cdr (assoc 'test-redef-props tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :foreground) "red")))
- ;; Re-define with different props structure
- (define-tp test-redef-props ()
- :props '(face (:background $tp-test-redef-bg) help-echo "new")
- :data '((tp-test-redef-bg . "yellow")))
- ;; Check new props are applied
- (let ((props (cdr (assoc 'test-redef-props tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :background) "yellow"))
- (should (equal (plist-get props 'help-echo) "new"))
- ;; Old :foreground should NOT be present
- (should (null (plist-get (plist-get props 'face) :foreground)))))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-redef-fg))
- (ignore-errors (makunbound 'tp-test-redef-bg)))))
-
-(ert-deftest tp-test-redefine-layer-clears-old-reactive-deps ()
- "Test that re-defining a layer with different reactive vars clears old dependencies."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; First definition with $old-var
- (define-tp test-redef-deps () :props '(face (:foreground $tp-test-old-var))
- :data '((tp-test-old-var . "red")))
- ;; Check old var is in dependencies
- (should (assoc 'tp-test-old-var tp-reactive-deps))
- (let ((deps (cdr (assoc 'tp-test-old-var tp-reactive-deps))))
- (should (assoc 'test-redef-deps deps)))
- ;; Re-define with $new-var
- (define-tp test-redef-deps () :props '(face (:foreground $tp-test-new-var))
- :data '((tp-test-new-var . "blue")))
- ;; Check old var is no longer in dependencies for this layer
- (when-let ((deps (cdr (assoc 'tp-test-old-var tp-reactive-deps))))
- (should-not (assoc 'test-redef-deps deps)))
- ;; Check new var is in dependencies
- (should (assoc 'tp-test-new-var tp-reactive-deps))
- (let ((deps (cdr (assoc 'tp-test-new-var tp-reactive-deps))))
- (should (assoc 'test-redef-deps deps))))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-old-var))
- (ignore-errors (makunbound 'tp-test-new-var)))))
-
-(ert-deftest tp-test-redefine-layer-updates-watchers ()
- "Test that re-defining a layer updates :watch correctly."
- (tp-test-with-temp-buffer
- ;; Use defvar to create dynamically-bound variables that watcher callbacks can access
- (defvar tp-test-watch-log-old nil "Log for old watcher.")
- (defvar tp-test-watch-log-new nil "Log for new watcher.")
- (setq tp-test-watch-log-old nil)
- (setq tp-test-watch-log-new nil)
- (unwind-protect
- (progn
- ;; First definition with old watcher
- (define-tp test-redef-watch () :props '(face (:foreground $tp-test-watch-var))
- :data '((tp-test-watch-var . "red"))
- :watch '((tp-test-watch-var
- (lambda (new old layer)
- (push (list 'old new) tp-test-watch-log-old)))))
- ;; Re-define with new watcher
- (define-tp test-redef-watch () :props '(face (:foreground $tp-test-watch-var))
- :data '((tp-test-watch-var . "red"))
- :watch '((tp-test-watch-var
- (lambda (new old layer)
- (push (list 'new new) tp-test-watch-log-new)))))
- ;; Change variable
- (setq tp-test-watch-var "blue")
- ;; Old watcher should NOT be called
- (should (null tp-test-watch-log-old))
- ;; New watcher should be called
- (should (= (length tp-test-watch-log-new) 1))
- (should (equal (car tp-test-watch-log-new) '(new "blue"))))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-watch-var))
- (makunbound 'tp-test-watch-log-old)
- (makunbound 'tp-test-watch-log-new))))
-
-(ert-deftest tp-test-redefine-layer-updates-compute ()
- "Test that re-defining a layer updates :compute correctly."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; First definition with old compute
- (setq tp-test-compute-src "hello")
- (define-tp test-redef-compute ()
- :props '(help-echo $tp-test-compute-out)
- :data '(tp-test-compute-src)
- :compute '((tp-test-compute-out
- (lambda () (upcase tp-test-compute-src)))))
- (should (equal tp-test-compute-out "HELLO"))
- ;; Re-define with different compute
- (define-tp test-redef-compute ()
- :props '(help-echo $tp-test-compute-out)
- :data '(tp-test-compute-src)
- :compute '((tp-test-compute-out
- (lambda () (concat tp-test-compute-src "-suffix")))))
- ;; Check compute is updated
- (should (equal tp-test-compute-out "hello-suffix"))
- ;; Trigger re-compute by changing source
- (setq tp-test-compute-src "world")
- (should (equal tp-test-compute-out "world-suffix")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-compute-src))
- (ignore-errors (makunbound 'tp-test-compute-out)))))
-
-(ert-deftest tp-test-redefine-layer-from-reactive-to-static ()
- "Test re-defining a layer from reactive to non-reactive clears dependencies."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; First definition with reactive variable
- (define-tp test-reactive-to-static () :props '(face (:foreground $tp-test-r2s-color))
- :data '((tp-test-r2s-color . "red")))
- ;; Check reactive dependency is registered
- (should (assoc 'tp-test-r2s-color tp-reactive-deps))
- ;; Re-define as static (non-reactive)
- (define-tp test-reactive-to-static () '(face bold))
- ;; Check reactive dependency is cleared
- (when-let ((deps (cdr (assoc 'tp-test-r2s-color tp-reactive-deps))))
- (should-not (assoc 'test-reactive-to-static deps)))
- ;; Check layer has new static props
- (let ((props (tp-layer-props 'test-reactive-to-static)))
- (should (eq (plist-get props 'face) 'bold))))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-r2s-color)))))
-
-(ert-deftest tp-test-redefine-layer-group-updates-data ()
- "Test that re-defining a layer group with different :data initial values updates the variable."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; First definition
- (define-tps test-redef-group ()
- '("layer1" :props (face (:background $tp-test-group-color))
- :data ((tp-test-group-color . "gray"))))
- ;; Check initial value
- (should (equal tp-test-group-color "gray"))
- ;; Re-define with different color
- (define-tps test-redef-group ()
- '("layer1" :props (face (:background $tp-test-group-color))
- :data ((tp-test-group-color . "blue"))))
- ;; Check variable is updated
- (should (equal tp-test-group-color "blue"))
- ;; Check layer props are updated
- (let ((props (cdr (assoc 'test-redef-group-layer1 tp-layer-alist))))
- (should (equal (plist-get (plist-get props 'face) :background) "blue"))))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-group-color)))))
-
-(ert-deftest tp-test-redefine-applied-layer-updates-text ()
- "Test that re-defining a layer updates text regions that have it applied."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; First definition
- (define-tp test-redef-applied () :props '(face (:background $tp-test-applied-color))
- :data '((tp-test-applied-color . "gray")))
- ;; Apply to text
- (insert "Hello World")
- (tp-set 1 6 'test-redef-applied)
- ;; Check initial color
- (should (equal (plist-get (get-text-property 1 'face) :background) "gray"))
- ;; Re-define with different color
- (define-tp test-redef-applied () :props '(face (:background $tp-test-applied-color))
- :data '((tp-test-applied-color . "blue")))
- ;; The text should now have the new color
- ;; This happens because define-tp calls tp--update-layer-regions
- ;; at the end to update all text regions with the new properties
- (should (equal (plist-get (get-text-property 1 'face) :background) "blue")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-applied-color)))))
-
-;;; ============================================================
-;;; Reactive Text (tp-text) Tests
-;;; ============================================================
-
-(ert-deftest tp-test-tp-text-nil-initializes-to-current-text ()
- "Test that tp-text with nil value is initialized to current text."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold tp-text nil))
- ;; tp-text should be set to the current text
- (should (equal (tp-at 1 'tp-text) "Hello"))
- ;; face should still be bold
- (should (eq (tp-at 1 'face) 'bold))))
-
-(ert-deftest tp-test-tp-text-string-object-replaces-content ()
- "Test that tp-text on string object replaces the string content."
- ;; When tp-text is set on a string, the returned string should have
- ;; the tp-text value as its content, not the original string
- (let ((result (tp-set "2" 'face '(:background "green") 'tp-text "6")))
- ;; The returned string should be "6", not "2"
- (should (equal result "6"))
- ;; Properties should be applied
- (should (equal (get-text-property 0 'face result) '(:background "green")))
- (should (equal (get-text-property 0 'tp-text result) "6"))))
-
-(ert-deftest tp-test-tp-text-string-replaces-text ()
- "Test that tp-text with string value replaces the text in the region."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold tp-text "Hi"))
- ;; Text should be replaced
- (should (equal (buffer-substring-no-properties 1 3) "Hi"))
- ;; face should still be applied
- (should (eq (tp-at 1 'face) 'bold))
- ;; tp-text property should be set
- (should (equal (tp-at 1 'tp-text) "Hi"))))
-
-(ert-deftest tp-test-tp-text-preserves-other-properties ()
- "Test that tp-text replacement preserves existing properties."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- ;; First set some properties
- (tp-set 1 6 '(help-echo "greeting"))
- ;; Then set tp-text with face
- (tp-set 1 6 '(face bold tp-text "Hi"))
- ;; Text should be replaced
- (should (equal (buffer-substring-no-properties 1 3) "Hi"))
- ;; Both face and help-echo should be preserved
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "greeting"))))
-
-(ert-deftest tp-test-tp-reset-with-tp-text ()
- "Test that tp-reset with tp-text works correctly."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-reset 1 6 '(face italic tp-text "Bye"))
- ;; Text should be replaced
- (should (equal (buffer-substring-no-properties 1 4) "Bye"))
- ;; Properties should be set
- (should (eq (tp-at 1 'face) 'italic))
- (should (equal (tp-at 1 'tp-text) "Bye"))))
-
-(ert-deftest tp-test-tp-add-with-tp-text ()
- "Test that tp-add with tp-text works correctly."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(help-echo "existing"))
- (tp-add 1 6 '(face bold tp-text "Hi"))
- ;; Text should be replaced
- (should (equal (buffer-substring-no-properties 1 3) "Hi"))
- ;; Both properties should be present
- (should (eq (tp-at 1 'face) 'bold))
- (should (equal (tp-at 1 'help-echo) "existing"))))
-
-(ert-deftest tp-test-tp-text-reactive-layer ()
- "Test tp-text with reactive variable."
- (tp-test-with-temp-buffer
- (defvar tp-test-reactive-text nil "Test variable for reactive text.")
- (setq tp-test-reactive-text "Initial")
- (unwind-protect
- (progn
- (define-tp test-reactive-text-layer ()
- :props '(face bold tp-text $tp-test-reactive-text))
- ;; Apply layer to text
- (insert "Hello World")
- (tp-set 1 6 'test-reactive-text-layer)
- ;; Initial text should be replaced
- (should (equal (buffer-substring-no-properties 1 8) "Initial"))
- ;; tp-text should be set
- (should (equal (tp-at 1 'tp-text) "Initial"))
- ;; Change the reactive variable
- (setq tp-test-reactive-text "Changed")
- ;; Text should be updated
- (should (equal (buffer-substring-no-properties 1 8) "Changed"))
- ;; face should still be applied
- (should (eq (tp-at 1 'face) 'bold)))
- ;; Cleanup
- (makunbound 'tp-test-reactive-text))))
-
-(ert-deftest tp-test-tp-text-reactive-nil-initializes-variable ()
- "Test tp-text with nil reactive variable initializes the variable to source text.
-When tp-text is bound to a reactive variable and that variable is nil,
-the source text should be used and the reactive variable should be updated."
- (tp-test-with-temp-buffer
- (defvar tp-test-text-var nil "Test variable for tp-text initialization.")
- (setq tp-test-text-var nil)
- (unwind-protect
- (progn
- ;; Define layer with tp-text bound to a reactive variable
- (define-tp test-init-text-layer ()
- :props '(face bold tp-text $tp-test-text-var))
- ;; Apply layer to string - variable is nil, so source text should be used
- (let ((result (tp-set "2" 'test-init-text-layer)))
- ;; Result should be the source text "2"
- (should (equal result "2"))
- ;; tp-test-text-var should now be "2"
- (should (equal tp-test-text-var "2"))
- ;; tp-text property should be "2"
- (should (equal (tp-at 0 'tp-text result) "2")))
- ;; Now set the variable to a different value and test again
- (setq tp-test-text-var "18")
- ;; Redefine layer to reset resolved props to the new variable value.
- ;; This is necessary because the layer definition caches the resolved
- ;; tp-text value, and we want to test the behavior when the variable
- ;; already has a non-nil value at layer application time.
- (define-tp test-init-text-layer ()
- :props '(face bold tp-text $tp-test-text-var))
- (let ((result (tp-set "2" 'test-init-text-layer)))
- ;; Result should be the variable value "18", not source "2"
- (should (equal result "18"))
- ;; Variable should remain "18"
- (should (equal tp-test-text-var "18"))))
- ;; Cleanup
- (makunbound 'tp-test-text-var))))
-
-(ert-deftest tp-test-tp-text-direct-string-uses-specified-text ()
- "Test tp-text with direct string value uses that string, not source text.
-When tp-text is set directly to a string (not a reactive variable),
-the inserted text should be that string, not the source text."
- (let ((result (tp-set "2" 'tp-text "23")))
- ;; Result should be "23", not "2"
- (should (equal result "23"))
- ;; tp-text property should be "23"
- (should (equal (tp-at 0 'tp-text result) "23"))))
-
-(ert-deftest tp-test-tp-text-reactive-computed ()
- "Test tp-text with computed reactive variable."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- (setq tp-test-name-part1 "Hello")
- (setq tp-test-name-part2 "World")
- (define-tp test-computed-text-layer ()
- :props '(face bold tp-text $tp-test-full-text)
- :data '(tp-test-name-part1 tp-test-name-part2)
- :compute '((tp-test-full-text
- (lambda ()
- (concat tp-test-name-part1 " " tp-test-name-part2)))))
- ;; Apply layer to text
- (insert "placeholder")
- (tp-set 1 12 'test-computed-text-layer)
- ;; Text should be replaced with computed value
- (should (equal (buffer-substring-no-properties 1 12) "Hello World"))
- ;; Change a data variable
- (setq tp-test-name-part1 "Goodbye")
- ;; Text should be updated with new computed value
- (should (equal (buffer-substring-no-properties 1 14) "Goodbye World")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-name-part1))
- (ignore-errors (makunbound 'tp-test-name-part2))
- (ignore-errors (makunbound 'tp-test-full-text)))))
-
-(ert-deftest tp-test-tp-text-same-text-different-properties ()
- "Test tp-text updates when text is same but properties differ.
-When the reactive variable changes to a propertized string with the same
-text content but different properties, the properties should be updated."
- (tp-test-with-temp-buffer
- (defvar tp-test-same-text nil "Test variable for same text different props.")
- (setq tp-test-same-text "emacs")
- (unwind-protect
- (progn
- (define-tp test-same-text-layer ()
- :props '(face (:foreground "green") tp-text $tp-test-same-text))
- ;; Apply layer to text - insert placeholder and apply layer to entire buffer
- (insert "placeholder")
- (tp-set (point-min) (point-max) 'test-same-text-layer)
- ;; Initial text should be "emacs" with foreground green
- (should (equal (buffer-substring-no-properties (point-min) (point-max)) "emacs"))
- (should (equal (plist-get (tp-at (point-min) 'face) :foreground) "green"))
- ;; Change the reactive variable to same text but different properties
- (setq tp-test-same-text (propertize "emacs" 'face 'bold))
- ;; Text should still be "emacs"
- (should (equal (buffer-substring-no-properties (point-min) (point-max)) "emacs"))
- ;; Face should now include bold from the propertized string
- (let ((face-val (tp-at (point-min) 'face)))
- (should (or (eq face-val 'bold)
- (and (listp face-val) (memq 'bold face-val))))))
- ;; Cleanup
- (makunbound 'tp-test-same-text))))
-
-;;; ============================================================
-;;; tp-text with Embedded Text Properties Tests
-;;; ============================================================
-
-(ert-deftest tp-test-tp-text-with-embedded-properties-string ()
- "Test that tp-set with tp-text preserves embedded properties on strings."
- ;; When tp-text is a propertized string, embedded properties should be preserved
- ;; (props still override embedded if there's a conflict)
- (let* ((propertized-text (copy-sequence "Hello"))
- (_ (put-text-property 0 5 'custom-prop 'embedded-value propertized-text))
- (result (tp-set "X" 'tp-text propertized-text 'face 'bold)))
- ;; The text content should be from tp-text
- (should (equal result "Hello"))
- ;; The face property from props should be applied
- (should (equal (tp-at 0 'face result) 'bold))
- ;; tp-set now preserves embedded props
- (should (equal (tp-at 0 'custom-prop result) 'embedded-value))))
-
-(ert-deftest tp-test-tp-add-with-embedded-properties-string ()
- "Test that tp-add with tp-text merges embedded properties on strings."
- ;; When tp-text is a propertized string and tp-add is used, props are merged
- (let* ((propertized-text (copy-sequence "Hello"))
- (_ (put-text-property 0 5 'custom-prop 'embedded-value propertized-text))
- (result (tp-add "X" 'tp-text propertized-text 'face 'bold)))
- ;; The text content should be from tp-text
- (should (equal result "Hello"))
- ;; The face property from props should be applied
- (should (equal (tp-at 0 'face result) 'bold))
- ;; tp-add merges - embedded custom-prop should be present
- (should (equal (tp-at 0 'custom-prop result) 'embedded-value))))
-
-(ert-deftest tp-test-tp-text-with-embedded-face-string ()
- "Test that tp-set with tp-text preserves embedded face on strings."
- (let* ((propertized-text (copy-sequence "Hello"))
- (_ (put-text-property 0 5 'face 'italic propertized-text))
- ;; Set tp-text with its own face, and also specify help-echo
- (result (tp-set "X" 'tp-text propertized-text 'help-echo "tip")))
- ;; The text content should be from tp-text
- (should (equal result "Hello"))
- ;; tp-set now preserves embedded face
- (should (equal (tp-at 0 'face result) 'italic))
- ;; The help-echo from props should be applied
- (should (equal (tp-at 0 'help-echo result) "tip"))))
-
-(ert-deftest tp-test-tp-add-with-embedded-face-string ()
- "Test that tp-add with tp-text merges embedded face on strings."
- (let* ((propertized-text (copy-sequence "Hello"))
- (_ (put-text-property 0 5 'face 'italic propertized-text))
- ;; Add tp-text with its own face, and also specify help-echo
- (result (tp-add "X" 'tp-text propertized-text 'help-echo "tip")))
- ;; The text content should be from tp-text
- (should (equal result "Hello"))
- ;; tp-add merges - embedded face should be present
- (should (equal (tp-at 0 'face result) 'italic))
- ;; The help-echo from props should be applied
- (should (equal (tp-at 0 'help-echo result) "tip"))))
-
-(ert-deftest tp-test-tp-text-with-embedded-properties-buffer ()
- "Test that tp-set with tp-text preserves embedded properties in buffers."
- (tp-test-with-temp-buffer
- (insert "Original")
- (let* ((propertized-text (copy-sequence "New"))
- (_ (put-text-property 0 3 'custom-prop 'embedded-value propertized-text)))
- (tp-set 1 9 `(face bold tp-text ,propertized-text))
- ;; The text content should be replaced with tp-text value
- (should (equal (buffer-substring-no-properties 1 4) "New"))
- ;; The face from props should be applied
- (should (equal (tp-at 1 'face) 'bold))
- ;; tp-set now preserves embedded props
- (should (equal (tp-at 1 'custom-prop) 'embedded-value)))))
-
-(ert-deftest tp-test-tp-text-with-mixed-properties ()
- "Test that tp-set with tp-text preserves embedded properties."
- ;; tp-set now preserves embedded props (props still take precedence for conflicts)
- (let* ((propertized-text (copy-sequence "ABCD"))
- ;; Set a property at position 0
- (_ (put-text-property 0 4 'region-type 'start propertized-text))
- (result (tp-set "X" 'tp-text propertized-text 'face 'bold)))
- ;; The text content should be from tp-text
- (should (equal result "ABCD"))
- ;; The face from props should be applied uniformly
- (should (equal (tp-at 0 'face result) 'bold))
- (should (equal (tp-at 3 'face result) 'bold))
- ;; tp-set now preserves embedded props
- (should (equal (tp-at 0 'region-type result) 'start))))
-
-(ert-deftest tp-test-tp-reset-with-embedded-properties ()
- "Test that tp-reset preserves embedded text properties from tp-text."
- (let* ((propertized-text (copy-sequence "Test"))
- (_ (put-text-property 0 4 'custom-prop 'value propertized-text))
- (result (tp-reset "X" 'tp-text propertized-text 'face 'bold)))
- ;; The text content should be from tp-text
- (should (equal result "Test"))
- ;; The face from props should be applied
- (should (equal (tp-at 0 'face result) 'bold))
- ;; tp-reset now preserves embedded props from tp-text
- (should (equal (tp-at 0 'custom-prop result) 'value))))
-
-(ert-deftest tp-test-tp-add-with-embedded-properties ()
- "Test that tp-add with embedded text properties preserves them."
- (let* ((propertized-text (copy-sequence "Test"))
- (_ (put-text-property 0 4 'custom-prop 'value propertized-text))
- (result (tp-add "X" 'tp-text propertized-text 'face 'bold)))
- ;; The text content should be from tp-text
- (should (equal result "Test"))
- ;; The face from props should be applied
- (should (equal (tp-at 0 'face result) 'bold))
- ;; The embedded custom-prop from tp-text should be preserved
- (should (equal (tp-at 0 'custom-prop result) 'value))))
-
-(ert-deftest tp-test-tp-text-face-merging ()
- "Test that tp-add with tp-text merges embedded face property with props face."
- ;; This is the core use case for tp-add: merging face 'bold with face (:foreground \"red\")
- (let ((result (tp-add "emacs" 'face 'bold 'tp-text (propertize "vim" 'face '(:foreground "red")))))
- ;; Text should be replaced
- (should (equal result "vim"))
- ;; Face should be merged: (:foreground \"red\") + bold
- (let ((face-val (tp-at 0 'face result)))
- ;; 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 (equal face-val '(:foreground "red"))
- (and (listp face-val)
- (cl-some (lambda (f)
- (and (listp f)
- (equal (plist-get f :foreground) "red")))
- face-val)))))))
-
-(ert-deftest tp-test-tp-add-face-override-subprops ()
- "Test that tp-add with tp-text overrides same face sub-properties."
- ;; When new props have same sub-property as embedded, new value should override
- ;; Example: new (:foreground "green") should override embedded (:foreground "red")
- (let ((result (tp-add "emacs" 'face '(:foreground "green")
- 'tp-text (propertize "vim" 'face '(:foreground "red")))))
- (should (equal result "vim"))
- ;; Face should be (:foreground "green") - new overrides old
- (let ((face-val (tp-at 0 'face result)))
- (should (equal face-val '(:foreground "green")))))
- ;; More complex case: new (bold (:foreground "green")) with embedded (:foreground "red")
- (let ((result (tp-add "emacs" 'face '(bold (:foreground "green"))
- 'tp-text (propertize "vim" 'face '(:foreground "red")))))
- (should (equal result "vim"))
- ;; Face should be (bold (:foreground "green")) - new overrides old
- (let ((face-val (tp-at 0 'face result)))
- (should (member 'bold (if (listp face-val) face-val (list face-val))))
- ;; Should have green, not red
- (should (cl-some (lambda (f)
- (and (listp f)
- (keywordp (car-safe f))
- (equal (plist-get f :foreground) "green")))
- (if (and (listp face-val) (not (keywordp (car-safe face-val))))
- face-val
- (list face-val))))))
- ;; Mixed format case: new (bold :foreground "green") with embedded (:foreground "red")
- (let ((result (tp-add "emacs" 'face '(bold :foreground "green")
- 'tp-text (propertize "vim" 'face '(:foreground "red")))))
- (should (equal result "vim"))
- ;; Face should be (bold (:foreground "green")) - parsed correctly and new overrides old
- (let ((face-val (tp-at 0 'face result)))
- (should (member 'bold (if (listp face-val) face-val (list face-val))))
- ;; Should have green, not red
- (should (cl-some (lambda (f)
- (and (listp f)
- (keywordp (car-safe f))
- (equal (plist-get f :foreground) "green")))
- (if (and (listp face-val) (not (keywordp (car-safe face-val))))
- face-val
- (list face-val)))))))
-
-;;; ============================================================
-;;; New define-tp Format Tests (Parameterized and Non-Parameterized)
-;;; ============================================================
-
-(ert-deftest tp-test-define-tp-non-parameterized ()
- "Test define-tp with non-parameterized format (empty arglist)."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- (should (assoc 'tp-bold tp-layer-alist))
- ;; Unified structure: (LAYER-NAME nil BODY-FORM) where BODY-FORM is quoted
- (let ((entry (cdr (assoc 'tp-bold tp-layer-alist))))
- (should (= (length entry) 2))
- (should (null (car entry))) ; arglist is nil
- (should (equal (eval (cadr entry)) '(face bold))))))
-
-(ert-deftest tp-test-define-tp-non-parameterized-usage-string ()
- "Test non-parameterized layer usage with string: (tp-set string 'layer-name t).
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- (let ((result (tp-set "emacs" 'tp-bold t)))
- ;; Result should have the correct properties
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- (should (eq (get-text-property 0 'face result) 'bold)))))
-
-(ert-deftest tp-test-define-tp-non-parameterized-usage-region ()
- "Test non-parameterized layer usage with region: (tp-set start end '(layer-name t)).
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (insert "emacs")
- (define-tp tp-bold ()
- '(face bold))
- (tp-set 1 6 '(tp-bold t))
- ;; Check properties in buffer
- (should-not (tp-at 1 'tp-name)) ; no tp-name for direct setting
- (should (eq (tp-at 1 'face) 'bold))))
-
-(ert-deftest tp-test-define-tp-parameterized ()
- "Test define-tp with parameterized format."
- (tp-test-with-temp-buffer
- (define-tp tp-space (pixel)
- (list 'display (list 'space :width (list pixel))))
- ;; Check it's registered as a parameterized layer in tp-layer-alist
- (should (assoc 'tp-space tp-layer-alist))
- (should (tp-layer-parameterized-p 'tp-space))
- ;; Check the structure is correct (ARGLIST BODY-FORM)
- (let ((entry (cdr (assoc 'tp-space tp-layer-alist))))
- ;; entry is (ARGLIST BODY-FORM)
- (should (equal (car entry) '(pixel))))))
-
-(ert-deftest tp-test-define-tp-parameterized-usage-string ()
- "Test parameterized layer usage with string: (tp-set string 'layer-name arg).
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-space (pixel)
- (list 'display (list 'space :width (list pixel))))
- (let ((result (tp-set "emacs" 'tp-space 2)))
- ;; Result should have the correct properties
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- (should (equal (get-text-property 0 'display result) '(space :width (2)))))))
-
-(ert-deftest tp-test-define-tp-parameterized-usage-region ()
- "Test parameterized layer usage with region: (tp-set start end '(layer-name arg)).
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (insert "emacs")
- (define-tp tp-space (pixel)
- (list 'display (list 'space :width (list pixel))))
- (tp-set 1 6 '(tp-space 5))
- ;; Check properties in buffer
- (should-not (tp-at 1 'tp-name)) ; no tp-name for direct setting
- (should (equal (tp-at 1 'display) '(space :width (5))))))
-
-(ert-deftest tp-test-define-tp-parameterized-backquote ()
- "Test parameterized layer with backquote syntax.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-test-space (pixel)
- `(display (space :width (,pixel))))
- (let ((result (tp-set "emacs" 'tp-test-space 10)))
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- (should (equal (get-text-property 0 'display result) '(space :width (10)))))))
-
-(ert-deftest tp-test-define-tp-parameterized-undefine ()
- "Test tp-undefine-layer clears parameterized layer info."
- (tp-test-with-temp-buffer
- (define-tp tp-test-param (arg)
- (list 'display arg))
- (should (assoc 'tp-test-param tp-layer-alist))
- (should (tp-layer-parameterized-p 'tp-test-param))
- (tp-undefine-layer 'tp-test-param)
- (should-not (assoc 'tp-test-param tp-layer-alist))))
-
-(ert-deftest tp-test-layer-reset-clears-params ()
- "Test tp-layer-reset clears parameterized layers."
- (tp-test-with-temp-buffer
- (define-tp tp-test-param (arg)
- (list 'display arg))
- (should (assoc 'tp-test-param tp-layer-alist))
- (tp-layer-reset)
- (should-not tp-layer-alist)))
-
-(ert-deftest tp-test-layer-with-extra-props-string ()
- "Test layer with extra native properties on string.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- ;; Non-parameterized layer with extra props
- (let ((result (tp-set "emacs" 'tp-bold t 'face '(:foreground "green"))))
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- ;; Should have both face values in the plist
- (let ((props (text-properties-at 0 result)))
- (should (member 'face props))))))
-
-(ert-deftest tp-test-parameterized-layer-with-extra-props-string ()
- "Test parameterized layer with extra native properties on string.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
- ;; Parameterized layer with extra props
- (let ((result (tp-set "emacs" 'tp-space 6 'face '(:foreground "green"))))
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- (should (equal (get-text-property 0 'display result) '(space :width (6))))
- (should (equal (get-text-property 0 'face result) '(:foreground "green"))))))
-
-(ert-deftest tp-test-layer-with-extra-props-region ()
- "Test layer with extra native properties on region.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- ;; Region form with extra props
- (let ((result (tp-set 0 5 '(tp-bold t face (:foreground "green")) "emacs")))
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- ;; Should have both face values in the plist
- (let ((props (text-properties-at 0 result)))
- (should (member 'face props))))))
-
-(ert-deftest tp-test-parameterized-layer-with-extra-props-region ()
- "Test parameterized layer with extra native properties on region.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
- ;; Region form with extra props
- (let ((result (tp-set 0 5 '(tp-space 6 face (:foreground "green")) "emacs")))
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- (should (equal (get-text-property 0 'display result) '(space :width (6))))
- (should (equal (get-text-property 0 'face result) '(:foreground "green"))))))
-
-(ert-deftest tp-test-layer-at-any-position-string ()
- "Test layer properties can be at any position in string form.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
- ;; Layer in the middle of the plist
- (let ((result (tp-set "emacs"
- 'face '(:foreground "green")
- 'tp-space 6
- 'test "test")))
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- (should (equal (get-text-property 0 'display result) '(space :width (6))))
- (should (equal (get-text-property 0 'face result) '(:foreground "green")))
- (should (equal (get-text-property 0 'test result) "test")))))
-
-(ert-deftest tp-test-layer-at-any-position-region ()
- "Test layer properties can be at any position in region form.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
- ;; Layer in the middle of the plist
- (let ((result (tp-set 0 5 '(face (:foreground "green") tp-space 6 test "test") "emacs")))
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- (should (equal (get-text-property 0 'display result) '(space :width (6))))
- (should (equal (get-text-property 0 'face result) '(:foreground "green")))
- (should (equal (get-text-property 0 'test result) "test")))))
-
-(ert-deftest tp-test-non-param-layer-at-any-position ()
- "Test non-parameterized layer at any position.
-When using tp-set (direct property setting), tp-name is NOT added."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- ;; Layer in the middle of the plist
- (let ((result (tp-set "emacs"
- 'test1 "value1"
- 'tp-bold t
- 'test2 "value2")))
- (should-not (get-text-property 0 'tp-name result)) ; no tp-name for direct setting
- (should (equal (get-text-property 0 'test1 result) "value1"))
- (should (equal (get-text-property 0 'test2 result) "value2")))))
-
-;; Tests for tp-push-layer and tp-put-layer with define-tp layers
-(ert-deftest tp-test-push-layer-non-parameterized ()
- "Test tp-push-layer with non-parameterized define-tp layer."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- ;; String form
- (let ((result (tp-push-layer "emacs" 'tp-bold)))
- (should (eq (get-text-property 0 'tp-name result) 'tp-bold))
- (should (eq (get-text-property 0 'face result) 'bold)))))
-
-(ert-deftest tp-test-push-layer-parameterized ()
- "Test tp-push-layer with parameterized define-tp layer."
- (tp-test-with-temp-buffer
- (define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
- ;; String form with parameterized layer
- (let ((result (tp-push-layer "emacs" '(tp-space 6))))
- (should (eq (get-text-property 0 'tp-name result) 'tp-space))
- (should (equal (get-text-property 0 'display result) '(space :width (6)))))))
-
-(ert-deftest tp-test-put-layer-non-parameterized ()
- "Test tp-put-layer with non-parameterized define-tp layer."
- (tp-test-with-temp-buffer
- (define-tp tp-italic ()
- '(face italic))
- ;; String form
- (let ((result (tp-put-layer "emacs" 'tp-italic 0)))
- (should (eq (get-text-property 0 'tp-name result) 'tp-italic))
- (should (eq (get-text-property 0 'face result) 'italic)))))
-
-(ert-deftest tp-test-put-layer-parameterized ()
- "Test tp-put-layer with parameterized define-tp layer."
- (tp-test-with-temp-buffer
- (define-tp tp-width (pixels)
- `(display (space :width (,pixels))))
- ;; String form with parameterized layer
- (let ((result (tp-put-layer "emacs" '(tp-width 10) 0)))
- (should (eq (get-text-property 0 'tp-name result) 'tp-width))
- (should (equal (get-text-property 0 'display result) '(space :width (10)))))))
-
-;; Tests for reactive variables with define-tp layers
-(ert-deftest tp-test-define-tp-with-reactive-var-needs-tp-name ()
- "Test define-tp layers mixed with reactive variables get anonymous tp-name."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- (define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
- ;; Define a reactive variable
- (defvar $tp-test-color "red")
- (defvar $tp-test-pixel 10)
- ;; Using reactive variables - should get anonymous tp-name
- ;; Note: When using backquote `, the $vars are expanded at read time
- ;; so this doesn't test the reactive detection. Instead we test that
- ;; the expansion works correctly.
- (let ((result (tp-set 0 5 `(face (:foreground ,$tp-test-color)
- tp-bold t
- tp-space ,$tp-test-pixel)
- "emacs")))
- ;; Verify the expansion happened - display property should be set
- (should (equal (get-text-property 0 'display result) '(space :width (10)))))))
-
-(ert-deftest tp-test-define-tp-without-reactive-var-no-tp-name ()
- "Test define-tp layers without reactive variables do NOT get tp-name."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- (define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
- ;; Not using reactive variables - should NOT have tp-name
- (let ((result (tp-set 0 5 '(face (:foreground "green")
- tp-bold t
- tp-space 6)
- "emacs")))
- (should-not (get-text-property 0 'tp-name result))
- ;; Display property should be expanded from tp-space
- (should (equal (get-text-property 0 'display result) '(space :width (6))))
- ;; Face property exists (first one found is (:foreground "green"))
- (should (get-text-property 0 'face result)))))
-
-(ert-deftest tp-test-define-tp-string-form-without-reactive-no-tp-name ()
- "Test define-tp layers in string form without reactive vars - no tp-name."
- (tp-test-with-temp-buffer
- (define-tp tp-bold ()
- '(face bold))
- (define-tp tp-space (pixel)
- `(display (space :width (,pixel))))
- ;; String form - not using reactive variables - should NOT have tp-name
- (let ((result (tp-set "emacs"
- 'face '(:foreground "green")
- 'tp-bold t
- 'tp-space 6)))
- (should-not (get-text-property 0 'tp-name result))
- ;; Display property should be expanded from tp-space
- (should (equal (get-text-property 0 'display result) '(space :width (6))))
- ;; Face property exists
- (should (get-text-property 0 'face result)))))
-
-;;; ============================================================
-;;; Batched Updates Tests
-;;; ============================================================
-
-(ert-deftest tp-test-batch-updates-basic ()
- "Test that tp-with-batch-updates defers reactive updates."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Define a reactive layer
- (define-tp test-batch-layer ()
- :props '(face (:foreground $tp-test-batch-color))
- :data '((tp-test-batch-color . "red")))
- (insert "Hello World")
- (tp-set 1 6 'test-batch-layer)
- ;; Initial color should be red
- (should (equal (plist-get (tp-at 1 'face) :foreground) "red"))
- ;; Now use batch updates
- (tp-with-batch-updates
- (setq tp-test-batch-color "blue")
- ;; Inside batch, layer definition is updated but buffer may not be
- ;; (implementation note: the layer props are always updated immediately)
- )
- ;; After batch ends, buffer should be updated
- (should (equal (plist-get (tp-at 1 'face) :foreground) "blue")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-batch-color)))))
-
-(ert-deftest tp-test-batch-updates-multiple-vars ()
- "Test that tp-with-batch-updates consolidates multiple variable changes."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Define a reactive layer with multiple vars
- (define-tp test-multi-batch ()
- :props '(face (:foreground $tp-test-fg :background $tp-test-bg))
- :data '((tp-test-fg . "white") (tp-test-bg . "black")))
- (insert "Hello World")
- (tp-set 1 6 'test-multi-batch)
- ;; Use batch updates
- (tp-with-batch-updates
- (setq tp-test-fg "yellow")
- (setq tp-test-bg "navy"))
- ;; Both should be updated
- (should (equal (plist-get (tp-at 1 'face) :foreground) "yellow"))
- (should (equal (plist-get (tp-at 1 'face) :background) "navy")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-fg))
- (ignore-errors (makunbound 'tp-test-bg)))))
-
-;;; ============================================================
-;;; Debug Mode Tests
-;;; ============================================================
-
-(ert-deftest tp-test-debug-mode-logs ()
- "Test that debug mode logs to *tp-debug* buffer."
- (tp-test-with-temp-buffer
- (let ((tp-debug-mode t)
- (tp-debug-echo nil))
- ;; Clear any existing debug buffer
- (tp-debug-clear)
- ;; Log a message
- (tp-debug-log "Test message %d" 42)
- ;; Check the debug buffer
- (with-current-buffer (get-buffer "*tp-debug*")
- (should (string-match-p "Test message 42" (buffer-string)))))))
-
-(ert-deftest tp-test-debug-mode-disabled ()
- "Test that debug mode does not log when disabled."
- (tp-test-with-temp-buffer
- (let ((tp-debug-mode nil))
- ;; Clear any existing debug buffer
- (tp-debug-clear)
- ;; Try to log a message
- (tp-debug-log "Should not appear")
- ;; Check that buffer is empty or doesn't exist
- (let ((buf (get-buffer "*tp-debug*")))
- (if buf
- (with-current-buffer buf
- (should (string= (buffer-string) ""))))))))
-
-;;; ============================================================
-;;; Value Transformation Tests
-;;; ============================================================
-
-(ert-deftest tp-test-transform-basic ()
- "Test that :transform transforms tp-text values."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Define a layer with transform
- (define-tp test-transform-layer ()
- :props '(face bold tp-text $tp-test-value)
- :data '((tp-test-value . "hello"))
- :transform #'upcase)
- (insert "placeholder")
- (tp-set 1 12 'test-transform-layer)
- ;; Text should be transformed to uppercase
- (should (equal (buffer-substring-no-properties 1 6) "HELLO")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-value)))))
-
-(ert-deftest tp-test-transform-with-reactive-update ()
- "Test that :transform works with reactive updates."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Define a layer with transform (format as currency)
- (define-tp test-currency-layer ()
- :props '(face bold tp-text $tp-test-amount)
- :data '((tp-test-amount . "100"))
- :transform (lambda (text)
- (format "$%s.00" text)))
- (insert "placeholder")
- (tp-set 1 12 'test-currency-layer)
- ;; Text should be formatted
- (should (equal (buffer-substring-no-properties 1 8) "$100.00"))
- ;; Update the variable
- (setq tp-test-amount "250")
- ;; Text should be updated with transform applied
- (should (equal (buffer-substring-no-properties 1 8) "$250.00")))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-amount)))))
-
-(ert-deftest tp-test-transform-removed-on-redefine ()
- "Test that :transform is removed when layer is redefined without it."
- (tp-test-with-temp-buffer
- (unwind-protect
- (progn
- ;; Define with transform
- (define-tp test-redef-transform ()
- :props '(face bold tp-text $tp-test-text)
- :data '((tp-test-text . "hello"))
- :transform #'upcase)
- ;; Check transform is registered
- (should (assoc 'test-redef-transform tp-layer-transforms))
- ;; Redefine without transform
- (define-tp test-redef-transform ()
- :props '(face bold tp-text $tp-test-text)
- :data '((tp-test-text . "hello")))
- ;; Transform should be removed
- (should-not (assoc 'test-redef-transform tp-layer-transforms)))
- ;; Cleanup
- (ignore-errors (makunbound 'tp-test-text)))))
-
-;;; ============================================================
-;;; Built-in Text Property Name Validation Tests
-;;; ============================================================
-
-(ert-deftest tp-test-builtin-text-property-check ()
- "Test that tp--builtin-text-property-p correctly identifies built-in properties."
- ;; Check known built-in properties
- (should (tp--builtin-text-property-p 'face))
- (should (tp--builtin-text-property-p 'display))
- (should (tp--builtin-text-property-p 'invisible))
- (should (tp--builtin-text-property-p 'help-echo))
- (should (tp--builtin-text-property-p 'keymap))
- (should (tp--builtin-text-property-p 'mouse-face))
- (should (tp--builtin-text-property-p 'read-only))
- (should (tp--builtin-text-property-p 'front-sticky))
- (should (tp--builtin-text-property-p 'rear-nonsticky))
- ;; Check non-built-in properties
- (should-not (tp--builtin-text-property-p 'tp-my-custom-layer))
- (should-not (tp--builtin-text-property-p 'my-layer))
- (should-not (tp--builtin-text-property-p 'custom-property)))
-
-(ert-deftest tp-test-define-tp-rejects-builtin-names ()
- "Test that define-tp rejects built-in text property names."
- (tp-test-with-temp-buffer
- ;; Test that using 'face as a layer name raises an error
- (should-error
- (eval '(define-tp face () '(help-echo "test"))))
- ;; Test that using 'display as a layer name raises an error
- (should-error
- (eval '(define-tp display () '(face bold))))
- ;; Test that using 'invisible as a layer name raises an error
- (should-error
- (eval '(define-tp invisible () '(face bold))))
- ;; Test that using 'keymap as a layer name raises an error
- (should-error
- (eval '(define-tp keymap () '(face bold))))
- ;; Test that valid names work fine
- (should (define-tp tp-test-valid-layer () '(face bold)))))
-
-(ert-deftest tp-test-define-tp-parameterized-rejects-builtin ()
- "Test that parameterized define-tp also rejects built-in names."
- (tp-test-with-temp-buffer
- ;; Parameterized layer with built-in name should fail
- (should-error
- (eval '(define-tp display (value) `(face (:height ,value)))))
- ;; Valid parameterized layer should work
- (should (define-tp tp-test-param-valid (value) `(face (:height ,value))))))
-
-;;; ============================================================
-;;; Nested Layer Resolution Tests
-;;; ============================================================
-
-(ert-deftest tp-test-nested-layer-resolution ()
- "Test that nested custom layers are resolved to built-in properties.
-When a layer's body returns a plist containing other custom layer names,
-those should be recursively expanded to their built-in properties."
- (tp-test-with-temp-buffer
- ;; Define a base layer that returns built-in properties
- (define-tp tp-test-base-layer (color)
- `(face (:foreground ,color :background "white")))
- ;; Define a wrapper layer that uses the base layer
- (define-tp tp-test-wrapper-layer (plist)
- (let ((color (plist-get plist :color)))
- `(tp-test-base-layer ,color
- help-echo "wrapper")))
- ;; Use the wrapper layer
- (let ((result (tp-set "test" 'tp-test-wrapper-layer '(:color "red"))))
- ;; The face property should be resolved from tp-test-base-layer
- (should (equal (plist-get (get-text-property 0 'face result) :foreground) "red"))
- (should (equal (plist-get (get-text-property 0 'face result) :background) "white"))
- ;; help-echo should also be present
- (should (equal (get-text-property 0 'help-echo result) "wrapper"))
- ;; tp-test-base-layer should NOT be present as a property
- (should (null (get-text-property 0 'tp-test-base-layer result))))))
-
-(ert-deftest tp-test-deeply-nested-layer-resolution ()
- "Test that deeply nested layers (3 levels) are fully resolved."
- (tp-test-with-temp-buffer
- ;; Define 3 levels of nesting
- (define-tp tp-test-level1 (val)
- `(face (:foreground ,val)))
- (define-tp tp-test-level2 (val)
- `(tp-test-level1 ,val help-echo "level2"))
- (define-tp tp-test-level3 (val)
- `(tp-test-level2 ,val display "level3"))
- ;; Use the most deeply nested layer
- (let ((result (tp-set "test" 'tp-test-level3 "blue")))
- ;; All properties should be resolved
- (should (equal (plist-get (get-text-property 0 'face result) :foreground) "blue"))
- (should (equal (get-text-property 0 'help-echo result) "level2"))
- (should (equal (get-text-property 0 'display result) "level3"))
- ;; None of the custom layer names should be present
- (should (null (get-text-property 0 'tp-test-level1 result)))
- (should (null (get-text-property 0 'tp-test-level2 result))))))
-
-;;; ============================================================
-;;; Duplicate Property Merging Tests
-;;; ============================================================
-
-(ert-deftest tp-test-merge-duplicate-face-symbols ()
- "Test that multiple face symbols in one call are merged into a face list."
- (tp-test-with-temp-buffer
- (let ((result (tp-set "emacs"
- 'face 'bold
- 'face 'italic)))
- ;; Should be a list with italic first (later takes precedence)
- (let ((face-prop (get-text-property 0 'face result)))
- (should (listp face-prop))
- (should (memq 'bold face-prop))
- (should (memq 'italic face-prop))
- ;; italic should come before bold (later value takes precedence)
- (should (< (cl-position 'italic face-prop)
- (cl-position 'bold face-prop)))))))
-
-(ert-deftest tp-test-merge-duplicate-face-plists ()
- "Test that multiple face plists in one call are merged."
- (tp-test-with-temp-buffer
- (let ((result (tp-set "emacs"
- 'face '(:background "green")
- 'face '(:foreground "red"))))
- (let ((face-prop (get-text-property 0 'face result)))
- ;; Should be a merged plist
- (should (plist-get face-prop :background))
- (should (plist-get face-prop :foreground))
- (should (equal (plist-get face-prop :background) "green"))
- (should (equal (plist-get face-prop :foreground) "red"))))))
-
-(ert-deftest tp-test-merge-duplicate-face-later-overrides ()
- "Test that later face plist values override earlier ones for same key."
- (tp-test-with-temp-buffer
- (let ((result (tp-set "emacs"
- 'face '(:foreground "red")
- 'face '(:foreground "yellow"))))
- (let ((face-prop (get-text-property 0 'face result)))
- ;; Later value should override
- (should (equal (plist-get face-prop :foreground) "yellow"))))))
-
-(ert-deftest tp-test-merge-other-props-later-overrides ()
- "Test that non-face duplicate properties use later value."
- (tp-test-with-temp-buffer
- (let ((result (tp-set "emacs"
- 'help-echo "first"
- 'help-echo "second")))
- (should (equal (get-text-property 0 'help-echo result) "second")))))
-
-(ert-deftest tp-test-merge-multiple-layers-with-face ()
- "Test merging multiple layers that each contribute face properties."
- (tp-test-with-temp-buffer
- (define-tp tp-test-layer1 ()
- '(face (:foreground "blue")))
- (define-tp tp-test-layer2 ()
- '(face (:background "yellow")))
- (let ((result (tp-set "emacs"
- 'tp-test-layer1 t
- 'tp-test-layer2 t
- 'face '(:weight bold))))
- (let ((face-prop (get-text-property 0 'face result)))
- ;; All face properties should be merged
- (should (equal (plist-get face-prop :foreground) "blue"))
- (should (equal (plist-get face-prop :background) "yellow"))
- (should (equal (plist-get face-prop :weight) 'bold))))))
-
-(ert-deftest tp-test-merge-in-region-form ()
- "Test duplicate property merging in region form."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-set 1 6 '(face bold face (:foreground "green")))
- (let ((face-prop (tp-at 1 'face)))
- ;; Should be a list with plist and symbol
- (should (listp face-prop))
- ;; Check properties
- (should (or (memq 'bold face-prop)
- (eq face-prop 'bold))))))
-
-(ert-deftest tp-test-tp-add-merge-faces ()
- "Test that tp-add also merges duplicate face properties."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-add 1 6 '(face bold face (:foreground "red")))
- (let ((face-prop (tp-at 1 'face)))
- ;; Should have both face values merged
- (should (listp face-prop))
- (should (memq 'bold face-prop))
- ;; Check for the plist part with :foreground
- (should (cl-some (lambda (f)
- (and (listp f)
- (keywordp (car f))
- (equal (plist-get f :foreground) "red")))
- face-prop)))))
-
-(ert-deftest tp-test-tp-reset-merge-faces ()
- "Test that tp-reset also merges duplicate face properties."
- (tp-test-with-temp-buffer
- (insert "Hello World")
- (tp-reset 1 6 '(face bold face (:foreground "red")))
- (let ((face-prop (tp-at 1 'face)))
- ;; Should have both face values merged
- (should (listp face-prop))
- (should (memq 'bold face-prop)))))
-
-(ert-deftest tp-test-merge-mouse-face ()
- "Test that mouse-face properties are also merged."
- (tp-test-with-temp-buffer
- (let ((result (tp-set "emacs"
- 'mouse-face 'highlight
- 'mouse-face '(:background "blue"))))
- (let ((mouse-face-prop (get-text-property 0 'mouse-face result)))
- ;; Should be a list with plist and symbol
- (should (listp mouse-face-prop))
- (should (memq 'highlight mouse-face-prop))))))
-
-;;; ============================================================
-;;; Nil Value Property Tests (Issue: "Odd length text property list")
-;;; ============================================================
-
-(ert-deftest tp-test-set-with-nil-value ()
- "Test tp-set with nil value produces valid property list.
-Regression test for: (tp-set \"emacs\" 'face nil) erroring with
-\"Odd length text property list\"."
- (tp-test-with-temp-buffer
- (let ((result (tp-set "emacs" 'face nil)))
- ;; Result should be #("emacs" 0 5 (face nil))
- (should (stringp result))
- (should (eq (get-text-property 0 'face result) nil))
- ;; Verify the property list is valid (has even length)
- (let ((props (text-properties-at 0 result)))
- (should (= (% (length props) 2) 0))))))
-
-(ert-deftest tp-test-set-with-nil-value-in-middle ()
- "Test tp-set with nil value in middle of property list."
- (tp-test-with-temp-buffer
- (let ((result (tp-set "emacs" 'face 'bold 'help-echo nil 'display "test")))
- ;; Result should have face=bold, help-echo=nil, display="test"
- (should (eq (get-text-property 0 'face result) 'bold))
- (should (eq (get-text-property 0 'help-echo result) nil))
- (should (equal (get-text-property 0 'display result) "test")))))
-
-(ert-deftest tp-test-set-with-multiple-nil-values ()
- "Test tp-set with multiple nil values."
- (tp-test-with-temp-buffer
- (let ((result (tp-set "emacs" 'face nil 'help-echo nil)))
- (should (eq (get-text-property 0 'face result) nil))
- (should (eq (get-text-property 0 'help-echo result) nil)))))
-
-(ert-deftest tp-test-reset-with-nil-value ()
- "Test tp-reset with nil value works correctly."
- (tp-test-with-temp-buffer
- (let ((result (tp-reset "emacs" 'face nil)))
- ;; Result should have face=nil
- (should (eq (get-text-property 0 'face result) nil)))))
-
-(ert-deftest tp-test-add-with-nil-value ()
- "Test tp-add with nil value works correctly."
- (tp-test-with-temp-buffer
- (let ((result (tp-add "emacs" 'face nil)))
- ;; Result should have face=nil
- (should (eq (get-text-property 0 'face result) nil)))))
-
-(ert-deftest tp-test-set-nil-value-in-buffer ()
- "Test tp-set with nil value in buffer region."
- (tp-test-with-temp-buffer
- (insert "emacs")
- (tp-set 1 6 '(face nil))
- (should (eq (tp-at 1 'face) nil))))
-
-;;; ============================================================
-;;; Non-Destructive String Modification Tests
-;;; ============================================================
-
-(ert-deftest tp-test-set-preserves-text-property-intervals ()
- "Test that tp-set preserves text property intervals when adding new properties.
-When a string has different properties at different positions, adding a new
-property should preserve the original interval structure.
-
-Test string: \" button \" (8 characters, positions 0-7)
- - Position 0-1: display property (first space character)
- - Position 1-7: no display property (text \"button \")
- - Position 7-8: display property (last space character)"
- (let ((original #(" button " 0 1 (display (space :width (4)))
- 7 8 (display (space :width (4))))))
- (let ((result (tp-set original 'face '(:foreground "red"))))
- ;; Result should be a new string with properties
- (should (stringp result))
- ;; Result should NOT be the same object as original
- (should (not (eq original result)))
- ;; Original should NOT be modified
- (should (null (get-text-property 0 'face original)))
- ;; Result should have face property everywhere
- (should (equal (get-text-property 0 'face result) '(:foreground "red")))
- (should (equal (get-text-property 4 'face result) '(:foreground "red")))
- (should (equal (get-text-property 7 'face result) '(:foreground "red")))
- ;; Result should preserve display property at original positions
- (should (equal (get-text-property 0 'display result) '(space :width (4))))
- (should (null (get-text-property 2 'display result))) ;; No display at position 2
- (should (equal (get-text-property 7 'display result) '(space :width (4)))))))
-
-(ert-deftest tp-test-set-does-not-modify-original-string ()
- "Test that tp-set returns a new string and does not modify the original."
- (let ((original "Hello"))
- (let ((result (tp-set original 'face 'bold)))
- ;; Result should be a new string with properties
- (should (stringp result))
- (should (eq (get-text-property 0 'face result) 'bold))
- ;; Original should NOT be modified (no properties)
- (should (null (get-text-property 0 'face original)))
- ;; Strings should not be eq (different objects)
- (should (not (eq original result))))))
-
-(ert-deftest tp-test-reset-does-not-modify-original-string ()
- "Test that tp-reset returns a new string and does not modify the original."
- (let ((original "Hello"))
- (let ((result (tp-reset original 'face 'bold)))
- ;; Result should be a new string with properties
- (should (stringp result))
- (should (eq (get-text-property 0 'face result) 'bold))
- ;; Original should NOT be modified (no properties)
- (should (null (get-text-property 0 'face original)))
- ;; Strings should not be eq (different objects)
- (should (not (eq original result))))))
-
-(ert-deftest tp-test-add-does-not-modify-original-string ()
- "Test that tp-add returns a new string and does not modify the original."
- (let ((original "Hello"))
- (let ((result (tp-add original 'face 'bold)))
- ;; Result should be a new string with properties
- (should (stringp result))
- (should (eq (get-text-property 0 'face result) 'bold))
- ;; Original should NOT be modified (no properties)
- (should (null (get-text-property 0 'face original)))
- ;; Strings should not be eq (different objects)
- (should (not (eq original result))))))
-
-(ert-deftest tp-test-remove-does-not-modify-original-string ()
- "Test that tp-remove returns a new string and does not modify the original."
- ;; First create a propertized string (using propertize to create the original)
- (let ((original (propertize "Hello" 'face 'bold 'help-echo "tip")))
- (let ((result (tp-remove original 'face)))
- ;; Result should be a new string without face property
- (should (stringp result))
- (should (null (get-text-property 0 'face result)))
- (should (equal (get-text-property 0 'help-echo result) "tip"))
- ;; Original should still have face property
- (should (eq (get-text-property 0 'face original) 'bold))
- ;; Strings should not be eq (different objects)
- (should (not (eq original result))))))
-
-(ert-deftest tp-test-set-region-modifies-original-string ()
- "Test that tp-set with region form DOES modify the original string.
-The region form (tp-set START END PROPS STRING) modifies the string in-place."
- (let ((original (copy-sequence "Hello World")))
- (let ((result (tp-set 0 5 '(face bold) original)))
- ;; Result should be the same object as original (modified in-place)
- (should (eq result original))
- ;; Both should have the face property
- (should (eq (get-text-property 0 'face result) 'bold))
- (should (eq (get-text-property 0 'face original) 'bold)))))
-
-(ert-deftest tp-test-match-set-does-not-modify-original-string ()
- "Test that tp-match-set returns a new string and does not modify the original."
- (let ((original "Hello World"))
- (let ((result (tp-match-set "Hello" '(face bold) original)))
- ;; Result should be a new string with properties
- (should (stringp result))
- (should (eq (get-text-property 0 'face result) 'bold))
- ;; Original should NOT be modified (no properties)
- (should (null (get-text-property 0 'face original)))
- ;; Strings should not be eq (different objects)
- (should (not (eq original result))))))
-
-(ert-deftest tp-test-regexp-set-does-not-modify-original-string ()
- "Test that tp-regexp-set returns a new string and does not modify the original."
- (let ((original "abc 123 def"))
- (let ((result (tp-regexp-set "[0-9]+" '(face bold) original)))
- ;; Result should be a new string with properties on the match
- (should (stringp result))
- (should (eq (get-text-property 4 'face result) 'bold))
- ;; Original should NOT be modified (no properties)
- (should (null (get-text-property 4 'face original)))
- ;; Strings should not be eq (different objects)
- (should (not (eq original result))))))
-
-(ert-deftest tp-test-remove-custom-layer ()
- "Test that tp-remove correctly removes custom text property layers.
-When a layer is removed, only its face contribution should be removed,
-not the entire face property."
- ;; First define the custom layer
- (tp-layer-reset)
- (eval '(define-tp tp-delete (color)
- `(face (:strike-through ,color))))
- ;; Test with entire string form
- (let* ((str "emacs")
- (str-with-props (tp-set str 'face 'bold 'tp-delete t))
- (result (tp-remove str-with-props 'tp-delete)))
- ;; Original should still have the properties
- (should (get-text-property 0 'face str-with-props))
- ;; Result should have face 'bold (only the tp-delete contribution removed)
- (should (equal (get-text-property 0 'face result) 'bold))
- ;; Result should not have tp-delete property
- (should (null (get-text-property 0 'tp-delete result)))
- ;; Result should not have tp-name property
- (should (null (get-text-property 0 'tp-name result)))))
-
-(ert-deftest tp-test-remove-custom-layer-preserves-other-props ()
- "Test that tp-remove with layer name preserves other properties.
-When the layer property is set (via mixed syntax), its face contribution
-can be tracked and removed."
- (tp-layer-reset)
- (eval '(define-tp tp-delete (color)
- `(face (:strike-through ,color))))
- ;; Test with mixed syntax - set layer alongside other properties
- ;; This allows tracking of the layer property
- (let* ((str "emacs")
- (str-with-props (tp-set str 'help-echo "test" 'tp-delete "red"))
- (result (tp-remove str-with-props 'tp-delete)))
- ;; help-echo should still be present
- (should (equal (get-text-property 0 'help-echo result) "test"))
- ;; face (from tp-delete) should be removed
- (should (null (get-text-property 0 'face result)))
- ;; tp-delete property should be removed
- (should (null (get-text-property 0 'tp-delete result)))))
+ (should (equal (get-text-property 0 'help-echo result) "tip"))))
+
+(ert-deftest tp-test-set-string-range-mutates-in-place ()
+ "Explicit string ranges retain the historical in-place contract."
+ (let ((text (copy-sequence "hello")))
+ (should (eq (tp-set 1 4 '(face italic) text) text))
+ (should-not (get-text-property 0 'face text))
+ (should (eq (get-text-property 1 'face text) 'italic))
+ (should-not (get-text-property 4 'face text))))
+
+(ert-deftest tp-test-reset-replaces-only-the-requested-range ()
+ "Reset removes prior properties inside its range and nowhere else."
+ (tp-test-with-temp-buffer
+ (insert "abcdef")
+ (put-text-property 1 7 'help-echo "host")
+ (tp-reset 2 5 '(face bold))
+ (should (equal (get-text-property 1 'help-echo) "host"))
+ (should-not (get-text-property 2 'help-echo))
+ (should (eq (get-text-property 2 'face) 'bold))
+ (should (equal (get-text-property 5 'help-echo) "host"))))
+
+(ert-deftest tp-test-add-composes-face-and-nested-plists ()
+ "Add uses the shared native property merge policy."
+ (let* ((source (propertize "x" 'face 'bold
+ 'display '(:width 1 :height 2)))
+ (result (tp-add source
+ 'face 'italic
+ 'display '(:width 3))))
+ (should (equal (get-text-property 0 'face result) '(italic bold)))
+ (should
+ (equal (get-text-property 0 'display result)
+ '(:width 3 :height 2)))))
+
+(ert-deftest tp-test-remove-top-level-and-nested-properties ()
+ "Remove handles top-level, sub-property, and nested paths."
+ (let* ((source (propertize
+ "x" 'face '(:foreground "red"
+ :underline (:style wave :color "blue"))
+ 'help-echo "tip"))
+ (no-help (tp-remove source 'help-echo))
+ (no-underline-style
+ (tp-remove source 'face :underline '(:style))))
+ (should-not (get-text-property 0 'help-echo no-help))
+ (should
+ (equal (get-text-property 0 'face no-underline-style)
+ '(:foreground "red" :underline (:color "blue"))))))
+
+(ert-deftest tp-test-clear-defaults-to-target-bounds ()
+ "Clear removes every property while preserving text."
+ (let ((text (propertize "hello" 'face 'bold)))
+ (tp-clear nil nil text)
+ (should (equal text "hello"))
+ (should-not (text-properties-at 0 text))))
+
+(ert-deftest tp-test-native-recipe-application-is-one-shot ()
+ "Applying a named recipe creates no object, binding, anchor, or mount."
+ (tp-test-with-temp-buffer
+ (define-tp tp-test-warning (color)
+ `(face (:foreground ,color) help-echo "warning"))
+ (insert "warning")
+ (let ((before (tp-reactive-counters)))
+ (tp-set 1 8 '(tp-test-warning "orange"))
+ (should (equal (get-text-property 1 'face)
+ '(:foreground "orange")))
+ (should (equal (tp-reactive-counters) before)))))
+
+(ert-deftest tp-test-match-and-regexp-use-the-same-direct-core ()
+ "Literal and regexp application share recipe projection semantics."
+ (tp-test-with-temp-buffer
+ (define-tp tp-test-hit () '(face bold))
+ (insert "one two one")
+ (should (equal (tp-match-set "one" 'tp-test-hit)
+ '((1 . 4) (9 . 12))))
+ (should (equal (tp-regexp-add "t.o" '(help-echo "two"))
+ '((5 . 8))))
+ (should (eq (get-text-property 1 'face) 'bold))
+ (should (equal (get-text-property 5 'help-echo) "two"))))
+
+(ert-deftest tp-test-property-navigation-keeps-string-buffer-parity ()
+ "Forward and backward search report equivalent string/buffer matches."
+ (let ((text (tp-set "abcd" 'face 'bold)))
+ (with-temp-buffer
+ (insert text)
+ (goto-char (point-min))
+ (let ((buffer-match (tp-forward 'face 'bold)))
+ (should (= (prop-match-beginning buffer-match) 1))
+ (should (= (prop-match-end buffer-match) 5))
+ (should (eq (prop-match-value buffer-match) 'bold)))
+ (should (equal (tp-forward 'face 'bold text) '((0 4 bold))))
+ (goto-char (point-max))
+ (let ((buffer-match (tp-backward 'face 'bold)))
+ (should (= (prop-match-beginning buffer-match) 1))
+ (should (= (prop-match-end buffer-match) 5))
+ (should (eq (prop-match-value buffer-match) 'bold))))))
(provide 'tp-tests)
;;; tp-tests.el ends here
diff --git a/tp-benchmark.el b/tp-benchmark.el
index cb29b5d..163ec21 100644
--- a/tp-benchmark.el
+++ b/tp-benchmark.el
@@ -7,7 +7,7 @@
;;; Commentary:
;; Run with:
-;; emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run
+;; Emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run
;;; Code:
@@ -20,9 +20,6 @@
(defconst tp-benchmark--generated-seed 8675309
"Printed generated seed. Fixed so the benchmark output is reproducible.")
-(defvar tp-bench-fanout-color nil
- "Reactive color variable used by `tp-benchmark-run'.")
-
(defun tp-benchmark--print (plist)
"Print one benchmark row from PLIST."
(princ
@@ -32,7 +29,9 @@
(format "%s=%S" (substring (symbol-name key) 1)
(plist-get plist key)))
'(:scenario :status :fixture :seed :requested :actual :operations
- :scanned :changed :refreshed :elapsed :gcs :note)
+ :objects :subscribers :invalidated :recomputed :skipped
+ :text-operations :property-operations :touched :revision :published
+ :elapsed :gcs :note)
" ")
"\n")))
@@ -49,7 +48,10 @@
result))
(defun tp-benchmark--measure (scenario fixture seed requested actual body)
- "Measure BODY after GC and print a benchmark row."
+ "Measure BODY for SCENARIO and print a benchmark row.
+
+SCENARIO, FIXTURE, SEED, REQUESTED and ACTUAL identify the row metadata.
+BODY performs the timed operation."
(garbage-collect)
(let* ((gc-start gcs-done)
(start (float-time))
@@ -62,19 +64,12 @@
result
(list :elapsed elapsed :gcs (- gcs-done gc-start) :note nil)))))
-(defun tp-benchmark--blocked (scenario fixture seed requested note)
- "Print a blocked benchmark row."
- (tp-benchmark--print
- (list :scenario scenario :status 'blocked :fixture fixture :seed seed
- :requested requested :actual 0 :operations 0 :scanned 0
- :changed 0 :refreshed 0 :elapsed nil :gcs 0 :note note)))
-
(defun tp-benchmark--large-text (size seed)
"Benchmark large text property set/search for SIZE and SEED."
(let ((text (tp-benchmark--random-string size seed)))
(tp-set 0 size '(tp-bench t) text)
(unless (equal (tp-search text 'tp-bench t) (list (list 0 size t)))
- (error "large-text correctness failed"))
+ (error "Large-text correctness failed"))
(set-text-properties 0 size nil text)
(tp-benchmark--measure
'large-text 'string seed size size
@@ -82,118 +77,230 @@
(tp-set 0 size '(tp-bench t) text)
(let ((matches (tp-search text 'tp-bench t)))
(unless (equal matches (list (list 0 size t)))
- (error "timed large-text correctness failed"))
- (list :operations 2 :scanned size :changed size
- :refreshed 0 :note (length matches)))))))
+ (error "Timed large-text correctness failed"))
+ (list :operations 2 :touched size :note (length matches)))))))
(defun tp-benchmark--fragmented (runs seed)
- "Benchmark RUNS fragmented property intervals using SEED."
+ "Measure fragmented property intervals using SEED.
+RUNS is the number of intervals."
(let ((text (make-string runs ?x)))
(cl-loop for i below runs
when (zerop (mod i 2))
do (put-text-property i (1+ i) 'tp-bench i text))
(unless (= (length (tp-search text 'tp-bench)) (/ (1+ runs) 2))
- (error "fragmented correctness failed"))
+ (error "Fragmented correctness failed"))
(tp-benchmark--measure
'fragmented 'string seed runs runs
(lambda ()
(let ((matches (tp-search text 'tp-bench)))
- (list :operations 1 :scanned runs :changed (length matches)
- :refreshed 0 :note nil))))))
+ (list :operations 1 :touched runs :note (length matches)))))))
-(defun tp-benchmark--define-stack-layers (depth)
- "Define DEPTH benchmark stack layers."
- (cl-loop for i below depth
- do (eval `(define-tp ,(intern (format "tp-bench-stack-%d" i))
- () '(face bold)))))
+(defun tp-benchmark--retained-producer (entries)
+ "Return a retained content producer for ENTRIES.
+Each entry is a cons whose car is a stable key and whose cdr is text."
+ (lambda (context)
+ (let ((root (tp-object-ensure context nil 'root 'group)))
+ (tp-surface-plan-create
+ :key 'root
+ :kind 'group
+ :children
+ (mapcar
+ (lambda (entry)
+ (tp-object-ensure context root (car entry) 'text)
+ (tp-surface-plan-create
+ :key (car entry) :kind 'text :text (cdr entry)
+ :capability 'content))
+ entries)
+ :capability 'content))))
-(defun tp-benchmark--stack-depth (depth seed)
- "Benchmark stack operations at DEPTH using SEED."
- (tp-layer-reset)
- (tp-benchmark--define-stack-layers depth)
- (with-temp-buffer
- (insert (make-string 2000 ?s))
- (cl-loop for i below depth
- do (tp-push-layer 1 2001
- (intern (format "tp-bench-stack-%d" i))))
- (unless (= (tp-layer-count 1 2001) depth)
- (error "stack-depth correctness failed"))
- (set-text-properties 1 2001 nil)
- (tp-benchmark--measure
- 'stack-depth 'buffer seed depth depth
- (lambda ()
- (cl-loop for i below depth
- do (tp-push-layer 1 2001
- (intern (format "tp-bench-stack-%d" i))))
- (unless (= (tp-layer-count 1 2001) depth)
- (error "timed stack-depth correctness failed"))
- (let ((top (tp-layer-top 1 2001)))
- (list :operations (1+ depth) :scanned 2000 :changed 2000
- :refreshed 0 :note top))))))
+(defun tp-benchmark--retained-reconcile (count seed)
+ "Benchmark retained keyed reconciliation of COUNT items using SEED."
+ (let* ((entries
+ (cl-loop for index below count
+ collect (cons index (format "%d " index))))
+ (changed-key (mod seed count))
+ (updated
+ (reverse
+ (mapcar
+ (lambda (entry)
+ (if (= (car entry) changed-key)
+ (cons (car entry) (format "changed-%d " seed))
+ entry))
+ entries)))
+ (buffer (generate-new-buffer " *tp-benchmark-retained*"))
+ surface object)
+ (unwind-protect
+ (progn
+ (setq surface
+ (tp-surface-mount
+ buffer (tp-benchmark--retained-producer entries)
+ '(:capability content))
+ object (tp-object-resolve surface (list 'root changed-key)))
+ (tp-benchmark--measure
+ 'retained-keyed-reconcile 'buffer seed count count
+ (lambda ()
+ (let ((report
+ (tp-surface-update
+ surface (tp-benchmark--retained-producer updated))))
+ (unless (eq object
+ (tp-object-resolve surface
+ (list 'root changed-key)))
+ (error "Retained object identity changed"))
+ (with-current-buffer buffer
+ (unless (equal (buffer-string)
+ (mapconcat #'cdr updated ""))
+ (error "Retained reconciliation published wrong text")))
+ (unless (and (zerop (plist-get report :created-objects))
+ (zerop (plist-get report :removed-objects)))
+ (error "Retained reconciliation replaced stable objects"))
+ (list :operations 1
+ :objects (plist-get report :reconciled-objects)
+ :text-operations (plist-get report :text-operations)
+ :property-operations
+ (plist-get report :property-operations)
+ :touched (plist-get report :touched-characters)
+ :revision (plist-get report :new-revision)
+ :published 1
+ :note (format "moved=%d"
+ (plist-get report :moved-objects)))))))
+ (when (and surface (tp-surface-live-p surface))
+ (tp-surface-unmount surface))
+ (when (buffer-live-p buffer)
+ (kill-buffer buffer)))))
-(defun tp-benchmark--define-fanout-layer (seed)
- "Define one reactive layer for SEED."
- (set 'tp-bench-fanout-color "red")
- (eval '(define-tp tp-bench-fanout ()
- :props '(face (:foreground $tp-bench-fanout-color))
- :data '((tp-bench-fanout-color . "red"))))
- seed)
+(defun tp-benchmark--sparse-signal-update (unrelated-count seed)
+ "Benchmark one exact signal update beside UNRELATED-COUNT bindings.
+SEED supplies the target signal value."
+ (let* ((target (tp-signal-create 0))
+ (unrelated (tp-signal-create 0))
+ (target-owner (list 'target seed))
+ (unrelated-owner (list 'unrelated seed))
+ (target-calls 0)
+ (unrelated-calls 0))
+ (unwind-protect
+ (progn
+ (tp-with-transaction
+ (tp-bind target-owner '(benchmark . target)
+ (lambda ()
+ (cl-incf target-calls)
+ (tp-signal-read target)))
+ (dotimes (index unrelated-count)
+ (tp-bind unrelated-owner (list 'benchmark index)
+ (lambda ()
+ (cl-incf unrelated-calls)
+ (tp-signal-read unrelated)))))
+ (unless (and (= (tp-signal-subscriber-count target) 1)
+ (= (tp-signal-subscriber-count unrelated)
+ unrelated-count))
+ (error "Sparse dependency graph has wrong subscriber counts"))
+ (tp-reactive-reset-counters)
+ (tp-benchmark--measure
+ 'signal-sparse-update 'binding-graph seed
+ unrelated-count unrelated-count
+ (lambda ()
+ (tp-signal-set target (1+ seed))
+ (unless (and (= target-calls 2)
+ (= unrelated-calls unrelated-count))
+ (error "Sparse update recomputed unrelated bindings"))
+ (let ((counters (tp-reactive-counters)))
+ (unless (and (= (plist-get counters :invalidated) 1)
+ (= (plist-get counters :recomputed) 1))
+ (error "Sparse update did not stay dependency-local"))
+ (list :operations 1
+ :objects (1+ unrelated-count)
+ :subscribers (tp-signal-subscriber-count target)
+ :invalidated (plist-get counters :invalidated)
+ :recomputed (plist-get counters :recomputed)
+ :skipped (plist-get counters :skipped)
+ :published 0
+ :note "unrelated-bindings-untouched")))))
+ (tp-binding-dispose-owner target-owner)
+ (tp-binding-dispose-owner unrelated-owner)
+ (when (tp-signal-live-p target)
+ (tp-signal-dispose target))
+ (when (tp-signal-live-p unrelated)
+ (tp-signal-dispose unrelated)))))
-(defun tp-benchmark--reactive-fanout (requested seed)
- "Benchmark reactive fanout REQUESTED using SEED."
- (let ((actual (min requested 200)))
- (tp-layer-reset)
- (tp-reactive-reset)
- (tp-benchmark--define-fanout-layer seed)
- (let ((buffers nil))
- (unwind-protect
- (progn
- (dotimes (i actual)
- (let ((buf (generate-new-buffer
- (format " *tp-bench-fanout-%d*" i))))
- (push buf buffers)
- (with-current-buffer buf
- (insert "x")
- (tp-set 1 2 'tp-bench-fanout))))
- (setq tp-bench-fanout-color "blue")
- (with-current-buffer (car buffers)
- (unless (equal (plist-get (get-text-property 1 'face)
- :foreground)
- "blue")
- (error "reactive-fanout correctness failed")))
+(defun tp-benchmark--reactive-surface-producer (signal)
+ "Return a retained producer backed by a binding to SIGNAL."
+ (let ((compute (lambda () (tp-signal-read signal))))
+ (lambda (context)
+ (let* ((object (tp-object-ensure context nil 'value 'text))
+ (binding (tp-bind object '(benchmark . value) compute)))
+ (tp-surface-plan-create
+ :key 'value :kind 'text
+ :text (number-to-string (tp-binding-read binding))
+ :capability 'content)))))
+
+(defun tp-benchmark--batched-and-noop-publication (writes seed)
+ "Benchmark WRITES batched writes and equal no-ops using SEED."
+ (let* ((signal (tp-signal-create seed))
+ (buffer (generate-new-buffer " *tp-benchmark-batch*"))
+ (producer (tp-benchmark--reactive-surface-producer signal))
+ surface)
+ (unwind-protect
+ (progn
+ (setq surface
+ (tp-surface-mount buffer producer '(:capability content)))
+ (let ((revision (tp-surface-revision surface)))
+ (tp-reactive-reset-counters)
(tp-benchmark--measure
- 'reactive-fanout 'buffers seed requested actual
+ 'transaction-batch 'retained-surface seed writes writes
(lambda ()
- (setq tp-bench-fanout-color "green")
- (list :operations 1 :scanned actual :changed actual
- :refreshed actual
- :note (format "requested=%d actual=%d"
- requested actual)))))
- (mapc (lambda (buf)
- (when (buffer-live-p buf) (kill-buffer buf)))
- buffers)))))
-
-(defun tp-benchmark--theme-refresh (seed)
- "Benchmark current theme managed refresh hook using SEED."
- (if (not (fboundp 'tp--refresh-managed-after-theme-change))
- (tp-benchmark--blocked
- 'theme-managed-refresh 'buffer seed 1
- "tp--refresh-managed-after-theme-change unavailable")
- (tp-layer-reset)
- (with-temp-buffer
- (insert (make-string 1000 ?t))
- (define-tp tp-bench-theme () '(face (:foreground "red")))
- (tp-push-layer 1 1001 'tp-bench-theme)
- (tp--refresh-managed-after-theme-change 'benchmark)
- (unless tp-theme-last-refreshed-ranges
- (error "theme-refresh correctness failed"))
- (tp-benchmark--measure
- 'theme-managed-refresh 'buffer seed 1 1
- (lambda ()
- (tp--refresh-managed-after-theme-change 'benchmark)
- (list :operations 1 :scanned 1000 :changed 0
- :refreshed (length tp-theme-last-refreshed-ranges)
- :note tp-theme-last-refresh-mode))))))
+ (tp-with-transaction
+ (dotimes (index writes)
+ (tp-signal-set signal (+ seed index 1))))
+ (let* ((report (tp-surface-report surface))
+ (counters (tp-reactive-counters))
+ (expected (+ seed writes)))
+ (with-current-buffer buffer
+ (unless (equal (buffer-string)
+ (number-to-string expected))
+ (error "Batched publication produced wrong text")))
+ (unless (and (= (tp-surface-revision surface)
+ (1+ revision))
+ (= (plist-get report :candidate-source-writes) 1)
+ (= (plist-get counters :recomputed) 2))
+ (error "Batched writes were not committed once"))
+ (list :operations writes
+ :objects (plist-get report :reconciled-objects)
+ :invalidated (plist-get counters :invalidated)
+ :recomputed (plist-get counters :recomputed)
+ :skipped (plist-get counters :skipped)
+ :text-operations (plist-get report :text-operations)
+ :property-operations
+ (plist-get report :property-operations)
+ :touched (plist-get report :touched-characters)
+ :revision (tp-surface-revision surface)
+ :published 1
+ :note "one-surface-commit")))))
+ (let ((revision (tp-surface-revision surface))
+ (value (tp-signal-peek signal)))
+ (tp-reactive-reset-counters)
+ (tp-benchmark--measure
+ 'equal-write-noop 'retained-surface seed writes writes
+ (lambda ()
+ (tp-with-transaction
+ (dotimes (_index writes)
+ (tp-signal-set signal value)))
+ (let ((counters (tp-reactive-counters)))
+ (unless (and (= (tp-surface-revision surface) revision)
+ (equal counters
+ '(:invalidated 0 :recomputed 0 :skipped 0
+ :subscription-added 0
+ :subscription-removed 0)))
+ (error "Equal writes changed retained runtime state"))
+ (list :operations writes
+ :subscribers (tp-signal-subscriber-count signal)
+ :invalidated 0 :recomputed 0 :skipped 0
+ :revision revision :published 0
+ :note "revision-unchanged"))))))
+ (when (and surface (tp-surface-live-p surface))
+ (tp-surface-unmount surface))
+ (when (tp-signal-live-p signal)
+ (tp-signal-dispose signal))
+ (when (buffer-live-p buffer)
+ (kill-buffer buffer)))))
(defun tp-benchmark-run ()
"Run tp benchmarks in batch mode."
@@ -207,11 +314,12 @@
(tp-benchmark--large-text size seed))
(dolist (runs '(1000 10000 50000))
(tp-benchmark--fragmented runs seed))
- (dolist (depth '(1 5 20 50))
- (tp-benchmark--stack-depth depth seed))
- (dolist (fanout '(1 10 100 500))
- (tp-benchmark--reactive-fanout fanout seed))
- (tp-benchmark--theme-refresh seed)))
+ (dolist (count '(10 100 1000))
+ (tp-benchmark--retained-reconcile count seed))
+ (dolist (unrelated-count '(1 100 10000))
+ (tp-benchmark--sparse-signal-update unrelated-count seed))
+ (dolist (writes '(1 100 10000))
+ (tp-benchmark--batched-and-noop-publication writes seed))))
(provide 'tp-benchmark)
;;; tp-benchmark.el ends here
diff --git a/tp-builtins.el b/tp-builtins.el
index 5b4ac21..c89dcf7 100644
--- a/tp-builtins.el
+++ b/tp-builtins.el
@@ -203,48 +203,5 @@ the gallery window."
keymap)
rear-nonsticky (keymap))))
-(defun tp--managed-theme-ranges ()
- "Return managed buffer ranges and the layer names found in them."
- (let (ranges)
- (dolist (buffer (buffer-list))
- (when (buffer-live-p buffer)
- (tp--map-intervals
- buffer nil nil
- (lambda (start end props)
- (let ((names (delq nil
- (cons (plist-get props 'tp-name)
- (mapcar
- (lambda (entry)
- (plist-get entry 'tp-name))
- (plist-get props 'tp-layers))))))
- (when names
- (push (list :buffer buffer :start start :end end
- :layers (delete-dups names))
- ranges)))))))
- (nreverse ranges)))
-
-(defun tp--refresh-managed-after-theme-change (_source)
- "Conservatively refresh all managed layers after a theme change."
- (let* ((ranges (tp--managed-theme-ranges))
- (layers (delete-dups
- (apply #'append
- (mapcar (lambda (range)
- (copy-sequence
- (plist-get range :layers)))
- ranges))))
- errors)
- (dolist (layer layers)
- (condition-case condition
- (tp--layer-refresh layer)
- (error
- (push (list :kind 'theme-refresh :layer layer
- :condition condition)
- errors))))
- (setq tp-theme-last-refresh-mode :conservative
- tp-theme-last-refreshed-ranges ranges
- tp-theme-last-refresh-errors (nreverse errors))))
-
-(add-hook 'tp-theme-change-hook #'tp--refresh-managed-after-theme-change)
-
(provide 'tp-builtins)
;;; tp-builtins.el ends here
diff --git a/tp-core.el b/tp-core.el
index 1c59b6f..4cb5a52 100644
--- a/tp-core.el
+++ b/tp-core.el
@@ -252,8 +252,10 @@ OBJECT can be string or buffer; nil means current buffer."
(null (object-intervals (or object (current-buffer)))))
(defun tp-plist (start-or-string &optional end object)
- "Return merged plist of all properties from START to END in OBJECT.
-With single STRING argument, return properties of entire string."
+ "Return merged plist of all properties from START-OR-STRING to END in OBJECT.
+
+When START-OR-STRING is a string, return properties of the whole string.
+Otherwise, START-OR-STRING and END define the range."
(let (start-pos end-pos obj)
(if (stringp start-or-string)
(setq start-pos 0
@@ -269,6 +271,25 @@ With single STRING argument, return properties of entire string."
do (setq result (plist-put result key val)))))
result)))
+(defun tp--copy-property-value (value)
+ "Return a defensive copy of mutable containers in property VALUE.
+Cons cells, strings, and vectors are copied recursively. Functions, records,
+and other opaque objects keep their identity; functions are never executed."
+ (cond
+ ((functionp value) value)
+ ((recordp value) value)
+ ((consp value)
+ (cons (tp--copy-property-value (car value))
+ (tp--copy-property-value (cdr value))))
+ ((stringp value) (copy-sequence value))
+ ((vectorp value)
+ (let ((copy (copy-sequence value)))
+ (dotimes (index (length copy))
+ (aset copy index
+ (tp--copy-property-value (aref copy index))))
+ copy))
+ (t value)))
+
(defun tp--deep-merge-plist (base new)
"Deep merge NEW plist into BASE plist.
For nested plists (starting with keyword), recursively merge.
@@ -608,81 +629,6 @@ Supports plists, alists, and list-of-keys extraction."
(t nil))))
(tp--get-nested next-value rest))))
-(defun tp--reactive-symbol-p (sym)
- "Return non-nil if SYM is a reactive variable symbol (starts with $)."
- (and (symbolp sym)
- (string-prefix-p "$" (symbol-name sym))))
-
-(defun tp--reactive-var-symbol (sym)
- "Convert a reactive symbol SYM (e.g., $foo) to its variable symbol (e.g., foo).
-Returns nil if SYM is not a reactive symbol."
- (when (tp--reactive-symbol-p sym)
- (intern (substring (symbol-name sym) 1))))
-
-(defun tp--collect-reactive-symbols (form)
- "Recursively collect all reactive symbols ($-prefixed) from FORM.
-Returns a list of reactive symbols found."
- (cond
- ((tp--reactive-symbol-p form)
- (list form))
- ((consp form)
- (append (tp--collect-reactive-symbols (car form))
- (tp--collect-reactive-symbols (cdr form))))
- (t nil)))
-
-(defun tp--extract-reactive-value (val reactive-var)
- "Extract only the parts of VAL that use REACTIVE-VAR.
-If VAL is a plist, recursively extract only the key-value pairs
-containing REACTIVE-VAR.
-If VAL directly contains REACTIVE-VAR, return VAL as-is.
-REACTIVE-VAR should be the $-prefixed symbol (e.g., $my-color)."
- (cond
- ;; If val is the reactive var itself, return it
- ((eq val reactive-var) val)
- ;; If val is a plist (starts with a keyword), extract reactive parts recursively
- ((and (listp val) (keywordp (car val)))
- (let ((result nil))
- (cl-loop for (key subval) on val by #'cddr
- when (member reactive-var (tp--collect-reactive-symbols subval))
- do (setq result
- (plist-put result key
- (tp--extract-reactive-value subval reactive-var))))
- result))
- ;; Otherwise return val as-is if it contains the reactive var
- (t val)))
-
-(defun tp--extract-reactive-props (plist reactive-var)
- "Extract only the properties from PLIST that use REACTIVE-VAR.
-Returns a plist containing only the key-value pairs that reference REACTIVE-VAR.
-For nested plists, only the sub-properties containing REACTIVE-VAR are included.
-REACTIVE-VAR should be the $-prefixed symbol (e.g., $my-color)."
- (let ((result nil))
- (cl-loop for (key val) on plist by #'cddr
- when (member reactive-var (tp--collect-reactive-symbols val))
- do (setq result
- (plist-put result key
- (tp--extract-reactive-value val reactive-var))))
- result))
-
-(defun tp--resolve-reactive-symbols (form &optional override-alist)
- "Recursively resolve all reactive symbols in FORM to their values.
-Reactive symbols ($foo) are replaced with the value of the variable foo.
-OVERRIDE-ALIST is an optional alist of (SYMBOL . VALUE) pairs that
-override the current variable values (used during watcher callbacks)."
- (cond
- ((tp--reactive-symbol-p form)
- (let* ((var-sym (tp--reactive-var-symbol form))
- (override (assoc var-sym override-alist)))
- (if override
- (cdr override)
- (if (boundp var-sym)
- (symbol-value var-sym)
- nil))))
- ((consp form)
- (cons (tp--resolve-reactive-symbols (car form) override-alist)
- (tp--resolve-reactive-symbols (cdr form) override-alist)))
- (t form)))
-
(defun tp--prepend-face (new-face existing-face)
"Prepend NEW-FACE to EXISTING-FACE for the face property.
Returns a face value where NEW-FACE takes precedence.
@@ -838,16 +784,10 @@ order."
(defun tp-intervals-map (function start end &optional object absolute)
"Apply FUNCTION to each property interval of [START, END) in OBJECT.
-FUNCTION is called with (I-START I-END TOP-PROPS BELOW-PROPS-LST) for
-every interval `tp-intervals' reports, splitting the layer-stack
-bookkeeping out of the raw properties:
-- TOP-PROPS is the interval's property plist with the `tp-layers'
- entry removed: the directly rendered properties.
-- BELOW-PROPS-LST is the value of the interval's `tp-layers'
- property: the list of stored layer plists (normally the layers
- buried below the rendered top layer; while any layer is hidden it
- holds the whole ordered stack - see `tp-layer-stack-at' for the
- decoded view). It is nil when the interval carries no layer stack.
+FUNCTION is called with (I-START I-END PROPERTIES RESERVED) for every
+interval `tp-intervals' reports. PROPERTIES is the direct property plist and
+RESERVED is nil. The fourth argument is retained so existing stateless callers
+do not need an arity change; TP no longer stores an inline layer stack.
I-START/I-END follow `tp-intervals' coordinates: for buffers they
are by default relative to START (0-based offsets, the legacy
@@ -861,18 +801,7 @@ Returns the list of FUNCTION's non-nil results, in interval order
nil
(mapcar
(lambda (tp)
- (let* ((interval-start (nth 0 tp)) ;; start from 0
- (interval-end (nth 1 tp))
- (interval-props (nth 2 tp))
- (top-props
- (if-let ((idx (cl-position 'tp-layers interval-props)))
- (append (cl-subseq interval-props 0 idx)
- (nthcdr (+ idx 2) interval-props))
- interval-props))
- (below-props-lst (plist-get interval-props 'tp-layers)))
- (funcall function
- interval-start interval-end
- top-props below-props-lst)))
+ (funcall function (nth 0 tp) (nth 1 tp) (nth 2 tp) nil))
(tp-intervals start end object absolute))))
(provide 'tp-core)
diff --git a/tp-layer.el b/tp-layer.el
index 5719312..76b6b52 100644
--- a/tp-layer.el
+++ b/tp-layer.el
@@ -1,1832 +1,560 @@
-;;; tp-layer.el --- Layer definition and registry for tp -*- lexical-binding: t -*-
+;;; tp-layer.el --- Named property declaration recipes -*- 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.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
-;; The layer registry: `define-tp' / `define-tps' and all machinery to
-;; define, store, resolve and expand named property layers and groups,
-;; plus the layer-stack representation helpers shared with tp-stack.el.
+;; `define-tp' and `define-tps' register reusable native text-property
+;; declaration recipes. A recipe is definition-time data only: applying it
+;; expands to ordinary direct properties and never stamps runtime identity into
+;; text. Live identity and reactivity belong to tp-surface and tp-reactive.
;;; Code:
(require 'cl-lib)
-(require 'dash)
(require 'tp-core)
(require 'tp-style)
-(require 'tp-reactive)
-(define-error 'tp-unresolved-layer "Unresolved tp layer or group")
-(define-error 'tp-layer-conflict "Conflicting edit in a managed tp range")
-
-(defvar tp--layer-refresh-function nil
- "Function re-rendering regions that carry a given layer, or nil.
-Installed by tp-render.el. Called with
-\(LAYER-NAME nil nil OLD-PROPS) after a non-parameterized layer is
-redefined, so text that already uses the layer can replace the old
-owned properties with the new definition. When nil, redefinition
-only updates the registry.")
-
-(defun tp--layer-refresh (layer-name &optional old-props)
- "Re-render regions carrying LAYER-NAME via `tp--layer-refresh-function'."
- (when tp--layer-refresh-function
- (funcall tp--layer-refresh-function layer-name nil nil old-props)))
+(define-error 'tp-unresolved-layer "Unresolved TP declaration recipe")
+(define-error 'tp-invalid-layer-definition "Invalid TP declaration recipe")
(defvar tp-layer-alist nil
- "Alist of layer definitions: (LAYER-NAME . PROPERTIES).")
-
-(defvar tp--layer-definition-counter 0
- "Monotonic counter used for layer definition versions.")
-
-(defvar tp--layer-definition-versions nil
- "Alist of layer definition versions: (LAYER-NAME . VERSION).")
-
-(defvar tp--managed-entry-counter 0
- "Monotonic counter used for managed stack entry ids.")
-
-(defvar tp--compiled-style-layers nil
- "Layer names whose static declarations were compiled into TP styles.")
-
-(defun tp--compile-layer-style (name properties)
- "Compile layer NAME and raw PROPERTIES into the TP style registry."
- (tp-define-style name (tp-text-declarations properties))
- (cl-pushnew name tp--compiled-style-layers)
- name)
-
-(defun tp--uncompile-layer-style (name)
- "Remove layer NAME from the TP style registry."
- (tp-undefine-style name)
- (setq tp--compiled-style-layers (delq name tp--compiled-style-layers)))
-
-(defun tp--layer-definition-version (layer-name)
- "Return LAYER-NAME's current definition version, or 0."
- (or (cdr (assq layer-name tp--layer-definition-versions)) 0))
-
-(defun tp--bump-layer-definition-version (layer-name)
- "Increment and return LAYER-NAME's definition version."
- (setq tp--layer-definition-counter (1+ tp--layer-definition-counter))
- (setf (alist-get layer-name tp--layer-definition-versions)
- tp--layer-definition-counter)
- tp--layer-definition-counter)
-
-(defun tp--store-layer-entry (layer-name entry &optional bump-version)
- "Store LAYER-NAME registry ENTRY, optionally bumping its version."
- (if (assoc layer-name tp-layer-alist)
- (setf (cdr (assoc layer-name tp-layer-alist)) entry)
- (push (cons layer-name entry) tp-layer-alist))
- (when bump-version
- (tp--bump-layer-definition-version layer-name))
- (assoc layer-name tp-layer-alist))
-
-(defun tp--next-managed-entry-id ()
- "Return a fresh managed entry id symbol."
- (setq tp--managed-entry-counter (1+ tp--managed-entry-counter))
- (intern (format "tp-entry-%d" tp--managed-entry-counter)))
+ "Alist of named declaration recipes.
+Each entry has the form (NAME ARGLIST BODY-FORM).")
(defvar tp-layer-groups nil
- "Alist of layer groups: (GROUP-NAME . (LAYER-NAME1 LAYER-NAME2 ...)).")
-
-(defvar tp-layer-transforms nil
- "Alist of layer transforms: (LAYER-NAME . TRANSFORM-FN).
-TRANSFORM-FN receives the value and returns the transformed value.
-Used for tp-text transformations like formatting numbers or dates.")
+ "Alist of named declaration group recipes.
+Each entry has the form (NAME ARGLIST BODY-FORM).")
(defvar tp--group-generated-layers nil
- "Alist tracking layers generated by each group: (GROUP-NAME . LAYER-NAMES).
-Only layers created by the group definition itself (anonymous and
-named elements) are recorded here; layers merely referenced by name
-are not. Used to clean up orphaned layers when a group is redefined
-or undefined.")
+ "Alist mapping group names to generated static recipe names.")
-;; The counter below INTENTIONALLY survives `tp-layer-reset' (which
-;; clears `tp--anonymous-layer-registry' but not this): detached
-;; strings can outlive a reset while still carrying `tp-anon-N'
-;; property values, so the counter must keep increasing monotonically
-;; - a post-reset anonymous layer must never be minted under a name a
-;; stale string still holds. Do not "fix" this by resetting it.
-(defvar tp--anonymous-layer-counter 0
- "Counter for generating unique anonymous layer names.
-Never reset - not even by `tp-layer-reset' - so freshly minted
-`tp-anon-N' names cannot collide with names living on in detached
-strings (see the comment above).")
-
-(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)))
-
-(defvar tp--anonymous-layer-registry nil
- "Alist interning anonymous reactive layers: (PROPS-SPEC . LAYER-NAME).
-PROPS-SPEC is the original (unresolved) props spec passed to
-`tp--resolve-props'; LAYER-NAME is the anonymous layer registered for
-it. Lookup is `equal'-based, so resolving an identical spec reuses
-the existing anonymous layer instead of minting a new registry entry
-on every call.")
-
-(defun tp--anonymous-layer-name-for (props)
- "Return the interned anonymous layer name for reactive spec PROPS.
-If an `equal' spec was registered before, reuse its layer name;
-otherwise generate a fresh name via `tp--generate-anonymous-layer-name'
-and record it in `tp--anonymous-layer-registry'."
- (or (cdr (assoc props tp--anonymous-layer-registry))
- (let ((name (tp--generate-anonymous-layer-name)))
- (push (cons (copy-tree props) name) tp--anonymous-layer-registry)
- name)))
-
-(defun tp--buffer-has-layer-region-p (layer-name &optional buffer)
- "Return non-nil when BUFFER has a region carrying LAYER-NAME.
-BUFFER defaults to the current buffer; a dead BUFFER yields nil.
-Stack-aware: the layer counts as present when it is the rendered top
-layer (direct `tp-name' text property) or sits anywhere inside the
-`tp-layers' stack-storage property - buried below another layer, or
-hidden (see `tp-hide-layer') - so liveness checks never miss a layer
-a live buffer still holds. Built on the shared scan
-`tp-reactive--buffer-layer-names'."
- (and (member layer-name (tp-reactive--buffer-layer-names buffer)) t))
-
-;;;###autoload
-(defun tp-gc-anonymous-layers ()
- "Collect anonymous layers that no live buffer displays anymore.
-Walk `tp--anonymous-layer-registry' and, for every interned anonymous
-layer whose buffer registry has real knowledge (see
-`tp-reactive-layer-buffers'), check whether any registered live
-buffer still contains a region carrying the layer - as the rendered
-top layer or anywhere inside `tp-layers' stack storage, so buried and
-hidden layers count as alive (see `tp--buffer-has-layer-region-p').
-Layers displayed nowhere are undefined via `tp-undefine-layer', which
-also drops their reactive dependencies, transforms and registry
-entries.
-
-Layers whose registry state is `unknown' are conservatively kept:
-they were never seen in any buffer through the registering paths,
-and detached strings may still reference them. A layer becomes
-collectable only after it was registered for at least one buffer and
-none of the registered buffers still shows it (for example after the
-buffers were killed); call `tp-reactive-track-buffer' after
-inserting propertized strings so their buffers are registered too.
-
-Return the list of collected layer names."
- (interactive)
- (let ((collected nil))
- ;; Snapshot the names first: `tp-undefine-layer' mutates the
- ;; anonymous-layer registry while we iterate.
- (dolist (name (mapcar #'cdr tp--anonymous-layer-registry))
- (let ((bufs (tp-reactive-layer-buffers name)))
- (when (and (not (eq bufs 'unknown))
- (not (cl-some (lambda (buf)
- (tp--buffer-has-layer-region-p name buf))
- bufs)))
- (tp-undefine-layer name)
- (push name collected))))
- (when (called-interactively-p 'interactive)
- (message "tp: collected %d anonymous layer(s)" (length collected)))
- (nreverse collected)))
+(defvar tp--compiled-style-layers nil
+ "Recipe names currently compiled into TP named direct styles.")
(defvar tp--layer-expansion-stack nil
- "Layer names currently being expanded, innermost first.
-Dynamically bound during `tp-layer-props' / `tp-layer-props-with-arg'
-to detect cyclic layer references.")
+ "Recipe names currently being expanded, innermost first.")
-(defun tp--check-layer-cycle (layer-name)
- "Signal a clear error if LAYER-NAME is already being expanded.
-The error message names the full cycle, e.g. \"a -> b -> a\"."
- (when (memq layer-name tp--layer-expansion-stack)
- (error "tp: cyclic layer reference: %s"
+(defun tp--recipe-entry (name registry)
+ "Return NAME's recipe entry from REGISTRY, or nil."
+ (cdr (assq name registry)))
+
+(defun tp--validate-recipe-name (name kind)
+ "Validate recipe NAME for KIND and return NAME."
+ (unless (symbolp name)
+ (signal 'tp-invalid-layer-definition (list kind :name name)))
+ (when (tp--builtin-text-property-p name)
+ (signal 'tp-invalid-layer-definition
+ (list kind :reserved-text-property name)))
+ name)
+
+(defun tp--validate-recipe-arglist (arglist kind name)
+ "Validate ARGLIST for KIND recipe NAME and return a copy."
+ (unless (and (listp arglist)
+ (cl-every #'symbolp arglist)
+ (= (length arglist) (length (delete-dups (copy-sequence arglist)))))
+ (signal 'tp-invalid-layer-definition
+ (list kind name :arglist arglist)))
+ (copy-sequence arglist))
+
+(defun tp--recipe-dollar-symbol-p (value)
+ "Return non-nil when VALUE includes a legacy dollar-prefixed symbol."
+ (cond
+ ((symbolp value) (string-prefix-p "$" (symbol-name value)))
+ ((consp value)
+ (or (tp--recipe-dollar-symbol-p (car value))
+ (tp--recipe-dollar-symbol-p (cdr value))))
+ ((vectorp value) (cl-some #'tp--recipe-dollar-symbol-p value))
+ (t nil)))
+
+(defun tp--reject-legacy-reactive-syntax (value name)
+ "Reject legacy reactive syntax in VALUE from recipe NAME."
+ (when (tp--recipe-dollar-symbol-p value)
+ (signal 'tp-invalid-layer-definition
+ (list name :legacy-reactive-syntax
+ "Use tp-computed with signals or bindings"))))
+
+(defun tp--check-layer-cycle (name)
+ "Signal an error when expanding NAME would create a cycle."
+ (when (memq name tp--layer-expansion-stack)
+ (error "TP: cyclic declaration recipe: %s"
(mapconcat #'symbol-name
- (reverse (cons layer-name tp--layer-expansion-stack))
+ (reverse (cons name tp--layer-expansion-stack))
" -> "))))
-(defun tp--get-layer-face-contribution (layer-name layer-prop-value)
- "Get the face contribution from LAYER-NAME.
-LAYER-PROP-VALUE is the value of the layer property (the argument passed to it).
-Returns the face value that the layer adds, or nil if no face contribution."
- (when (tp--is-layer-name-p layer-name)
- (let ((layer-props
- (cond
- ((tp-layer-parameterized-p layer-name)
- (tp--layer-props-for-arg-value layer-name layer-prop-value nil))
- ((assoc layer-name tp-layer-alist)
- (tp-layer-props layer-name nil))
- ((assoc layer-name tp-layer-groups)
- (when-let ((layer-props-list (tp-group-props layer-name t)))
- (tp--build-layer-props layer-props-list))))))
- (when layer-props
- (plist-get layer-props 'face)))))
+(defun tp--eval-recipe (name arglist body args)
+ "Evaluate recipe NAME with ARGLIST, BODY and ARGS."
+ (unless (= (length args) (length arglist))
+ (error "TP recipe %s takes %d argument(s), got %d"
+ name (length arglist) (length args)))
+ (let ((value (cl-progv arglist args (eval body))))
+ (tp--reject-legacy-reactive-syntax value name)
+ value))
-(defun tp--parse-define-layer-args (args)
- "Parse ARGS for tp--define-layer-internal function.
-Returns plist with keys :props, :data, :watch, :compute, :transform.
-- Keyword arguments: :props PLIST [:data DATA] [:watch WATCH]
- [:compute COMPUTE] [:transform FN]"
- (let (props data watch compute transform)
+(defun tp--merge-property-groups (&rest groups)
+ "Merge native property GROUPS using TP's direct property semantics."
+ (let ((flat (apply #'append
+ (mapcar #'tp--copy-property-value (delq nil groups)))))
+ (if (cddr flat) (tp--merge-duplicate-keys flat) flat)))
+
+(defun tp--recipe-arguments (name arglist values)
+ "Split VALUES for recipe NAME with ARGLIST into (ARGS . EXTRA)."
+ (let ((arity (length arglist)))
(cond
- ;; Check for keyword arguments format
- ((and (keywordp (car args))
- (memq (car args) '(:props :data :watch :compute :transform)))
- ;; Parse keyword arguments
- (let ((rest args))
- (while rest
- (pcase (car rest)
- (:props (setq props (cadr rest) rest (cddr rest)))
- (:data (setq data (cadr rest) rest (cddr rest)))
- (:watch (setq watch (cadr rest) rest (cddr rest)))
- (:compute (setq compute (cadr rest) rest (cddr rest)))
- (:transform (setq transform (cadr rest) rest (cddr rest)))
- (_ (error "Unknown keyword in tp--define-layer-internal: %s" (car rest))))))
- ;; Validate: if :watch, :compute, or :data present, :props must be present
- (when (and (or watch compute data) (null props))
- (error "When using :watch, :compute, or :data, :props must be explicitly specified")))
- ;; Format 1: single plist (the plist directly as first arg)
- ((and (= (length args) 1)
- (listp (car args)))
- (setq props (car args)))
- (t (error "Invalid tp--define-layer-internal format")))
- (list :props props :data data :watch watch :compute compute :transform transform)))
+ ((zerop arity)
+ (cons nil (unless (equal values '(t)) values)))
+ ((and (consp values)
+ (listp (car values))
+ (= (length (car values)) arity)
+ (zerop (% (length (cdr values)) 2)))
+ (cons (car values) (cdr values)))
+ ((>= (length values) arity)
+ (cons (cl-subseq values 0 arity) (nthcdr arity values)))
+ (t
+ (error "TP recipe %s takes %d argument(s), got %d"
+ name arity (length values))))))
-(defun tp--define-layer-internal (name &rest args)
- "Define a single text property layer named NAME.
+(defun tp-layer-parameterized-p (name)
+ "Return non-nil when layer recipe NAME accepts arguments."
+ (when-let ((entry (tp--recipe-entry name tp-layer-alist)))
+ (and (car entry) t)))
-This function supports two formats:
+(defun tp-layer-arglist (name)
+ "Return a defensive copy of layer recipe NAME's argument list."
+ (when-let ((entry (tp--recipe-entry name tp-layer-alist)))
+ (copy-sequence (car entry))))
-Format 1 - Direct plist (no :watch/:compute/:data/:transform support):
- (tp--define-layer-internal \\='layer-name
- \\='(display \"🌑\" face (:height 1.0)))
+(defun tp-group-parameterized-p (name)
+ "Return non-nil when group recipe NAME accepts arguments."
+ (when-let ((entry (tp--recipe-entry name tp-layer-groups)))
+ (and (car entry) t)))
-Format 2 - With :props, :data, :watch, :compute, and/or :transform
-\(Vue 3 style reactivity):
- (tp--define-layer-internal \\='layer-name
- ;; props: $-prefixed symbols are reactive variables;
- ;; auto-defined if not bound
- :props \\='(face (:foreground $my-color) help-echo $full-name)
- ;; data: additional reactive variables not used in props;
- ;; auto-defined if not bound
- :data \\='((first-name . \"John\") (last-name . \"Doe\"))
- ;; compute: list of (VAR-NAME FUNCTION) - compute reactive variable values
- :compute \\='((full-name (lambda () (concat first-name \" \" last-name))))
- ;; watch: list of (VAR-NAME CALLBACK) - side effects when vars change
- :watch \\='((my-color (lambda (new old layer)
- (message \"Color changed from %s to %s\" old new))))
- ;; transform: function to transform tp-text values before display
- :transform (lambda (text) (upcase text)))
+(defun tp--group-arglist (name)
+ "Return a defensive copy of group recipe NAME's argument list."
+ (when-let ((entry (tp--recipe-entry name tp-layer-groups)))
+ (copy-sequence (car entry))))
-Reactive Variables:
- If any symbol in :props starts with $, it is treated as a reactive variable.
- Variables in :data are also reactive. All reactive variables are automatically
- defined as global variables if they are not already bound.
+(defun tp--is-layer-name-p (symbol)
+ "Return non-nil when SYMBOL names a layer or group recipe."
+ (and (symbolp symbol)
+ (or (assq symbol tp-layer-alist)
+ (assq symbol tp-layer-groups))))
-:data - A list of variable symbols or cons cells (SYMBOL . INITIAL-VALUE)
- for additional reactive state not in :props.
+(defun tp--plist-has-layer-key-p (properties)
+ "Return non-nil when PROPERTIES include a recipe as a key."
+ (and (listp properties)
+ (cl-loop for (key _value) on properties by #'cddr
+ thereis (tp--is-layer-name-p key))))
-:compute - A list of (VAR-SYMBOL COMPUTE-FN) pairs. COMPUTE-FN is evaluated
- to compute the value of VAR-SYMBOL. Can reference other reactive variables
- from both :props and :data.
+(defun tp--layer-value-args (name value)
+ "Return argument list for parameterized recipe NAME from VALUE."
+ (let ((arity (length (tp-layer-arglist name))))
+ (if (and (> arity 1) (proper-list-p value)) value (list value))))
-:watch - A list of (VAR-SYMBOL CALLBACK) pairs. CALLBACK is called when
- VAR-SYMBOL changes, receiving (NEW-VALUE OLD-VALUE LAYER-NAME).
+(defun tp--group-value-args (name value)
+ "Return argument list for parameterized group NAME from VALUE."
+ (let ((arity (length (tp--group-arglist name))))
+ (if (and (> arity 1) (proper-list-p value)) value (list value))))
-:transform - A function that receives the tp-text value and returns a
- transformed string. Useful for formatting numbers, dates, or other values
- before display.
- Example: (lambda (text) (format \"$%.2f\" (string-to-number text)))
+(defun tp--expand-layer-key (name value)
+ "Expand declaration recipe NAME used as a property key with VALUE."
+ (cond
+ ((assq name tp-layer-alist)
+ (if (tp-layer-parameterized-p name)
+ (tp-layer-props-with-args name (tp--layer-value-args name value))
+ (tp-layer-props name)))
+ ((assq name tp-layer-groups)
+ (apply #'tp--merge-property-groups
+ (if (tp-group-parameterized-p name)
+ (tp-group-props-with-args name (tp--group-value-args name value))
+ (tp-group-props name))))))
-Note: When using :watch, :compute, or :data, you MUST use :props to specify
-the text properties explicitly.
+(defun tp--expand-layer-in-plist (properties)
+ "Expand recipe keys in native PROPERTIES and return direct properties."
+ (unless (and (listp properties) (zerop (% (length properties) 2)))
+ (signal 'tp-invalid-layer-definition
+ (list :invalid-property-list properties)))
+ (let (groups)
+ (cl-loop for (key value) on properties by #'cddr
+ do (push (if (tp--is-layer-name-p key)
+ (tp--expand-layer-key key value)
+ (list key (tp--copy-property-value value)))
+ groups))
+ (apply #'tp--merge-property-groups (nreverse groups))))
-If a layer with the same NAME already exists, it will be overwritten.
-The layer is stored in `tp-layer-alist'."
- (declare (indent defun))
- (let* ((old-props (when (assoc name tp-layer-alist)
- (tp-layer-props name t)))
- (parsed (tp--parse-define-layer-args args))
- (properties (plist-get parsed :props))
- (data (plist-get parsed :data))
- (watch (plist-get parsed :watch))
- (compute (plist-get parsed :compute))
- (transform (plist-get parsed :transform))
- (reactive-syms (tp--collect-reactive-symbols properties))
- ;; Collect computed variable names (they become reactive too)
- (computed-vars (when compute (mapcar #'car compute)))
- ;; All variables that need to be reactive
- (all-reactive-syms (delete-dups (append reactive-syms)))
- ;; Variables from :props that need to be defined (without initial values)
- (props-vars (mapcar #'tp--reactive-var-symbol reactive-syms))
- ;; All variables to ensure are defined:
- ;; - :data entries (may have initial values as cons cells)
- ;; - :props reactive symbols (no initial values)
- ;; - :compute variable names (no initial values)
- (all-vars-to-define (delete-dups
- (append data
- props-vars
- computed-vars))))
- ;; Register or unregister transform function
- (if transform
- (if (assoc name tp-layer-transforms)
- (setcdr (assoc name tp-layer-transforms) transform)
- (push (cons name transform) tp-layer-transforms))
- ;; Remove any existing transform when redefining without one
- (setq tp-layer-transforms (assq-delete-all name tp-layer-transforms)))
- (if (or all-reactive-syms data compute)
- ;; Has reactive features - register dependencies and resolve at runtime
- (progn
- (tp--uncompile-layer-style name)
- ;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
- (tp--unregister-reactive-deps name)
- ;; Ensure all reactive variables are defined
- (tp--ensure-reactive-variables all-vars-to-define)
- ;; Register data variables
- (when data
- (tp--register-layer-data name data))
- ;; Register computed variable definitions
- (when compute
- (tp--register-layer-computed name compute)
- ;; Apply initial computed values
- (tp--apply-initial-computed compute))
- ;; Register reactive dependencies
- (tp--register-reactive-deps name all-reactive-syms properties)
- ;; Register watchers
- (when watch
- (tp--register-layer-watchers name watch))
- ;; Set layer properties with resolved values
- (let ((resolved-props (tp--resolve-reactive-symbols properties)))
- (tp--set-layer-props name resolved-props))
- (tp--bump-layer-definition-version name)
- ;; Update any text regions that already have this layer applied
- ;; This ensures re-definition immediately updates applied text
- (tp--layer-refresh name old-props)
- (assoc name tp-layer-alist))
- ;; No reactive symbols - use static properties
+(defun tp--layer-properties (name args)
+ "Expand layer recipe NAME using ARGS."
+ (when-let ((entry (tp--recipe-entry name tp-layer-alist)))
+ (pcase-let ((`(,arglist ,body) entry))
+ (tp--check-layer-cycle name)
+ (let* ((tp--layer-expansion-stack
+ (cons name tp--layer-expansion-stack))
+ (properties (tp--eval-recipe name arglist body args)))
+ (unless (listp properties)
+ (signal 'tp-invalid-layer-definition
+ (list name :properties properties)))
+ (tp--expand-layer-in-plist properties)))))
+
+(defun tp-layer-props (name &optional _provenance)
+ "Return direct properties for non-parameterized layer recipe NAME.
+The result is a defensive copy. Return nil for an undefined or
+parameterized recipe. PROVENANCE is accepted for source compatibility and
+has no effect; runtime identity is never written into text."
+ (when (and (assq name tp-layer-alist)
+ (not (tp-layer-parameterized-p name)))
+ (tp--copy-property-value (tp--layer-properties name nil))))
+
+(defun tp-layer-props-with-args (name args &optional _provenance)
+ "Return direct properties for layer recipe NAME evaluated with ARGS.
+The result is a defensive copy. PROVENANCE is accepted for source
+ compatibility and has no effect."
+ (when (assq name tp-layer-alist)
+ (tp--copy-property-value (tp--layer-properties name args))))
+
+(defun tp-layer-props-with-arg (name arg &optional provenance)
+ "Return layer recipe NAME evaluated with ARG.
+PROVENANCE is accepted for source compatibility and has no effect."
+ (tp-layer-props-with-args name (list arg) provenance))
+
+(defun tp--group-element-properties (group-name element)
+ "Resolve one ELEMENT produced by GROUP-NAME."
+ (cond
+ ((symbolp element)
+ (or (tp-layer-props element)
+ (apply #'tp--merge-property-groups (tp-group-props element))
+ (signal 'tp-unresolved-layer (list element))))
+ ((and (consp element) (symbolp (car element))
+ (tp--is-layer-name-p (car element)))
+ (or (tp--resolve-props element)
+ (signal 'tp-unresolved-layer (list (car element)))))
+ ((and (consp element) (stringp (car element)))
+ (let ((properties
+ (if (eq (cadr element) :props) (caddr element) (cdr element))))
+ (tp--expand-layer-in-plist properties)))
+ ((listp element) (tp--expand-layer-in-plist element))
+ (t
+ (signal 'tp-invalid-layer-definition
+ (list group-name :element element)))))
+
+(defun tp--group-properties (name args)
+ "Return the ordered direct property groups produced by NAME with ARGS."
+ (when-let ((entry (tp--recipe-entry name tp-layer-groups)))
+ (pcase-let ((`(,arglist ,body) entry))
+ (tp--check-layer-cycle name)
+ (let* ((tp--layer-expansion-stack
+ (cons name tp--layer-expansion-stack))
+ (elements (tp--eval-recipe name arglist body args)))
+ (unless (listp elements)
+ (signal 'tp-invalid-layer-definition
+ (list name :elements elements)))
+ (mapcar (lambda (element)
+ (tp--group-element-properties name element))
+ elements)))))
+
+(defun tp-group-props (name &optional _provenance)
+ "Return direct property groups for non-parameterized group recipe NAME.
+PROVENANCE is accepted for source compatibility and has no effect."
+ (when (and (assq name tp-layer-groups)
+ (not (tp-group-parameterized-p name)))
+ (tp--copy-property-value (tp--group-properties name nil))))
+
+(defun tp-group-props-with-args (name args &optional _provenance)
+ "Return direct property groups for group recipe NAME with ARGS."
+ (when (assq name tp-layer-groups)
+ (tp--copy-property-value (tp--group-properties name args))))
+
+(defun tp-group-props-with-arg (name arg &optional provenance)
+ "Return group recipe NAME evaluated with ARG.
+PROVENANCE is accepted for source compatibility and has no effect."
+ (tp-group-props-with-args name (list arg) provenance))
+
+(defun tp--resolve-named-call (name values)
+ "Resolve recipe NAME applied to VALUES plus optional extra properties."
+ (let* ((arglist (if (assq name tp-layer-alist)
+ (tp-layer-arglist name)
+ (tp--group-arglist name)))
+ (split (tp--recipe-arguments name arglist values))
+ (args (car split))
+ (extra (cdr split))
+ (base
+ (if (assq name tp-layer-alist)
+ (tp-layer-props-with-args name args)
+ (apply #'tp--merge-property-groups
+ (tp-group-props-with-args name args))))
+ (expanded-extra
+ (when extra (tp--expand-layer-in-plist extra))))
+ (tp--merge-property-groups base expanded-extra)))
+
+(defun tp--resolve-props (properties)
+ "Resolve PROPERTIES into ordinary direct Emacs text properties.
+PROPERTIES may be a recipe name, a recipe call followed by extra property
+pairs, or a native property list containing recipe keys. Return nil when a
+symbol does not name a recipe."
+ (cond
+ ((symbolp properties)
+ (when (tp--is-layer-name-p properties)
+ (tp--resolve-named-call properties nil)))
+ ((and (consp properties)
+ (symbolp (car properties))
+ (tp--is-layer-name-p (car properties)))
+ (tp--resolve-named-call (car properties) (cdr properties)))
+ ((listp properties)
+ (tp--expand-layer-in-plist properties))
+ (t nil)))
+
+(defun tp--ensure-props (properties)
+ "Return direct properties resolved from PROPERTIES.
+Signal `tp-unresolved-layer' when a symbol does not name a recipe."
+ (or (tp--resolve-props properties)
+ (if (symbolp properties)
+ (signal 'tp-unresolved-layer (list properties))
+ properties)))
+
+(defun tp--compile-layer-style (name)
+ "Compile static layer recipe NAME into the named style registry."
+ (if (tp-layer-parameterized-p name)
(progn
- ;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
- (tp--unregister-reactive-deps name)
- (tp--set-layer-props name properties)
- (tp--compile-layer-style name properties)
- (tp--bump-layer-definition-version name)
- ;; Update any text regions that already have this layer applied
- (tp--layer-refresh name old-props)
- (assoc name tp-layer-alist)))))
+ (tp-undefine-style name)
+ (setq tp--compiled-style-layers
+ (delq name tp--compiled-style-layers)))
+ (tp-define-style name (tp-text-declarations (tp-layer-props name)))
+ (cl-pushnew name tp--compiled-style-layers))
+ name)
+
+(defun tp--candidate-layer-parameterized-p (name layers)
+ "Return non-nil when NAME accepts arguments in candidate LAYERS."
+ (when-let ((entry (tp--recipe-entry name layers)))
+ (and (car entry) t)))
+
+(defun tp--candidate-layer-properties (name args layers groups)
+ "Expand NAME with ARGS against candidate LAYERS and GROUPS."
+ (let ((tp-layer-alist layers)
+ (tp-layer-groups groups))
+ (tp--layer-properties name args)))
+
+(defun tp--candidate-compile-layer-style
+ (name layers groups styles compiled)
+ "Compile NAME from LAYERS and GROUPS into STYLES; return COMPILED."
+ (if (tp--candidate-layer-parameterized-p name layers)
+ (progn
+ (remhash name styles)
+ (delq name compiled))
+ (puthash name
+ (tp-merge-declarations
+ (tp-text-declarations
+ (tp--candidate-layer-properties name nil layers groups)))
+ styles)
+ (cl-pushnew name compiled))
+ compiled)
+
+(defun tp--candidate-define-layer-recipe
+ (name arglist body layers groups styles compiled)
+ "Define NAME with ARGLIST and BODY in candidate registries.
+LAYERS, GROUPS, STYLES and COMPILED are the candidate registries.
+Return (LAYERS . COMPILED) for the updated candidates."
+ (tp--validate-recipe-name name 'layer)
+ (setq arglist (tp--validate-recipe-arglist arglist 'layer name))
+ (let ((candidate-layers
+ (cons (cons name (list arglist (tp--copy-property-value body)))
+ (assq-delete-all name layers))))
+ (cons candidate-layers
+ (tp--candidate-compile-layer-style
+ name candidate-layers groups styles compiled))))
+
+(defun tp--candidate-remove-layer (name layers styles compiled)
+ "Remove NAME from candidate LAYERS and STYLES; return (LAYERS . COMPILED)."
+ (remhash name styles)
+ (cons (assq-delete-all name layers)
+ (delq name compiled)))
+
+(defun tp--define-layer-recipe (name arglist body)
+ "Register layer recipe NAME with ARGLIST and BODY."
+ (tp--validate-recipe-name name 'layer)
+ (setq arglist (tp--validate-recipe-arglist arglist 'layer name))
+ (let ((old-entry (assq name tp-layer-alist)))
+ (setq tp-layer-alist
+ (cons (cons name (list arglist (tp--copy-property-value body)))
+ (assq-delete-all name tp-layer-alist)))
+ (condition-case condition
+ (progn
+ (tp--compile-layer-style name)
+ (assq name tp-layer-alist))
+ (error
+ (setq tp-layer-alist (assq-delete-all name tp-layer-alist))
+ (when old-entry (push old-entry tp-layer-alist))
+ (signal (car condition) (cdr condition))))))
;;;###autoload
(defmacro define-tp (name arglist &rest body)
- "Define a text property layer named NAME.
-
-This macro supports three formats:
-
-Format 1 - Non-parameterized simple (empty arglist, simple body):
- (define-tp tp-bold ()
- \\='(face bold))
-
-Format 2 - Parameterized simple (one or more arguments, simple body):
- (define-tp tp-space (pixel)
- \\=`(display (space :width (,pixel))))
- (define-tp tp-colors (fg bg)
- \\=`(face (:foreground ,fg :background ,bg)))
-
-Format 3 - Non-parameterized with reactive features
-\(requires $-prefixed variables):
- (define-tp my-layer ()
- :props \\='(face (:foreground $my-color))
- :data \\='((my-color . \"red\"))
- :compute \\='((full-name (lambda () (concat first-name \" \" last-name))))
- :watch \\='((my-color (lambda (new old layer) (message \"Color changed!\"))))
- :transform (lambda (text) (upcase text)))
-
-Usage:
- (tp-set \"emacs\" \\='tp-bold t)
- (tp-set 0 5 \\='(tp-bold t) \"emacs\")
- ;; => #(\"emacs\" 0 5 (face bold))
-
-Direct `tp-set' use expands a non-reactive layer as a property
-template and does not retain `tp-name'. Use `tp-push-layer' or
-`tp-put-layer' when the text must retain managed layer identity.
-
-ARGLIST must be either:
-- An empty list () for non-parameterized layers
-- A list of one or more parameter symbols for parameterized layers
-
-BODY is either:
-- A single property list expression (simple format)
-- Keyword arguments starting with :props, :data, :compute, :watch, or :transform
- (reactive format - only for non-parameterized layers with $-prefixed
- variables)
-
-In simple format, exactly one body form is accepted; supplying more
-than one signals an error at macro-expansion time instead of silently
-discarding the extra forms.
-
-$-prefixed reactive symbols appearing in a PARAMETERIZED body do not
-create reactive dependencies (parameterized layers cannot be
-reactive); they are resolved to the current value of the corresponding
-variable each time the layer is evaluated via
-`tp-layer-props-with-arg' or `tp-layer-props-with-args'.
-
-Note: NAME cannot be a built-in Emacs text property name like `face',
-`display', `invisible', etc. See `tp--builtin-text-properties' for the
-complete list of reserved names."
+ "Define named direct property recipe NAME with ARGLIST and BODY.
+BODY must contain exactly one form returning a native text-property plist.
+Use `tp-computed' for explicit reactive value sources."
(declare (indent defun))
- (unless (listp arglist)
- (error "define-tp ARGLIST must be a list"))
- ;; Check for built-in text property name conflict
- (when (tp--builtin-text-property-p name)
- (error "define-tp: '%s' is a built-in Emacs text property name and cannot be used as a layer name" name))
- ;; Check if body starts with keyword (reactive format)
- (let ((first-elem (car body)))
- (if (and (keywordp first-elem)
- (memq first-elem '(:props :data :compute :watch :transform)))
- ;; Reactive format - only allowed for non-parameterized layers
- (if arglist
- (error "define-tp: reactive keywords (:props, :data, :compute, :watch, :transform) are only supported for non-parameterized layers (empty arglist)")
- ;; Non-parameterized reactive: use tp--define-layer-internal directly
- `(tp--define-layer-internal ',name ,@body))
- ;; Simple format (original behavior)
- (progn
- (when (cdr body)
- (error "define-tp %s: simple format takes exactly one body form, got %d (use the :props keyword format to combine multiple components)"
- name (length body)))
- (let ((simple-body (car body)))
- (cond
- ;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM)
- ((null arglist)
- `(tp--define-layer-unified ',name nil ,simple-body))
- ;; Parameterized: one or more argument symbols - store as
- ;; (LAYER-NAME ARGLIST BODY-FORM)
- ((cl-every #'symbolp arglist)
- `(tp--define-layer-unified ',name ',arglist ',simple-body))
- (t
- (error "define-tp ARGLIST must be empty or a list of symbols"))))))))
+ (unless (= (length body) 1)
+ (error "Define-tp requires exactly one body form"))
+ (if arglist
+ `(tp--define-layer-recipe ',name ',arglist ',(car body))
+ `(tp--define-layer-recipe
+ ',name nil (list 'quote ,(car body)))))
;;;###autoload
(defalias 'tp-define-layer 'define-tp
- "Define a text property layer named NAME; alias of `define-tp'.
-This is the package-prefix-conforming name for the layer definition
-macro, so it is discoverable via the tp- prefix; `define-tp' is the
-historical name and both are permanent - neither will be removed.
-See `define-tp' for the full documentation of NAME, ARGLIST and
-BODY.")
+ "Define a named direct property recipe; alias of `define-tp'.")
(function-put 'tp-define-layer 'lisp-indent-function 'defun)
-(defun tp--define-layer-unified (name arglist body)
- "Define a layer NAME with ARGLIST and BODY using unified structure.
-For non-parameterized layers, ARGLIST is nil and BODY is the evaluated plist.
-For parameterized layers, ARGLIST is a list of one or more parameter
-symbols and BODY is the unevaluated form.
-Stores the layer in `tp-layer-alist' with format:
-\(LAYER-NAME ARGLIST BODY-FORM).
+(defun tp--group-generated-name (group-name suffix)
+ "Return a generated recipe name for GROUP-NAME and SUFFIX."
+ (intern (format "%s-%s" group-name suffix)))
-For non-parameterized layers, if BODY contains reactive symbols ($-prefixed),
-delegates to `tp--define-layer-internal' for proper reactive handling."
- (if arglist
- ;; Parameterized - store for later evaluation
- (let ((entry (list arglist body)))
- (tp--uncompile-layer-style name)
- (tp--store-layer-entry name entry t)
- (tp--layer-refresh name nil)
- (assoc name tp-layer-alist))
- ;; Non-parameterized - check for reactive symbols
- (let ((reactive-syms (tp--collect-reactive-symbols body))
- (old-props (when (assoc name tp-layer-alist)
- (tp-layer-props name t))))
- (if reactive-syms
- ;; Has reactive symbols - use tp--define-layer-internal for proper handling
- (tp--define-layer-internal name body)
- ;; No reactive symbols - store as static layer
- ;; Clean up old reactive dependencies if the layer was previously reactive
- (tp--unregister-reactive-deps name)
- (let ((entry (list nil `',body)))
- (tp--store-layer-entry name entry t)
- (tp--compile-layer-style name body)
- (tp--layer-refresh name old-props)
- (assoc name tp-layer-alist))))))
+(defun tp--static-group-generated-specs (name elements)
+ "Return validated generated recipe specs for static group NAME ELEMENTS."
+ (let (specs)
+ (cl-loop for element in elements
+ for index from 0
+ when (and (consp element) (stringp (car element)))
+ do (push (cons (tp--group-generated-name name (car element))
+ (if (eq (cadr element) :props)
+ (caddr element)
+ (cdr element)))
+ specs)
+ when (and (listp element)
+ (not (stringp (car-safe element)))
+ (not (symbolp element)))
+ do (push (cons (tp--group-generated-name name index) element)
+ specs))
+ (dolist (spec specs)
+ (tp--validate-recipe-name (car spec) 'group-element)
+ (tp-text-declarations (tp--expand-layer-in-plist (cdr spec))))
+ (nreverse (tp--copy-property-value specs))))
-(defun tp--layer-group-element-format (element)
- "Determine the format type of ELEMENT.
-Returns `symbol', `format-1', `format-2', `format-3', `format-4', or
-nil if invalid."
- (cond
- ;; Symbol - reference to existing layer
- ((symbolp element) 'symbol)
- ;; Format 4 - ("name" :props (plist...) [:data ...] [:watch ...] [:compute ...])
- ;; Named layer with :props and optional :data/:watch/:compute
- ((and (listp element)
- (> (length element) 3)
- (stringp (car element))
- (eq (cadr element) :props)
- (listp (caddr element))
- ;; Must have additional keywords after :props
- (let ((rest (cdddr element)))
- (and rest (keywordp (car rest)))))
- 'format-4)
- ;; Format 3 - ("name" :props (plist...))
- ((and (listp element)
- (= (length element) 3)
- (stringp (car element))
- (eq (cadr element) :props)
- (listp (caddr element)))
- 'format-3)
- ;; Format 2 - ("name" . (plist...)) - cons cell with proper list cdr
- ((and (consp element)
- (stringp (car element))
- (listp (cdr element))
- (not (eq (cadr element) :props))) ; Distinguish from format-3
- 'format-2)
- ;; Format 1 - (plist...) - anonymous, must start with a symbol
- ((and (listp element)
- (symbolp (car element)))
- 'format-1)
- (t nil)))
-
-(defun tp--parse-layer-group-element (group-name element idx)
- "Parse a layer group element and return (layer-name . properties)
-or extended form.
-GROUP-NAME is the name of the layer group.
-ELEMENT is the element to parse (can be anonymous plist, cons-cell,
-or :props form).
-IDX is the index for anonymous elements.
-
-Returns a cons cell (LAYER-NAME . PROPERTIES) or a symbol if ELEMENT
-references an already-defined layer.
-For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA
-:watch WATCH :compute COMPUTE :transform TRANSFORM).
-Unknown keywords in format-4 elements signal an error."
- (let ((format (tp--layer-group-element-format element)))
- (pcase format
- ('symbol element)
- ('format-4
- ;; Parse named layer with :props and optional :data/:watch/:compute/:transform
- (let* ((layer-suffix (car element))
- (layer-name (intern (format "%s-%s" group-name layer-suffix)))
- (rest (cdr element))
- (props nil)
- (data nil)
- (watch nil)
- (compute nil)
- (transform nil))
- ;; Parse keyword arguments
- (while rest
- (pcase (car rest)
- (:props (setq props (cadr rest) rest (cddr rest)))
- (:data (setq data (cadr rest) rest (cddr rest)))
- (:watch (setq watch (cadr rest) rest (cddr rest)))
- (:compute (setq compute (cadr rest) rest (cddr rest)))
- (:transform (setq transform (cadr rest) rest (cddr rest)))
- (unknown
- (error "Unknown keyword %S in layer group element: %S"
- unknown element))))
- (list layer-name :props props :data data :watch watch
- :compute compute :transform transform)))
- ('format-3
- (let* ((layer-suffix (car element))
- (layer-name (intern (format "%s-%s" group-name layer-suffix)))
- (props (caddr element)))
- (cons layer-name props)))
- ('format-2
- (let* ((layer-suffix (car element))
- (layer-name (intern (format "%s-%s" group-name layer-suffix)))
- (props (cdr element)))
- (cons layer-name props)))
- ('format-1
- (let ((layer-name (intern (format "%s-%d" group-name idx))))
- (cons layer-name element)))
- (_ (error "Invalid layer group element: %S" element)))))
-
-(defun tp--define-layer-from-parsed (layer-name props data watch compute &optional transform)
- "Internal helper to define a layer from parsed components.
-LAYER-NAME is the symbol name for the layer.
-PROPS is the property list.
-DATA is the list of data variables.
-WATCH is the list of watcher definitions.
-COMPUTE is the list of computed variable definitions.
-TRANSFORM, if non-nil, is registered in `tp-layer-transforms';
-when nil, any previously registered transform for LAYER-NAME is
-removed (mirroring `tp--define-layer-internal')."
- (let ((old-props (when (assoc layer-name tp-layer-alist)
- (tp-layer-props layer-name t))))
- ;; Register or unregister transform function
- (if transform
- (if (assoc layer-name tp-layer-transforms)
- (setcdr (assoc layer-name tp-layer-transforms) transform)
- (push (cons layer-name transform) tp-layer-transforms))
- (setq tp-layer-transforms
- (assq-delete-all layer-name tp-layer-transforms)))
- (let* ((reactive-syms (tp--collect-reactive-symbols props))
- (computed-vars (when compute (mapcar #'car compute)))
- (all-reactive-syms (delete-dups reactive-syms))
- (props-vars (mapcar #'tp--reactive-var-symbol reactive-syms))
- (all-vars-to-define
- (delete-dups (append data props-vars computed-vars))))
- (if (or all-reactive-syms data compute)
- (progn
- (tp--uncompile-layer-style layer-name)
- (tp--unregister-reactive-deps layer-name)
- (tp--ensure-reactive-variables all-vars-to-define)
- (when data
- (tp--register-layer-data layer-name data))
- (when compute
- (tp--register-layer-computed layer-name compute)
- (tp--apply-initial-computed compute))
- (tp--register-reactive-deps layer-name all-reactive-syms props)
- (when watch
- (tp--register-layer-watchers layer-name watch))
- (tp--set-layer-props
- layer-name (tp--resolve-reactive-symbols props))
- (tp--bump-layer-definition-version layer-name)
- (tp--layer-refresh layer-name old-props))
- (tp--unregister-reactive-deps layer-name)
- (tp--set-layer-props layer-name props)
- (tp--compile-layer-style layer-name props)
- (tp--bump-layer-definition-version layer-name)
- (tp--layer-refresh layer-name old-props))
- layer-name)))
-
-(defun tp--define-layer-internal-group (name &rest elements)
- "Define a layer group named NAME containing multiple layers.
-
-This function accepts a list of layer definitions in ELEMENTS.
-Each element in ELEMENTS should be one of:
-
-- A symbol: reference to an existing layer
-- A plist: anonymous layer (named as NAME-0, NAME-1, etc.)
-- A cons cell (\"suffix\" . plist): named layer (named as NAME-suffix)
-- A list (\"suffix\" :props plist [:data data] [:watch watch] [:compute compute]):
- named layer with reactive features
-
-All property lists should be evaluated (quoted in the call).
-
-Example:
- (tp--define-layer-internal-group \\='my-group
- \\='existing-layer
- \\='(face bold)
- \\='(\"named\" . (face italic))
- \\='(\"reactive\" :props (face (:foreground $color))
- :data ((color . \"red\"))))
-
-If a layer group with the same NAME already exists, it will be overwritten.
-Individual layers created by the group are stored in `tp-layer-alist',
-and the group itself is stored in `tp-layer-groups'."
- (declare (indent defun))
- (let ((layer-names nil)
- (generated nil)
- (idx 0))
- (dolist (element elements)
- (let ((parsed (tp--parse-layer-group-element name element idx)))
- (cond
- ;; Reference to existing layer (symbol)
- ((symbolp parsed)
- (push parsed layer-names))
- ;; Extended format with :data/:watch/:compute/:transform (format-4)
- ((and (listp parsed) (plist-get (cdr parsed) :props))
- (let* ((layer-name (car parsed))
- (props (plist-get (cdr parsed) :props))
- (data (plist-get (cdr parsed) :data))
- (watch (plist-get (cdr parsed) :watch))
- (compute (plist-get (cdr parsed) :compute))
- (transform (plist-get (cdr parsed) :transform)))
- (tp--define-layer-from-parsed layer-name props data watch compute transform)
- (push layer-name layer-names)
- (push layer-name generated)))
- ;; Simple format (cons cell of name . props)
- ((consp parsed)
- (let* ((layer-name (car parsed))
- (props (cdr parsed)))
- (tp--define-layer-from-parsed layer-name props nil nil nil)
- (push layer-name layer-names)
- (push layer-name generated)
- ;; Only increment idx for anonymous (Format 1) elements
- (when (eq (tp--layer-group-element-format element) 'format-1)
- (cl-incf idx)))))))
- (setq layer-names (nreverse layer-names))
- (setq generated (nreverse generated))
- ;; Undefine layers generated by a previous definition of this group
- ;; that are no longer part of it, so redefinition does not orphan them.
- (let ((old-generated (cdr (assq name tp--group-generated-layers))))
- (dolist (stale (cl-set-difference old-generated generated))
- (tp-undefine-layer stale)))
- (setf (alist-get name tp--group-generated-layers) generated)
- (tp--set-group-layers name layer-names)
- (assoc name tp-layer-groups)))
-
-(defun tp--define-layer-group-internal (name arglist elements)
- "Internal function for define-tps with ARGLIST and ELEMENTS.
-NAME is the group name symbol.
-ARGLIST is nil for non-parameterized groups, or a list with one symbol.
-ELEMENTS is the list of layer definitions."
- (if arglist
- ;; Parameterized group - store for later evaluation
- (let ((entry (list arglist elements)))
- (if (assoc name tp-layer-groups)
- (setf (cdr (assoc name tp-layer-groups)) entry)
- (push (cons name entry) tp-layer-groups))
- (assoc name tp-layer-groups))
- ;; Non-parameterized - define immediately using tp--define-layer-internal-group
- (apply #'tp--define-layer-internal-group name elements)))
-
-(defun tp--define-layer-group-unified (name arglist body-form)
- "Define a parameterized layer group NAME with ARGLIST and BODY-FORM.
-Stores the group in `tp-layer-groups' with format:
-\(GROUP-NAME ARGLIST BODY-FORM).
-Layers generated by a previous non-parameterized definition of NAME
-are undefined, since a parameterized group generates none."
- (dolist (stale (cdr (assq name tp--group-generated-layers)))
- (tp-undefine-layer stale))
- (setq tp--group-generated-layers
- (assq-delete-all name tp--group-generated-layers))
- (let ((entry (list arglist body-form)))
- (if (assoc name tp-layer-groups)
- (setf (cdr (assoc name tp-layer-groups)) entry)
- (push (cons name entry) tp-layer-groups)))
- (assoc name tp-layer-groups))
+(defun tp--define-group-recipe (name arglist body)
+ "Register group recipe NAME with ARGLIST and BODY."
+ (tp--validate-recipe-name name 'group)
+ (setq arglist (tp--validate-recipe-arglist arglist 'group name))
+ (let* ((elements (unless arglist (tp--eval-recipe name nil body nil)))
+ (tp--layer-expansion-stack (cons name tp--layer-expansion-stack))
+ (_validated
+ (unless arglist
+ (mapc (lambda (element)
+ (tp--group-element-properties name element))
+ elements)))
+ (specs (unless arglist
+ (tp--static-group-generated-specs name elements))))
+ (let ((candidate-layers (tp--copy-property-value tp-layer-alist))
+ (candidate-groups (tp--copy-property-value tp-layer-groups))
+ (candidate-generated
+ (tp--copy-property-value tp--group-generated-layers))
+ (candidate-compiled (copy-sequence tp--compiled-style-layers))
+ (candidate-styles (copy-hash-table tp--named-styles))
+ generated-names)
+ (dolist (generated (cdr (assq name candidate-generated)))
+ (pcase-let ((`(,layers . ,compiled)
+ (tp--candidate-remove-layer
+ generated candidate-layers
+ candidate-styles candidate-compiled)))
+ (setq candidate-layers layers
+ candidate-compiled compiled)))
+ (setq candidate-generated
+ (assq-delete-all name candidate-generated))
+ (setf (alist-get name candidate-groups)
+ (list arglist (tp--copy-property-value body)))
+ (dolist (spec specs)
+ (pcase-let ((`(,layers . ,compiled)
+ (tp--candidate-define-layer-recipe
+ (car spec) nil
+ (list 'quote (tp--copy-property-value (cdr spec)))
+ candidate-layers candidate-groups
+ candidate-styles candidate-compiled)))
+ (setq candidate-layers layers
+ candidate-compiled compiled)
+ (push (car spec) generated-names)))
+ (when specs
+ (setf (alist-get name candidate-generated)
+ (nreverse generated-names)))
+ (setq tp-layer-alist candidate-layers
+ tp-layer-groups candidate-groups
+ tp--group-generated-layers candidate-generated
+ tp--compiled-style-layers candidate-compiled
+ tp--named-styles candidate-styles)))
+ (assq name tp-layer-groups))
;;;###autoload
(defmacro define-tps (name arglist &rest body)
- "Define a text property group named NAME.
-
-This macro defines a group of text properties (layers) that can be
-used together.
-It follows the same format as `define-tp' for consistency.
-
-ARGLIST must be either:
-- An empty list () for non-parameterized groups
-- A list of one or more parameter symbols for parameterized groups
-
-BODY contains the layer definitions, which should be quoted lists.
-
-Format 1 - Non-parameterized (empty arglist):
- (define-tps my-moon-phases ()
- \\='(display \"🌑\")
- \\='(display \"🌕\"))
-
-Format 2 - Parameterized (with one or more arguments):
- (define-tps my-status (color)
- \\=`((face (:foreground ,color)))
- \\='(face (:weight bold)))
-
-Supported formats for each element in BODY:
-
-Format 1 - Existing layer reference:
- \\='existing-layer-name
-
-Format 2 - Anonymous layer (named as NAME-0, NAME-1, etc.):
- \\='(display \"🌑\" face (:height 1.0))
-
-Format 3 - Named layer with cons-cell (named as NAME-suffix):
- \\='(\"新月\" . (display \"🌑\" face (:height 1.0)))
-
-Format 4 - Named layer with :props keyword (named as NAME-suffix):
- \\='(\"新月\" :props (display \"🌑\" face (:height 1.0)))
-
-Format 5 - Named layer with :props, :data, :watch, and/or :compute:
- \\='(\"reactive\" :props (face (:foreground $my-color))
- :data ((my-color . \"red\"))
- :watch ((my-color (lambda (new old layer)
- (message \"Changed!\")))))
-
-Note: NAME cannot be a built-in Emacs text property name like `face',
-`display', `invisible', etc. See `tp--builtin-text-properties' for the
-complete list of reserved names."
+ "Define named direct property group recipe NAME with ARGLIST.
+Each BODY form evaluates to one layer name, recipe call, native property
+ plist, or named element such as (\"label\" . (face bold))."
(declare (indent defun))
- (unless (listp arglist)
- (error "define-tps ARGLIST must be a list"))
- ;; Check for built-in text property name conflict
- (when (tp--builtin-text-property-p name)
- (error "define-tps: '%s' is a built-in Emacs text property name and cannot be used as a group name" name))
- (cond
- ;; Non-parameterized: empty arglist
- ((null arglist)
- `(tp--define-layer-group-internal ',name nil (list ,@body)))
- ;; Parameterized: one or more argument symbols
- ((cl-every #'symbolp arglist)
- `(tp--define-layer-group-unified ',name ',arglist '(list ,@body)))
- (t
- (error "define-tps ARGLIST must be empty or a list of symbols"))))
+ (if arglist
+ `(tp--define-group-recipe ',name ',arglist '(list ,@body))
+ `(tp--define-group-recipe
+ ',name nil (list 'quote (list ,@body)))))
-;; For backward compatibility, keep define-tp-group as an alias
(defalias 'define-tp-group 'define-tps
- "Alias for `define-tps' for backward compatibility.")
+ "Define a declaration group; alias of `define-tps'.")
;;;###autoload
(defalias 'tp-define-group 'define-tps
- "Define a text property group named NAME; alias of `define-tps'.
-This is the package-prefix-conforming name for the group definition
-macro, so it is discoverable via the tp- prefix; `define-tps' and
-`define-tp-group' are the historical names and all three are
-permanent - none will be removed. See `define-tps' for the full
-documentation of NAME, ARGLIST and BODY.")
+ "Define a declaration group; alias of `define-tps'.")
(function-put 'tp-define-group 'lisp-indent-function 'defun)
-(defun tp--set-layer-props (layer-name properties)
- "Set PROPERTIES for layer LAYER-NAME in `tp-layer-alist'.
-If the layer already exists, updates its properties; otherwise creates it.
-Stores as (LAYER-NAME . PROPERTIES) for backward compatibility with
-reactive layers.
-This is an internal function used by layer definition macros and
- reactive updates."
- (tp--store-layer-entry layer-name properties))
-
-(defun tp--set-group-layers (group-name layer-names)
- "Set LAYER-NAMES for group GROUP-NAME in `tp-layer-groups'.
-If the group already exists, updates its layer list; otherwise creates it.
-This is an internal function used by group definition macros."
- (if (assoc group-name tp-layer-groups)
- (setf (cdr (assoc group-name tp-layer-groups)) layer-names)
- (push (cons group-name layer-names) tp-layer-groups)))
-
-(defun tp-layer-props (layer-name &optional include-tp-name)
- "Return properties for layer LAYER-NAME from `tp-layer-alist'.
-If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify
-the layer.
-Also includes tp-name automatically if the layer has reactive
-dependencies registered.
-Handles two storage formats:
-1. Old format (from tp--set-layer-props): (LAYER-NAME . PLIST) - flat plist
-2. Unified format (from define-tp): (LAYER-NAME ARGLIST BODY-FORM)
-For parameterized layers (ARGLIST non-nil), returns nil - use
-`tp-layer-props-with-arg'.
-Recursively expands any nested layer names in the returned plist.
-Signals an error naming the cycle if layer references are cyclic.
-The returned plist is a fresh copy: mutating it does not affect the
-stored layer definition."
- (when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
- (tp--check-layer-cycle layer-name)
- ;; Auto-include tp-name for layers with reactive deps
- (let ((tp--layer-expansion-stack (cons layer-name tp--layer-expansion-stack))
- (needs-tp-name (or include-tp-name
- (tp--layer-has-reactive-deps-p layer-name))))
- (copy-tree
- (cond
- ;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list
- ;; Check: exactly 2 elements and first is nil or a list of symbols
- ((and (= (length entry) 2)
- (or (null (car entry))
- (and (listp (car entry))
- (cl-every #'symbolp (car entry)))))
- (let ((arglist (car entry))
- (body (cadr entry)))
- (if arglist
- ;; Parameterized - needs argument, return nil
- nil
- ;; Non-parameterized - evaluate body and return props
- (let ((plist (eval body)))
- (when plist
- ;; Recursively expand nested layer names
- (when (tp--plist-has-layer-key-p plist)
- (setq plist (tp--expand-layer-in-plist plist)))
- (if needs-tp-name
- (append plist (list 'tp-name layer-name))
- plist))))))
- ;; Old format: entry is just a flat plist
- (t
- (let ((plist entry))
- ;; Recursively expand nested layer names
- (when (tp--plist-has-layer-key-p plist)
- (setq plist (tp--expand-layer-in-plist plist)))
- (if needs-tp-name
- (append plist (list 'tp-name layer-name))
- plist))))))))
-
-(defun tp-layer-parameterized-p (layer-name)
- "Return non-nil if LAYER-NAME is a parameterized layer.
-Parameterized layers are stored in unified format (LAYER-NAME ARGLIST BODY-FORM)
-where ARGLIST is a non-nil list of argument symbols."
- (when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
- ;; Unified format: entry is (ARGLIST BODY-FORM) with exactly 2 elements
- ;; and first element is a non-nil list of symbols
- (and (= (length entry) 2)
- (listp (car entry))
- (not (null (car entry)))
- (cl-every #'symbolp (car entry)))))
-
-(defun tp-layer-arglist (layer-name)
- "Return the parameter list of parameterized layer LAYER-NAME.
-Returns nil when LAYER-NAME is not a parameterized layer (including
-non-parameterized and undefined layers). The returned list is a copy
-of the ARGLIST given to `define-tp', e.g. (fg bg) for a
-two-parameter layer."
- (when (tp-layer-parameterized-p layer-name)
- (copy-sequence (car (cdr (assoc layer-name tp-layer-alist))))))
-
-(defun tp-layer-props-with-args (layer-name args &optional include-tp-name)
- "Return properties for parameterized layer LAYER-NAME with ARGS.
-ARGS is a list of argument values bound positionally (via `cl-progv',
-so dynamically) to the layer's parameters while the stored body form
-is evaluated. Extra values are ignored; passing fewer values than
-the layer has parameters signals a wrong-arity error (since Emacs 27
-`cl-progv' silently binds missing parameters to nil, so the arity is
-checked explicitly here).
-If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify
-the layer.
-Recursively expands any nested layer names in the returned plist.
-$-prefixed reactive symbols in the body are resolved to the current
-values of their variables at evaluation time; they do not create
-reactive dependencies (parameterized layers cannot be reactive).
-Signals an error naming the cycle if layer references are cyclic.
-The returned plist is a fresh copy: mutating it does not affect the
-stored layer definition.
-Returns nil when LAYER-NAME is not a parameterized layer.
-
-See also `tp-layer-props-with-arg' - note the one-character name
-difference - for the single-argument convenience, and
-`tp-group-props-with-args' for the group counterpart."
- (when (tp-layer-parameterized-p layer-name)
- (let* ((entry (cdr (assoc layer-name tp-layer-alist)))
- (arglist (car entry))
- (body (cadr entry)))
- (when (< (length args) (length arglist))
- (error "tp layer %s takes %d argument(s), got %d"
- layer-name (length arglist) (length args)))
- (tp--check-layer-cycle layer-name)
- (let* ((tp--layer-expansion-stack
- (cons layer-name tp--layer-expansion-stack))
- ;; Evaluate the body with all parameters bound. `eval'
- ;; without a lexical environment sees the dynamic
- ;; bindings established by `cl-progv'.
- (plist (cl-progv arglist args (eval body))))
- (when plist
- ;; Recursively expand nested layer names
- (when (tp--plist-has-layer-key-p plist)
- (setq plist (tp--expand-layer-in-plist plist)))
- ;; Resolve $-prefixed reactive symbols to their current values
- ;; so they never leak literally into the returned props.
- (when (tp--collect-reactive-symbols plist)
- (setq plist (tp--resolve-reactive-symbols plist)))
- (copy-tree
- (if include-tp-name
- (append plist (list 'tp-name layer-name))
- plist)))))))
-
-(defun tp-layer-props-with-arg (layer-name arg &optional include-tp-name)
- "Return properties for parameterized layer LAYER-NAME with ARG.
-Evaluates the body form with the argument bound to the parameter.
-This is the single-argument convenience over
-`tp-layer-props-with-args' - note the one-character name difference -
-equivalent to calling it with (list ARG).
-If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify
-the layer.
-Recursively expands any nested layer names in the returned plist.
-$-prefixed reactive symbols in the body are resolved to the current
-values of their variables at evaluation time; they do not create
-reactive dependencies (parameterized layers cannot be reactive).
-Signals an error naming the cycle if layer references are cyclic.
-The returned plist is a fresh copy: mutating it does not affect the
-stored layer definition.
-
-See also `tp-group-props-with-arg' for the group counterpart."
- (tp-layer-props-with-args layer-name (list arg) include-tp-name))
-
-(defun tp--layer-props-for-arg-value (layer-name value &optional include-tp-name)
- "Return props for parameterized LAYER-NAME given a stored VALUE.
-When LAYER-NAME takes more than one parameter and VALUE is a proper
-list, VALUE is treated as the full argument list (as stored by the
-plist-style spec (LAYER-NAME (ARG1 ARG2 ...))); otherwise VALUE is
-the single argument (the single-parameter behavior).
-INCLUDE-TP-NAME is passed through."
- (if (and (proper-list-p value)
- (> (length (tp-layer-arglist layer-name)) 1))
- (tp-layer-props-with-args layer-name value include-tp-name)
- (tp-layer-props-with-arg layer-name value include-tp-name)))
-
-(defun tp-group-props (group-name &optional include-tp-name)
- "Return list of properties for all layers in GROUP-NAME.
-If INCLUDE-TP-NAME is non-nil, each layer's props will include tp-name.
-Handles both old format (list of layer names) and new unified format
-from `define-tps` (parameterized groups store ARGLIST and BODY-FORM)."
- (when-let ((entry (cdr (assoc group-name tp-layer-groups))))
- ;; Check if it's the unified format from define-tps (ARGLIST BODY-FORM)
- ;; Unified format: (ARGLIST BODY-FORM) where ARGLIST is a list of symbols or nil
- ;; Old format: (layer1 layer2 ...) where each element is a symbol referring to a layer
- (cond
- ;; Unified parameterized format: (ARGLIST BODY-FORM) with non-nil ARGLIST
- ((and (= (length entry) 2)
- (listp (car entry))
- (not (null (car entry)))
- (cl-every #'symbolp (car entry)))
- ;; Parameterized group - can't get props without argument
- nil)
- ;; Old format or non-parameterized define-tps: list of layer names
- (t
- (mapcar (lambda (layer)
- (tp-layer-props layer include-tp-name))
- entry)))))
-
-(defun tp-group-parameterized-p (group-name)
- "Return non-nil if GROUP-NAME is a parameterized group.
-Parameterized groups are stored in format (GROUP-NAME ARGLIST BODY-FORM)
-where ARGLIST is a non-nil list of argument symbols."
- (when-let ((entry (cdr (assoc group-name tp-layer-groups))))
- ;; Check for unified format: (ARGLIST BODY-FORM) with non-nil ARGLIST
- (and (= (length entry) 2)
- (listp (car entry))
- (not (null (car entry)))
- (cl-every #'symbolp (car entry)))))
-
-(defun tp--group-arglist (group-name)
- "Return the parameter list of parameterized group GROUP-NAME.
-Returns nil when GROUP-NAME is not a parameterized group. The
-returned list is a copy of the ARGLIST given to `define-tps'."
- (when (tp-group-parameterized-p group-name)
- (copy-sequence (car (cdr (assoc group-name tp-layer-groups))))))
-
-(defun tp--group-anonymous-props (plist)
- "Normalize anonymous-layer PLIST from a parameterized group element.
-Expands nested layer names, resolves $-prefixed reactive symbols to
-their current values, and returns a fresh copy safe for caller
-mutation. Returns nil if PLIST is nil."
- (when plist
- (let ((props plist))
- (when (tp--plist-has-layer-key-p props)
- (setq props (tp--expand-layer-in-plist props)))
- (when (tp--collect-reactive-symbols props)
- (setq props (tp--resolve-reactive-symbols props)))
- (copy-tree props))))
-
-(defun tp--group-spec-to-props (spec include-tp-name)
- "Convert one evaluated parameterized-group element SPEC to a props plist.
-SPEC may be:
-- a symbol naming a defined layer;
-- a list (LAYER-NAME ARG ...) whose head is a defined layer or group;
-- a cons (\"NAME\" . PLIST) or a list (\"NAME\" :props PLIST);
-- a raw property list (anonymous layer), optionally wrapped in one
- extra set of parentheses as in the `define-tps' docstring example.
-INCLUDE-TP-NAME is passed through for named layer references;
-anonymous plists have no name, so it does not apply to them.
-Returns nil if SPEC cannot be interpreted."
- (cond
- ;; Layer name symbol
- ((symbolp spec)
- (tp-layer-props spec include-tp-name))
- ((not (consp spec)) nil)
- ;; (LAYER-NAME ARG ...) - defined layer at the head
- ((and (symbolp (car spec)) (tp--is-layer-name-p (car spec)))
- (let ((layer-name (car spec)))
- (if (tp-layer-parameterized-p layer-name)
- ;; Bind as many arguments as the layer has parameters.
- (tp-layer-props-with-args
- layer-name
- (-take (length (tp-layer-arglist layer-name)) (cdr spec))
- include-tp-name)
- ;; Non-parameterized layer - arg should be t or ignored
- (tp-layer-props layer-name include-tp-name))))
- ;; ("NAME" :props PLIST) or ("NAME" . PLIST) - use the props part
- ((stringp (car spec))
- (tp--group-anonymous-props
- (if (eq (cadr spec) :props)
- (caddr spec)
- (cdr spec))))
- ;; One extra level of wrapping, e.g. ((face (:foreground "red")))
- ((and (consp (car spec)) (null (cdr spec)))
- (tp--group-spec-to-props (car spec) include-tp-name))
- ;; Raw plist - anonymous layer
- ((symbolp (car spec))
- (tp--group-anonymous-props spec))
- (t nil)))
-
-(defun tp--group-props-with-args (group-name args &optional include-tp-name)
- "Return list of properties for parameterized group GROUP-NAME with ARGS.
-ARGS is a list of argument values bound positionally (via `cl-progv',
-so dynamically) to the group's parameters while the stored body form
-is evaluated. Each evaluated element is converted like
-`tp-group-props-with-arg' documents. If INCLUDE-TP-NAME is non-nil,
-named layer references include tp-name.
-Returns nil when GROUP-NAME is not a parameterized group.
-The public entry point delegating here is `tp-group-props-with-args'."
- (when (tp-group-parameterized-p group-name)
- (let* ((entry (cdr (assoc group-name tp-layer-groups)))
- (arglist (car entry))
- (body-form (cadr entry))
- ;; Evaluate the body with all parameters bound - returns
- ;; list of layer specs.
- (layer-specs (cl-progv arglist args (eval body-form))))
- ;; Convert layer specs to property lists
- (mapcar (lambda (spec)
- (tp--group-spec-to-props spec include-tp-name))
- layer-specs))))
-
-(defun tp-group-props-with-arg (group-name arg &optional include-tp-name)
- "Return list of properties for parameterized group GROUP-NAME with ARG.
-Evaluates the body form with the argument bound to the parameter.
-This is the single-argument convenience over
-`tp-group-props-with-args' - note the one-character name difference -
-equivalent to calling it with (list ARG).
-Each evaluated element may be a layer name symbol, a (LAYER-NAME ARG)
-reference, a named element (\"NAME\" . PLIST) / (\"NAME\" :props PLIST),
-or a raw property list (anonymous layer) as documented in `define-tps'.
-If INCLUDE-TP-NAME is non-nil, named layer references include tp-name.
-Returns a list of property lists for each layer in the group.
-
-See also `tp-layer-props-with-arg' for the single-layer counterpart."
- (tp--group-props-with-args group-name (list arg) include-tp-name))
-
-(defun tp-group-props-with-args (group-name args &optional include-tp-name)
- "Return list of properties for parameterized group GROUP-NAME with ARGS.
-ARGS is a list of argument values bound positionally to the group's
-parameters while the stored body form is evaluated - the public
-multi-argument introspection path for groups defined by `define-tps'
-with two or more parameters (which `tp-put-layer' specs like
-\(GROUP-NAME ARG1 ARG2) consume). Each evaluated element is
-converted exactly as `tp-group-props-with-arg' documents. If
-INCLUDE-TP-NAME is non-nil, named layer references include tp-name.
-Returns nil when GROUP-NAME is not a parameterized group.
-
-This mirrors `tp-layer-props-with-args' for layers. See also
-`tp-group-props-with-arg' - note the one-character name difference -
-for the single-argument convenience."
- (tp--group-props-with-args group-name args include-tp-name))
-
-(defun tp--group-props-for-arg-value (group-name value &optional include-tp-name)
- "Return props list for parameterized GROUP-NAME given a stored VALUE.
-When GROUP-NAME takes more than one parameter and VALUE is a proper
-list, VALUE is treated as the full argument list (as stored by the
-plist-style spec (GROUP-NAME (ARG1 ARG2 ...))); otherwise VALUE is
-the single argument (the single-parameter behavior).
-INCLUDE-TP-NAME is passed through."
- (if (and (proper-list-p value)
- (> (length (tp--group-arglist group-name)) 1))
- (tp--group-props-with-args group-name value include-tp-name)
- (tp-group-props-with-arg group-name value include-tp-name)))
-
-(defun tp--is-layer-name-p (sym)
- "Return non-nil if SYM is a defined layer, parameterized layer, or group name."
- (and (symbolp sym)
- (or (assoc sym tp-layer-alist)
- (assoc sym tp-layer-groups))))
-
-(defun tp--plist-has-layer-key-p (plist)
- "Return non-nil if PLIST contains any layer names as keys."
- (cl-loop for (key _val) on plist by #'cddr
- thereis (tp--is-layer-name-p key)))
-
-(defun tp--expand-layer-in-plist (props)
- "Expand any layer names found in PROPS plist.
-Scans through PROPS treating it as a plist (key value pairs).
-When a key is a layer/group name, expands it with its properties.
-Recursively expands until no more layer names are found in the result.
-Does NOT add tp-name - this is for direct property setting (tp-set/add/reset).
-Returns the expanded plist."
- (let ((result nil)
- (remaining props))
- (while remaining
- (let ((key (car remaining))
- (val (cadr remaining)))
- (cond
- ;; Key is a layer/parameterized layer/group name - expand it
- ((tp--is-layer-name-p key)
- (let ((layer-props
- (cond
- ;; Parameterized layer - evaluate with the argument (val);
- ;; for multi-parameter layers a list VAL carries all args
- ((tp-layer-parameterized-p key)
- (tp--layer-props-for-arg-value key val nil)) ; no tp-name
- ;; Non-parameterized layer - val should be t
- ((assoc key tp-layer-alist)
- (tp-layer-props key nil)) ; no tp-name
- ;; Parameterized layer group - evaluate with the argument (val);
- ;; for multi-parameter groups a list VAL carries all args
- ((tp-group-parameterized-p key)
- (when-let ((layer-props-list
- (tp--group-props-for-arg-value key val t)))
- ;; Build layered structure: first layer at top, rest in tp-layers
- (tp--build-layer-props layer-props-list)))
- ;; Non-parameterized layer group - build layered structure
- ((assoc key tp-layer-groups)
- (when-let ((layer-props-list (tp-group-props key t)))
- ;; Build layered structure: first layer at top, rest in tp-layers
- (tp--build-layer-props layer-props-list))))))
- (when layer-props
- ;; Recursively expand if the layer props contain more layer names
- (when (tp--plist-has-layer-key-p layer-props)
- (setq layer-props (tp--expand-layer-in-plist layer-props)))
- (setq result (append result layer-props)))))
- ;; Regular property - keep as-is
- (t
- (setq result (append result (list key val)))))
- (setq remaining (cddr remaining))))
- ;; Merge duplicate keys in the expanded result
- ;; Use (cdddr result) for O(1) check - need at least 4 elements (2 key-value pairs) for possible duplicates
- (if (cdddr result)
- (tp--merge-duplicate-keys result)
- result)))
-
-(defun tp--strip-trailing-plist-nil (plist)
- "Remove a lone trailing nil from odd-length PLIST.
-`tp--merge-duplicate-keys' pads an odd-length property spec (a flat
-\(LAYER ARG1 ARG2 EXTRA-PROP VAL) call for a multi-parameter layer)
-with a trailing nil value; strip it so the extra properties form a
-proper plist again."
- (if (and plist
- (cl-oddp (length plist))
- (null (car (last plist))))
- (butlast plist)
- plist))
-
-(defun tp--resolve-props (props)
- "Resolve PROPS to a property list with layer metadata.
-PROPS can be:
-- A symbol (layer name from `tp-layer-alist' or group name from
- `tp-layer-groups')
-- A two-element list (LAYER-NAME ARG) where LAYER-NAME is a defined layer
- and ARG is either `t' for non-parameterized layers or the argument value
- for parameterized layers
-- A list starting with (LAYER-NAME ARG EXTRA-PROPS...) where extra properties
- are merged with the layer properties
-- For multi-parameter layers/groups, (LAYER-NAME ARG1 ARG2 ...
- EXTRA-PROPS...) binds as many leading elements as the layer has
- parameters; alternatively (LAYER-NAME (ARG1 ARG2 ...) EXTRA-PROPS...)
- passes all arguments as one list (recognized when the list's length
- equals the layer's parameter count and the remaining elements form
- an even-length plist)
-- A plist with layer names at any position - they will be expanded inline
-- A plist (handles anonymous layers with reactive variables)
-
-If PROPS is a symbol:
-- First checks `tp-layer-alist' and expands the layer properties
- WITHOUT `tp-name' for direct property setting
-- Then checks `tp-layer-groups' and returns properties WITH `tp-layers'
-
-If PROPS is (LAYER-NAME ARG) or (LAYER-NAME ARG EXTRA-PROPS...):
-- For non-parameterized layers: if ARG is t, returns the layer properties
-- For parameterized layers: evaluates the body with the argument(s)
- and returns the result
-- Extra properties after the argument(s) are appended to the layer
- properties
-
-If PROPS is a plist with layer names at any position:
-- Layer names are expanded inline with their properties
-- Other properties are preserved in order
-
-If PROPS is a plist:
-- If it contains reactive variables ($...), generates a UUID for `tp-name',
- registers reactive dependencies, and returns the resolved props
- with `tp-name'.
- If the plist already has a `tp-name', uses that instead of
- generating a new one.
-- If no reactive variables, returns props as-is (no tp-name added).
-
-Returns nil if PROPS is a symbol but no matching layer/group is found.
-
-Reactive anonymous properties retain `tp-name' so they can be
-updated. Plain layer names used through direct property APIs do not;
-use stack APIs for a managed mount. Group names include `tp-layers'
-with the full layer stack."
- (cond
- ;; Already a plist - check for reactive variables and add tp-name
- ((listp props)
- (let ((first-elem (car-safe props))
- (second-elem (cadr props)))
- (cond
- ;; Handle (layer-name arg ...) format for defined layers at the START
- ;; This includes both (layer-name arg) and (layer-name arg extra-prop val ...)
- ((and (>= (length props) 2)
- (tp--is-layer-name-p first-elem))
- (let* ((arity (cond ((tp-layer-parameterized-p first-elem)
- (length (tp-layer-arglist first-elem)))
- ((tp-group-parameterized-p first-elem)
- (length (tp--group-arglist first-elem)))
- ;; Non-parameterized: one slot is consumed
- ;; by the conventional `t' argument.
- (t 1)))
- ;; Plist-style multi-arg spec (LAYER (ARG1 ... ARGN)
- ;; EXTRA...): the element after the name carries all
- ;; arguments when it is a list of exactly ARITY values
- ;; and the remaining elements form an even-length plist.
- (wrapped-args (and (> arity 1)
- (proper-list-p second-elem)
- (= (length second-elem) arity)
- (cl-evenp (length (cddr props)))))
- (args (if wrapped-args
- second-elem
- (-take arity (cdr props))))
- (extra-props (if wrapped-args
- (cddr props)
- (tp--strip-trailing-plist-nil
- (-drop arity (cdr props)))))
- ;; ARG-1: wrong-arity parameterized calls must signal
- ;; clearly instead of nil-binding missing parameters or
- ;; applying excess positional args as garbage property
- ;; keys.
- (kind (cond ((tp-layer-parameterized-p first-elem) "layer")
- ((tp-group-parameterized-p first-elem) "group")))
- (_arity-check
- (when kind
- (when (< (length args) arity)
- (error "tp %s %s takes %d argument(s), got %d"
- kind first-elem arity (length args)))
- (when (and (not wrapped-args)
- extra-props
- (not (symbolp (car extra-props))))
- (error "tp %s %s takes %d argument(s); excess argument %S is not a property key"
- kind first-elem arity (car extra-props)))))
- (layer-props
- (cond
- ;; Parameterized layer - evaluate with the argument(s)
- ((tp-layer-parameterized-p first-elem)
- (tp-layer-props-with-args first-elem args nil)) ; no tp-name
- ;; Non-parameterized layer - arg should be t, return the layer props
- ;; (silently ignore non-t values for flexibility)
- ((assoc first-elem tp-layer-alist)
- (tp-layer-props first-elem nil)) ; no tp-name
- ;; Parameterized layer group - evaluate with the argument(s)
- ((tp-group-parameterized-p first-elem)
- (when-let ((layer-props-list
- (tp--group-props-with-args first-elem args t)))
- ;; Build layered structure: first layer at top, rest in tp-layers
- (tp--build-layer-props layer-props-list)))
- ;; Non-parameterized layer group - build layered structure
- ((assoc first-elem tp-layer-groups)
- (when-let ((layer-props-list (tp-group-props first-elem t)))
- ;; Build layered structure: first layer at top, rest in tp-layers
- (tp--build-layer-props layer-props-list))))))
- ;; Recursively resolve extra properties (they may also contain layer names)
- (let ((expanded-props
- (if (and layer-props extra-props)
- (let* ((resolved-extra (tp--expand-layer-in-plist extra-props))
- (combined (append layer-props resolved-extra)))
- ;; Merge duplicate keys after combining layer props with extra props
- ;; Need at least 4 elements (2 key-value pairs) for possible duplicates
- (if (cdddr combined)
- (tp--merge-duplicate-keys combined)
- combined))
- layer-props)))
- ;; After expansion, check for reactive symbols in the merged props
- ;; (original props may contain $vars that need reactive tracking)
- (let ((reactive-syms (tp--collect-reactive-symbols props)))
- (if reactive-syms
- ;; Has reactive symbols - need anonymous tp-name for reactive tracking
- (let* ((existing-tp-name (plist-get props 'tp-name))
- (layer-name (or existing-tp-name
- (tp--anonymous-layer-name-for props)))
- ;; Resolve reactive symbols in expanded props
- (resolved-props (tp--resolve-reactive-symbols expanded-props)))
- ;; Register reactive dependencies
- (tp--uncompile-layer-style layer-name)
- (tp--set-layer-props layer-name resolved-props)
- (tp--register-reactive-deps layer-name reactive-syms props)
- (append resolved-props (list 'tp-name layer-name)))
- ;; No reactive symbols - return expanded props as-is (no tp-name)
- expanded-props)))))
-
- ;; Handle single-element list containing a layer/group name symbol.
- ;; This can happen when tp-set is called with string form: (tp-set str 'layer-name)
- ;; which produces props = (layer-name) in tp--parse-args.
- ((and (= (length props) 1)
- (symbolp first-elem)
- (or (assoc first-elem tp-layer-alist)
- (assoc first-elem tp-layer-groups)))
- ;; It's a layer/group name wrapped in a list - recurse with the symbol
- (tp--resolve-props first-elem))
-
- ;; Check if any key in the plist is a layer name (layer at any position)
- ((cl-some #'tp--is-layer-name-p
- (cl-loop for (key _val) on props by #'cddr collect key))
- ;; Expand all layer names in the plist
- (let ((expanded-props (tp--expand-layer-in-plist props)))
- ;; After expansion, check for reactive symbols in the original props
- ;; (they may contain $vars that need reactive tracking)
- (let ((reactive-syms (tp--collect-reactive-symbols props)))
- (if reactive-syms
- ;; Has reactive symbols - need anonymous tp-name for reactive tracking
- (let* ((existing-tp-name (plist-get props 'tp-name))
- (layer-name (or existing-tp-name
- (tp--anonymous-layer-name-for props)))
- ;; Resolve reactive symbols in expanded props
- (resolved-props (tp--resolve-reactive-symbols expanded-props)))
- ;; Register reactive dependencies
- (tp--uncompile-layer-style layer-name)
- (tp--set-layer-props layer-name resolved-props)
- (tp--register-reactive-deps layer-name reactive-syms props)
- (append resolved-props (list 'tp-name layer-name)))
- ;; No reactive symbols - return expanded props as-is (no tp-name)
- expanded-props))))
-
- ;; Normal plist processing
- (t
- (let* ((existing-tp-name (plist-get props 'tp-name))
- (reactive-syms (tp--collect-reactive-symbols props)))
- (if reactive-syms
- ;; Has reactive symbols - need to handle as anonymous reactive layer
- (let* ((layer-name (or existing-tp-name
- (tp--anonymous-layer-name-for props)))
- ;; Resolve reactive symbols to get current values
- (resolved-props (tp--resolve-reactive-symbols props)))
- ;; Register this anonymous layer in tp-layer-alist with resolved props
- (tp--uncompile-layer-style layer-name)
- (tp--set-layer-props layer-name resolved-props)
- ;; Register reactive dependencies with the original props
- (tp--register-reactive-deps layer-name reactive-syms props)
- ;; Return resolved props with tp-name for reactive tracking
- (append resolved-props (list 'tp-name layer-name)))
- ;; No reactive symbols - return props as-is (no tp-name needed)
- ;; This preserves the native text property behavior for non-reactive plists
- props))))))
- ;; Symbol - check if it's a layer or group name
- ((symbolp props)
- (cond
- ;; Parameterized layer without argument - cannot resolve, return nil
- ((tp-layer-parameterized-p props)
- nil)
- ;; Check layer - get props without tp-name for direct property setting
- ((assoc props tp-layer-alist)
- (tp-layer-props props nil)) ; no tp-name
- ;; Check group - build layered structure with tp-layers
- ((assoc props tp-layer-groups)
- (when-let ((layer-props-list (tp-group-props props t))) ; include tp-name
- ;; Build layered structure: first layer at top, rest in tp-layers
- (tp--build-layer-props layer-props-list)))
- ;; Parameterized group without argument - cannot resolve, return nil
- ((tp-group-parameterized-p props)
- nil)
- ;; Not found - return nil (let caller decide how to handle)
- (t nil)))
- (t nil)))
-
-(defun tp--ensure-props (plist)
- "Ensure PLIST is a property list, resolving layer names and
-handling reactive vars.
-If PLIST is a symbol, resolve it via `tp--resolve-props'.
-If PLIST is a plist, also process it via `tp--resolve-props' to handle
-anonymous reactive layers.
-If resolution fails, return PLIST unchanged (for backward compatibility)."
- (or (tp--resolve-props plist) plist))
-
;;;###autoload
(defun tp-layer-reset ()
- "Reset all layer definitions.
-Clears both `tp-layer-alist' and `tp-layer-groups'.
-Also resets all reactive text property watchers, dependencies, and transforms."
+ "Remove every named layer and group declaration recipe."
(interactive)
- (tp-reactive-reset)
- (setq tp-layer-alist nil)
- (setq tp-layer-groups nil)
- (setq tp--layer-definition-counter 0)
- (setq tp--layer-definition-versions nil)
- (setq tp--managed-entry-counter 0)
(dolist (name tp--compiled-style-layers)
(tp-undefine-style name))
- (setq tp--compiled-style-layers nil)
- (setq tp-layer-transforms nil)
- (setq tp--group-generated-layers nil)
- (setq tp--anonymous-layer-registry nil))
+ (setq tp-layer-alist nil
+ tp-layer-groups nil
+ tp--group-generated-layers nil
+ tp--compiled-style-layers nil))
(defun tp-undefine-layer (name)
- "Remove layer NAME from `tp-layer-alist'.
-Also unregisters any reactive dependencies and transforms for this layer,
-and drops any anonymous-layer registry entries interned for it."
- (tp--unregister-reactive-deps name)
- (setq tp-layer-alist (assq-delete-all name tp-layer-alist))
- (setq tp--layer-definition-versions
- (assq-delete-all name tp--layer-definition-versions))
- (setq tp-layer-transforms (assq-delete-all name tp-layer-transforms))
- (setq tp--anonymous-layer-registry
- (cl-remove-if (lambda (cell) (eq (cdr cell) name))
- tp--anonymous-layer-registry))
- (tp--uncompile-layer-style name))
+ "Remove named layer declaration recipe NAME."
+ (setq tp-layer-alist (assq-delete-all name tp-layer-alist)
+ tp--compiled-style-layers (delq name tp--compiled-style-layers))
+ (tp-undefine-style name))
(defun tp-undefine-group (name)
- "Remove layer group NAME from `tp-layer-groups'.
-Also undefines the layers that the group definition itself generated
-(anonymous and named elements), including their reactive dependencies
-and transforms. Layers merely referenced by the group are left
-untouched."
+ "Remove named declaration group NAME and recipes it generated."
(dolist (generated (cdr (assq name tp--group-generated-layers)))
(tp-undefine-layer generated))
(setq tp--group-generated-layers
- (assq-delete-all name tp--group-generated-layers))
- (setq tp-layer-groups (assq-delete-all name tp-layer-groups)))
-
-(defun tp--managed-entry-meta (name origin spec args arglist)
- "Build managed metadata for NAME with ORIGIN, SPEC, ARGS and ARGLIST."
- (list :schema 1
- :entry-id (tp--next-managed-entry-id)
- :origin origin
- :spec (copy-tree spec)
- :args (copy-tree args)
- :arglist (copy-tree arglist)
- :definition-version (tp--layer-definition-version name)
- :entry-version 1
- :mode 'exclusive
- :palette-deps nil
- :palette-generation (if (boundp 'tp-theme-generation)
- tp-theme-generation 0)
- :legacy-no-args nil))
-
-(defun tp--stamp-managed-entry (props name spec args arglist origin)
- "Return PROPS stamped with managed metadata for NAME."
- (plist-put (copy-tree props)
- 'tp-meta
- (tp--managed-entry-meta name origin spec args arglist)))
-
-(defun tp--entry-render-projection (props)
- "Return rendered PROPS without stack-only bookkeeping."
- (let ((result (copy-sequence props)))
- (dolist (key '(tp-meta tp-hidden tp-layers))
- (cl-remf result key))
- result))
-
-(defun tp--entry-authoritative-storage-p (layer-list)
- "Return non-nil when LAYER-LIST requires `tp-layers' authority."
- (seq-some (lambda (layer)
- (or (tp--stack-hidden-p layer)
- (plist-member layer 'tp-meta)))
- layer-list))
-
-(defun tp--normalize-layer-spec (layer-spec)
- "Normalize LAYER-SPEC to a plist with tp-name.
-Used by layer stack functions that need tp-name for identification.
-
-LAYER-SPEC can be:
-- A symbol (non-parameterized layer name from define-tp or
- tp--define-layer-internal)
-- A list (LAYER-NAME ARG ...) for parameterized layers from
- define-tp, with exactly as many arguments as the layer has
- parameters
-- A plist for inline layer definition
-- A list (NAME &rest PLIST) for named inline layer"
- (cond
- ;; Symbol - look up in tp-layer-alist (non-parameterized layer)
- ((symbolp layer-spec)
- (cond
- ;; Parameterized layer symbol without arg - error
- ((tp-layer-parameterized-p layer-spec)
- (error "Parameterized layer %S requires an argument, use '(%S arg)"
- layer-spec layer-spec))
- ;; Non-parameterized layer or old-format layer
- ((assoc layer-spec tp-layer-alist)
- (tp--stamp-managed-entry
- (or (tp-layer-props layer-spec t)
- (error "Layer %S not found in tp-layer-alist" layer-spec))
- layer-spec layer-spec nil nil 'defined))
- (t (signal 'tp-unresolved-layer (list layer-spec)))))
-
- ;; List starting with symbol - check if it's a parameterized layer
- ((and (listp layer-spec)
- (symbolp (car layer-spec))
- (not (keywordp (car layer-spec))))
- (let ((name (car layer-spec))
- (rest (cdr layer-spec)))
- (cond
- ;; Parameterized layer: (LAYER-NAME ARG ...) with exactly as
- ;; many arguments as the layer has parameters
- ((and (tp-layer-parameterized-p name)
- (= (length rest) (length (tp-layer-arglist name))))
- (tp--stamp-managed-entry
- (or (tp-layer-props-with-args name rest t)
- (error "Failed to resolve parameterized layer %S with args %S"
- name rest))
- name layer-spec rest (tp-layer-arglist name) 'parameterized))
- ;; ARG-1: a parameterized layer with the wrong number of
- ;; arguments must not fall through to the named-inline branch,
- ;; which would build an odd-length plist and die with the
- ;; cryptic "Odd length text property list".
- ((tp-layer-parameterized-p name)
- (error "tp layer %s expects %d args, got %d"
- name (length (tp-layer-arglist name)) (length rest)))
- ;; Named inline layer: (NAME &rest PLIST)
- (rest
- (tp--stamp-managed-entry
- (append rest (list 'tp-name name))
- name layer-spec nil nil 'inline))
- ;; Just a symbol in a list - treat as non-parameterized layer
- ((null rest)
- (tp--stamp-managed-entry
- (or (tp-layer-props name t)
- (signal 'tp-unresolved-layer (list name)))
- name layer-spec nil nil 'defined)))))
-
- ;; Plist (starts with keyword or property name)
- ((and (listp layer-spec) layer-spec)
- layer-spec)
- (t (error "Invalid layer spec: %S" layer-spec))))
-
-(defun tp--get-layer-stack (pos object)
- "Get the layer stack at POS in OBJECT as a list.
-Returns (TOP-PROPS . BELOW-PROPS-LIST)."
- (let* ((props (text-properties-at pos object))
- (tp-layers-idx (-elem-index 'tp-layers props))
- (top-props (if tp-layers-idx
- (-remove-at-indices
- (list tp-layers-idx (1+ tp-layers-idx)) props)
- props))
- (below-props (plist-get props 'tp-layers)))
- (cons top-props below-props)))
-
-(defun tp--build-layer-props (layer-list)
- "Build text properties from LAYER-LIST.
-First element is top layer, rest are in tp-layers."
- (if (null layer-list)
- nil
- (append (car layer-list)
- (list 'tp-layers (cdr layer-list)))))
-
-(defun tp--layer-stack-to-list (top belows)
- "Convert TOP and BELOWS to a flat list of layers."
- (if top
- (cons top belows)
- belows))
-
-;;; Layer stack storage codec
-;;
-;; The encoding/decoding of a layer stack into raw text properties
-;; lives here, beside `tp--build-layer-props' / `tp--layer-stack-to-list',
-;; so both the stack operations (tp-stack.el) and the reactive
-;; re-render engine (tp-render.el) can read and write stack storage
-;; without duplicating format knowledge or requiring each other.
-
-(defun tp--stack-hidden-p (layer)
- "Return non-nil when the layer plist LAYER is flagged hidden.
-A layer is hidden when its plist carries a non-nil `tp-hidden' entry;
-see `tp-hide-layer'."
- (and (plist-get layer 'tp-hidden) t))
-
-(defun tp--plist-equivalent-p (left right)
- "Return non-nil when LEFT and RIGHT contain the same plist entries."
- (let ((left-proj (tp--entry-render-projection left))
- (right-proj (tp--entry-render-projection right)))
- (and (cl-loop for (key val) on left-proj by #'cddr
- always (and (plist-member right-proj key)
- (equal (plist-get right-proj key) val)))
- (cl-loop for (key val) on right-proj by #'cddr
- always (and (plist-member left-proj key)
- (equal (plist-get left-proj key) val))))))
-
-(defun tp--assert-hidden-render-cache (direct stack)
- "Signal `tp-layer-conflict' unless DIRECT matches rendered STACK."
- (let ((expected (seq-find (lambda (layer)
- (not (tp--stack-hidden-p layer)))
- stack)))
- (unless (tp--plist-equivalent-p direct
- (tp--entry-render-projection expected))
- (signal 'tp-layer-conflict
- (list "Direct properties changed while a layer was hidden"
- :actual direct
- :expected (tp--entry-render-projection expected))))))
-
-(defun tp--stack-props-to-list (props)
- "Return the ordered layer stack stored in raw text properties PROPS.
-The result is a list of layer plists, top layer first, including
-hidden layers (flagged with a non-nil `tp-hidden' entry) at their
-stack position. Returns nil for bare text.
-
-This is the inverse of `tp--stack-build-props': when any entry of the
-`tp-layers' bookkeeping property is hidden, that property holds the
-whole ordered stack and the direct properties are only a render cache
-of the topmost non-hidden layer; otherwise the direct properties are
-the top layer and `tp-layers' holds the layers below it.
-
-When full-stack storage is active, an external direct-property edit
-cannot be assigned to a managed layer safely. Rather than discard it,
-signal `tp-layer-conflict' before decoding or rebuilding the stack."
- (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)))
- (if (tp--entry-authoritative-storage-p belows)
- (progn
- (tp--assert-hidden-render-cache top belows)
- belows)
- (tp--layer-stack-to-list top belows))))
-
-(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).
-
-When any layer in LAYER-LIST is hidden or carries `tp-meta', the
-storage switches to full-stack mode: the direct properties are the
-render projection of the topmost non-hidden layer (or no layer
-properties at all when every layer is hidden) and the `tp-layers'
-property holds the complete ordered LAYER-LIST. `tp--stack-props-to-list'
-reverses either representation."
- (cond
- ((null layer-list) nil)
- ((tp--entry-authoritative-storage-p layer-list)
- (append (tp--entry-render-projection
- (seq-find (lambda (layer)
- (not (tp--stack-hidden-p layer)))
- layer-list))
- (list 'tp-layers layer-list)))
- ((null (cdr layer-list)) (copy-sequence (car layer-list)))
- (t (append (car layer-list)
- (list 'tp-layers (cdr layer-list))))))
+ (assq-delete-all name tp--group-generated-layers)
+ tp-layer-groups (assq-delete-all name tp-layer-groups))
+ nil)
(defun tp--describe-layer-data (name)
- "Collect description data for layer NAME as a plist.
-Returns nil when NAME is not registered in `tp-layer-alist'.
-The returned plist has these keys:
-:name NAME itself.
-:format Storage format: `parameterized' (unified storage with
- a non-empty arglist), `reactive' (flat storage with
- reactive dependencies registered), `unified' (from
- `define-tp' with an empty arglist) or `flat' (old
- direct plist storage).
-:arglist The parameter list for parameterized layers, else nil.
-:body The raw stored body: the unevaluated BODY-FORM for
- unified/parameterized layers, the stored plist for
- flat/reactive layers.
-:props The expanded properties from `tp-layer-props' (with
- tp-name), or a placeholder string for parameterized
- layers, which need arguments
- \(see `tp-layer-props-with-args').
-:reactive-deps List of reactive variable symbols NAME depends on,
- from tp-reactive's `tp-reactive-deps' registry.
-:transform Non-nil when a transform is registered for NAME in
- `tp-layer-transforms'.
-:group The group that generated NAME (from
- `tp--group-generated-layers'), or nil."
- (when-let ((entry (cdr (assoc name tp-layer-alist))))
- (let* ((parameterized (tp-layer-parameterized-p name))
- (reactive (tp--layer-has-reactive-deps-p name))
- (unified (and (= (length entry) 2)
- (or (null (car entry))
- (and (listp (car entry))
- (cl-every #'symbolp (car entry))))))
- (format (cond (parameterized 'parameterized)
- (reactive 'reactive)
- (unified 'unified)
- (t 'flat)))
- (arglist (when parameterized (tp-layer-arglist name)))
- (body (if unified (cadr entry) entry))
- (props (if parameterized
- "parameterized layer: expand with `tp-layer-props-with-args'"
- (tp-layer-props name t)))
- (deps (cl-loop for dep in tp-reactive-deps
- when (assoc name (cdr dep))
- collect (car dep)))
- (transform (and (assoc name tp-layer-transforms) t))
- (group (cl-loop for (group-name . layers)
- in tp--group-generated-layers
- when (memq name layers)
- return group-name)))
- (list :name name
- :format format
- :arglist arglist
- :body body
- :props props
- :reactive-deps deps
- :transform transform
- :group group))))
+ "Return declarative registry data for layer recipe NAME."
+ (when-let ((entry (tp--recipe-entry name tp-layer-alist)))
+ (list :name name
+ :kind 'direct-declaration-recipe
+ :arglist (copy-sequence (car entry))
+ :body (tp--copy-property-value (cadr entry))
+ :props (if (car entry)
+ "parameterized recipe"
+ (tp-layer-props name))
+ :group (cl-loop for (group . generated)
+ in tp--group-generated-layers
+ when (memq name generated)
+ return group))))
;;;###autoload
(defun tp-describe-layer (name)
- "Display a help buffer describing the tp layer NAME.
-NAME is a layer registered in `tp-layer-alist'. Interactively,
-prompt with completion over the registered layers.
-The buffer shows the storage format (flat, unified, parameterized or
-reactive), the raw stored body, the expanded properties (or a
-placeholder for parameterized layers, which need arguments), the
-parameter list, the reactive variables the layer depends on, whether
-a transform is registered, and the group that generated the layer,
-if any."
+ "Display a help buffer describing declaration recipe NAME."
(interactive
- (list (intern (completing-read "Describe tp layer: "
- (mapcar #'car tp-layer-alist)
- nil t))))
+ (list (intern (completing-read "Describe TP recipe: "
+ (mapcar #'car tp-layer-alist) nil t))))
(let ((data (tp--describe-layer-data name)))
- (unless data
- (user-error "No tp layer named `%s'" name))
+ (unless data (user-error "No TP recipe named `%s'" name))
(with-help-window (help-buffer)
- (princ (format "%s is a tp layer.\n\n" name))
- (princ (format "Storage format: %s\n" (plist-get data :format)))
- (when (plist-get data :arglist)
- (princ (format "Arguments: %S\n" (plist-get data :arglist))))
- (princ (format "Stored body: %S\n" (plist-get data :body)))
- (let ((props (plist-get data :props)))
- (princ (format "Expanded props: %s\n"
- (if (stringp props) props (format "%S" props)))))
- (princ (format "Reactive deps: %s\n"
- (if (plist-get data :reactive-deps)
- (mapconcat #'symbol-name
- (plist-get data :reactive-deps) ", ")
- "none")))
- (princ (format "Transform: %s\n"
- (if (plist-get data :transform) "yes" "no")))
+ (princ (format "%s is a TP direct declaration recipe.\n\n" name))
+ (princ (format "Arguments: %S\n" (plist-get data :arglist)))
+ (princ (format "Stored body: %S\n" (plist-get data :body)))
+ (princ (format "Expanded properties: %S\n" (plist-get data :props)))
(when (plist-get data :group)
- (princ (format "Generated by: group %s\n"
+ (princ (format "Generated by group: %s\n"
(plist-get data :group)))))))
-(defun tp--get-layer-by-idx-or-name (layers idx-or-name)
- "Find layer in LAYERS by IDX-OR-NAME.
-Returns (index . layer-props) or nil."
- (cond
- ((integerp idx-or-name)
- (let ((actual-idx (if (< idx-or-name 0)
- (+ (length layers) idx-or-name)
- idx-or-name)))
- (when (and (>= actual-idx 0) (< actual-idx (length layers)))
- (cons actual-idx (nth actual-idx layers)))))
- ((symbolp idx-or-name)
- (cl-loop for layer in layers
- for i from 0
- when (equal idx-or-name (plist-get layer 'tp-name))
- return (cons i layer)))
- (t nil)))
-
(provide 'tp-layer)
;;; tp-layer.el ends here
diff --git a/tp-ops.el b/tp-ops.el
index ab1d41c..0c1924d 100644
--- a/tp-ops.el
+++ b/tp-ops.el
@@ -1,106 +1,36 @@
-;;; tp-ops.el --- Core text property operations for tp -*- lexical-binding: t -*-
+;;; tp-ops.el --- Direct text property operations -*- 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.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
-;; 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 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.
+;; Stateless string and buffer property operations. Named declaration
+;; recipes are expanded by tp-layer, while live content replacement and
+;; reactivity are owned exclusively by tp-surface and tp-reactive.
;;; Code:
(require 'cl-lib)
-(require 'dash)
(require 'tp-core)
(require 'tp-style)
-(require 'tp-reactive)
(require 'tp-layer)
-(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'.
-Signal when the transform fails or returns a non-string value."
- (let ((transform-fn (when layer-name
- (cdr (assoc layer-name tp-layer-transforms)))))
- (if (not transform-fn)
- text
- (let ((result (funcall transform-fn text)))
- (unless (stringp result)
- (error "tp: transform for %s returned non-string %S"
- layer-name result))
- (tp-debug-log " Transform %s: %S -> %S" layer-name text result)
- result))))
-
-(defun tp--merge-embedded-props (embedded props)
- "Merge the EMBEDDED string props plist under PROPS; PROPS win.
-Takes one property run's EMBEDDED plist, so callers preserve every
-interval instead of treating position 0 as representative.
-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 ((present (plist-member result key))
- (existing (plist-get result key)))
- (setq result
- (plist-put result key
- (if present
- (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."
+(defun tp--put-text-property-unless-equal (start end property value object)
+ "Set PROPERTY to VALUE on [START, END) in OBJECT only when needed."
(when (< start end)
- (unless (and (plist-member (text-properties-at start object) key)
- (equal (get-text-property start key object) val)
- (>= (or (next-single-property-change start key object end)
+ (unless (and (plist-member (text-properties-at start object) property)
+ (equal (get-text-property start property object) value)
+ (>= (or (next-single-property-change
+ start property object end)
end)
end))
- (put-text-property start end key val object))))
+ (put-text-property start end property value object))))
-(defun tp--value-after-add (key existing incoming)
- "Return EXISTING after adding INCOMING for property KEY."
+(defun tp--value-after-add (property existing incoming)
+ "Return EXISTING after adding INCOMING for PROPERTY."
(cond
- ((memq key tp-face-properties)
+ ((memq property tp-face-properties)
(tp--prepend-face incoming existing))
((and (listp incoming) (keywordp (car-safe incoming))
(listp existing) (keywordp (car-safe existing)))
@@ -109,1158 +39,418 @@ OBJECT is a string, a buffer, or nil for the current buffer."
(defun tp--props-after-add (existing incoming)
"Return EXISTING with INCOMING applied using `tp-add' semantics."
- (let ((result (copy-sequence existing)))
- (cl-loop
- for (key val) on incoming by #'cddr
- do (setq result
- (plist-put
- result key
- (tp--value-after-add key (plist-get result key) val))))
+ (let ((result (copy-tree existing)))
+ (cl-loop for (property value) on incoming by #'cddr
+ do (setq result
+ (plist-put result property
+ (tp--value-after-add
+ property (plist-get result property) value))))
result))
-(defun tp--apply-props-by-operation (start end props target operation)
- "Apply PROPS to TARGET from START to END according to OPERATION."
- (let ((pos start))
- (while (< pos end)
- (let* ((next (or (next-property-change pos target end) end))
- (existing (text-properties-at pos target)))
- (pcase operation
- (:reset
- (set-text-properties pos next props target))
- (:add
- (set-text-properties
- pos next (tp--props-after-add existing props) target))
- (_
- (cl-loop for (key val) on props by #'cddr
- do (tp--put-text-property-unless-equal
- pos next key val target))))
- (setq pos next)))))
+(defun tp--apply-props-by-operation (start end props object operation)
+ "Apply PROPS to [START, END) in OBJECT according to OPERATION."
+ (pcase operation
+ (:reset (set-text-properties start end props object))
+ (:add
+ (let ((position start))
+ (while (< position end)
+ (let* ((next (or (next-property-change position object end) end))
+ (merged (tp--props-after-add
+ (text-properties-at position object) props)))
+ (set-text-properties position next merged object)
+ (setq position next)))))
+ (_
+ (cl-loop for (property value) on props by #'cddr
+ do (tp--put-text-property-unless-equal
+ start end property value object)))))
-(defun tp--apply-reactive-text-props
- (source props offset &optional target operation)
- "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.
+(defun tp--whole-string-properties (property value rest)
+ "Build whole-string properties from PROPERTY, VALUE and REST."
+ (cond
+ ((and (symbolp property) (tp--is-layer-name-p property))
+ (cons property (if (or value rest) (cons value rest) nil)))
+ (property (cons property (cons value rest)))
+ (t nil)))
-OPERATION is `:reset', `:add', or nil for ordinary set semantics.
-Ordinary set 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)))
- (tp--apply-props-by-operation
- (+ offset istart) (+ offset iend) merged target operation)))))
+(defun tp--parse-region-object (rest)
+ "Return the optional region object from REST, rejecting extra values."
+ (cond
+ ((null rest) nil)
+ ((and (null (cdr rest))
+ (or (bufferp (car rest)) (stringp (car rest))))
+ (car rest))
+ (t
+ (error "Region form takes one properties plist and an optional object"))))
-(defun tp--tp-text-replace
- (start end final-text props object preserve-props operation)
- "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 PROPS-APPLIED) result.
-
-For a string OBJECT a NEW string is built as prefix + FINAL-TEXT +
-suffix, so text outside the region survives. For strings and buffers,
-PROPS are merged under every embedded property interval of FINAL-TEXT
-and applied here through `tp--apply-reactive-text-props'. The final
-non-nil return element tells callers not to flatten PROPS over the
-whole replacement afterward.
-
-For buffers the region text is replaced in place and NEW-END is the
-end of the inserted text.
-
-When PRESERVE-PROPS is non-nil, properties present at START whose
-keys PROPS does not set are re-applied over the replacement.
-OPERATION selects ordinary set, `:reset', or `:add' semantics."
- (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
- when (or (eq operation :add)
- (not (plist-member props key)))
- do (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 props start new-string operation)
- (list props new-end new-string t))
- ;; 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))
- (progn
- (tp--apply-reactive-text-props
- final-text props start object operation)
- (list props end object t))
- ;; 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
- when (or (eq operation :add)
- (not (plist-member props key)))
- do (put-text-property start new-end key val object))
- (tp--apply-reactive-text-props
- final-text props start object operation)
- (list props new-end object t))))))))
-
-(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 selects `:reset', `:merge' (`tp-add'), or ordinary
-`tp-set' 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 PROPS-APPLIED), where PROPS is the
-updated props, NEW-END is the new end position after replacement, and
-NEW-OBJECT is the new string object (only different for strings whose
-text was replaced). PROPS-APPLIED is non-nil when replacement props
-were already applied per embedded interval."
- (let ((operation (pcase merge-mode
- (:reset :reset)
- (:merge :add)
- (_ nil))))
- (if (not (plist-member props 'tp-text))
- ;; tp-text not in props - return unchanged
- (list props end object nil)
- (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)))
- (tp--tp-text-replace
- start end display-text props object preserve-props
- operation))))
- ;; 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)))
- (tp--tp-text-replace start end final-text props
- object preserve-props operation)))
- ;; Other types - return unchanged
- (t (list props end object nil)))))))
+(defun tp--prepare-direct-properties (specification)
+ "Resolve and project direct property SPECIFICATION."
+ (tp--project-text-declarations (tp--ensure-props specification)))
(defun tp--parse-args (start-or-string end-or-prop props-or-val rest
&optional operation)
- "Parse flexible function arguments and return a canonical request.
-Supports multiple calling conventions:
-1. Buffer region: (START END PROPS)
-2. Buffer region with object: (START END PROPS OBJECT)
-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 ...)"
- (let (object start finish props)
- (cond
- ;; First arg is a string - apply to entire string
- ((stringp start-or-string)
- (setq object start-or-string
- start 0
- finish (length start-or-string))
- ;; Check if second arg is a layer/group name or parameterized layer
- (cond
- ;; (tp-set "str" 'layer-name arg ...) - layer with argument and optional extra props
- ((and (symbolp end-or-prop)
- (or (assoc end-or-prop tp-layer-alist)
- (assoc end-or-prop tp-layer-groups))
- props-or-val)
- ;; Build props: (layer-name arg extra-prop1 val1 ...)
- (setq props (cons end-or-prop (cons props-or-val rest))))
- ;; (tp-set "str" 'layer-name) - layer without argument (legacy)
- ((and (symbolp end-or-prop)
- (or (assoc end-or-prop tp-layer-alist)
- (assoc end-or-prop tp-layer-groups))
- (null props-or-val)
- (null rest))
- (setq props (list end-or-prop)))
- ;; Standard flat plist: (tp-set "str" 'prop1 val1 'prop2 val2 ...)
- ;; Always include props-or-val even if it's nil, to handle (tp-set "str" 'prop nil)
- (t
- (setq props (if end-or-prop
- (cons end-or-prop (cons props-or-val rest))
- nil)))))
- ;; First arg is a number - region convention
- ((numberp start-or-string)
+ "Parse a TP mutation call and return a canonical request.
+
+START-OR-STRING and END-OR-PROP are the positional inputs.
+PROPS-OR-VAL is the property specification.
+REST is optional object or call metadata.
+OPERATION is :set, :reset, or :add."
+ (let (object start finish properties mutation public-return)
+ (if (stringp start-or-string)
+ (setq object start-or-string
+ start 0
+ finish (length start-or-string)
+ properties (tp--whole-string-properties
+ end-or-prop props-or-val rest)
+ mutation :copy
+ public-return :object)
+ (unless (numberp start-or-string)
+ (error "Invalid first argument: %S" start-or-string))
(setq start start-or-string
finish end-or-prop
- props props-or-val)
- ;; Check if 4th arg (first of rest) is a buffer or string
- (let ((extra rest))
- (when (and extra (or (bufferp (car extra))
- (stringp (car extra))))
- (setq object (car extra)
- extra (cdr extra)))
- ;; Anything left over is not a valid region-form argument.
- ;; In particular, flat PROP/VAL pairs like (tp-set 1 4 'face 'bold)
- ;; are only supported in the whole-string form; region form takes
- ;; a plist. Signal immediately instead of silently discarding.
- (when extra
- (error "Region form takes a properties plist: (tp-set START END '(PROP VAL ...) &optional OBJECT); flat PROP/VAL arguments like %S are only supported in the whole-string form"
- (car extra)))))
- (t (error "Invalid first argument: %S" start-or-string)))
- ;; Unwrap double-wrapped properties
- (when (and (listp props) (listp (car-safe props)))
- (setq props (car props)))
- ;; Merge duplicate keys in the plist (for single-call property setting)
- ;; This must happen before tp--resolve-props to properly handle face merging
- ;; Use (cdddr props) for O(1) check - need at least 4 elements (2 key-value pairs) for possible duplicates
- (when (and (listp props) (cdddr props))
- (setq props (tp--merge-duplicate-keys props)))
- ;; Resolve props: handles layer/group names and anonymous reactive plists
- (when props
- (setq props (or (tp--resolve-props props) props)))
+ properties props-or-val
+ object (tp--parse-region-object rest)
+ mutation :in-place
+ public-return (if (stringp object) :object :range)))
+ (when (and (listp properties) (listp (car-safe properties)))
+ (setq properties (car properties)))
+ (setq properties (tp--prepare-direct-properties properties))
(let ((range (tp--native-range-from-object object start finish)))
(tp--make-request
:operation operation
:range range
- :props props
- :mutation (if (and (stringp start-or-string)
- (stringp (tp--native-range-object range)))
- :copy
- :in-place)
- :public-return (if (stringp (tp--native-range-object range))
- :object
- :range)))))
+ :props properties
+ :mutation mutation
+ :public-return public-return))))
-(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 (string start end props &optional operation)
+ "Return a copy of STRING with PROPS applied to [START, END)."
+ (let ((result (copy-sequence string)))
+ (tp--apply-props-by-operation
+ (max 0 start) (min end (length result)) props result operation)
+ result))
-(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.
-Preserves the original text property intervals.
-
-MERGE-MODE controls how properties are applied:
- nil or :set - Set properties, preserving existing unspecified ones
- :reset - Completely replace all properties
- :add - Merge properties deeply (for face, prepend symbols)
-
-Returns a new propertized string."
- (let* ((len (length str))
- ;; Ensure bounds are valid
- (start (max 0 start))
- (end (min end len)))
- (cond
- ;; :reset - completely replace properties in the range
- ((eq merge-mode :reset)
- (let ((result (copy-sequence str)))
- (set-text-properties start end props result)
- result))
- ;; :add - deep merge with face prepending
- ((eq merge-mode :add)
- (let ((result (copy-sequence str)))
- (cl-loop
- for (key val) on props by #'cddr
- do (let ((pos start))
- (while (< pos end)
- (let* ((current-val (get-text-property pos key result))
- (new-val (cond
- ((memq key tp-face-properties)
- (tp--prepend-face val current-val))
- ((and (listp val) (keywordp (car-safe val))
- (listp current-val) (keywordp (car-safe current-val)))
- (tp--deep-merge-plist current-val val))
- (t val)))
- (next-change (or (next-single-property-change pos key result end) end)))
- (put-text-property pos next-change key new-val result)
- (setq pos next-change)))))
- result))
- ;; nil/:set - set properties while preserving existing ones
- ;; If applying to the entire string, use propertize for efficiency
- ;; Otherwise, use copy-sequence + put-text-property to apply to specific range
- (t
- (if (and (= start 0) (= end len))
- ;; Entire string: use propertize which creates a new copy and preserves existing properties
- (apply #'propertize str props)
- ;; Partial range: copy string and apply properties to the range
- (let ((result (copy-sequence str)))
- (cl-loop for (key val) on props by #'cddr
- do (put-text-property start end key val result))
- result))))))
+(defun tp--mutate-request (request)
+ "Execute canonical mutation REQUEST and return its public result."
+ (let* ((range (tp--request-range request))
+ (original (tp--native-range-object range))
+ (object (if (eq (tp--request-mutation request) :copy)
+ (copy-sequence original)
+ original))
+ (start (tp--native-range-start range))
+ (end (tp--native-range-end range)))
+ (tp--apply-props-by-operation
+ start end (tp--request-props request) object
+ (tp--request-operation request))
+ (if (eq (tp--request-public-return request) :object)
+ object
+ (cons start end))))
;;;###autoload
(defun tp-propertize (string declarations)
"Return a copy of STRING styled by native DECLARATIONS.
-DECLARATIONS pass through TP's property schemas, cascade, and projector.
-Ordinary function values remain literal text-property values."
+Declarations pass through TP's direct property policy and projection core."
(unless (stringp string)
(signal 'wrong-type-argument (list 'stringp string)))
(tp--apply-props-to-string
- string 0 (length string)
- (tp--project-text-declarations declarations)))
+ string 0 (length string) (tp--project-text-declarations declarations)))
;;;###autoload
(defun tp-apply (buffer start end declarations)
"Apply native DECLARATIONS once to BUFFER from START to END.
-The operation preserves text and direct properties not named by DECLARATIONS.
-Return the committed range as a START . END cons."
- (let* ((target (get-buffer buffer))
- (_range (tp--validate-buffer-range target start end))
- (range (tp--native-range-from-object target start end))
- (properties (tp--project-text-declarations declarations)))
+Preserve text and direct properties not named by DECLARATIONS, then return the
+committed range as a START . END cons."
+ (let ((target (get-buffer buffer)))
+ (tp--validate-buffer-range target start end)
(tp--apply-props-by-operation
- (tp--native-range-start range) (tp--native-range-end range)
- properties target nil)
- (cons (tp--native-range-start range) (tp--native-range-end range))))
+ start end (tp--project-text-declarations declarations) target nil)
+ (cons start end)))
+;;;###autoload
(defun tp-set (start-or-string &optional end-or-prop props-or-val &rest rest)
- "Set text properties on string or buffer region.
+ "Set direct text properties on a string or buffer range.
+String whole-object calls return a new string. Explicit string ranges and
+buffer ranges mutate their target in place. Named recipes expand to ordinary
+properties and do not create live identity.
-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.
-For tp-text, props override embedded text properties.
-
-**String Modification Behavior:**
-- Entire string form (tp-set STRING ...): Returns a NEW propertized string
- (original is not modified). Uses `propertize' internally.
-- Region form with string (tp-set START END PROPS STRING): Modifies the
- original string in-place using `put-text-property'.
-- Buffer forms: Always modify in-place.
-
-Returns: For buffers, (START . END) cons. For strings, the result string."
- ;; Determine if this is the "entire string" form (first arg is a string)
- (let ((entire-string-form (stringp start-or-string)))
- (let* ((request (tp--parse-args start-or-string end-or-prop
- props-or-val rest :set))
- (range (tp--request-range request))
- (object (tp--native-range-object range))
- (start (tp--native-range-start range))
- (finish (tp--native-range-end range))
- (props (tp--request-props request)))
- ;; Handle tp-text property specially - :override means props override embedded props
- (pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied)
- (tp--handle-tp-text-property start finish props object t :override)))
- (setq props new-props finish new-finish object new-object)
- (cond
- (props-applied
- (if (stringp object)
- object
- (tp--ops-register-layer-buffer props object)
- (cons start finish)))
- ;; Entire string form: create a new propertized string (non-destructive)
- ((and (stringp object) entire-string-form)
- (tp--apply-props-to-string object start finish props nil))
- ;; Region form with string object: modify in-place
- ((stringp object)
- (let ((has-existing-props (text-properties-at start object)))
- (if (and (not has-existing-props)
- (= start (or (next-single-property-change
- start nil object finish)
- finish)))
- (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))))
- object)
- ;; Buffer: modify in place
- (t
- (let ((has-existing-props (text-properties-at start object)))
- (if (and (not has-existing-props)
- (= start (or (next-single-property-change
- start nil object finish)
- finish)))
- (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)))))))
+START-OR-STRING, END-OR-PROP, PROPS-OR-VAL and REST are parsed by
+`tp--parse-args` and then committed by `tp--mutate-request`."
+ (tp--mutate-request
+ (tp--parse-args start-or-string end-or-prop props-or-val rest :set)))
+;;;###autoload
(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.
+ "Replace all text properties on a string or buffer range.
-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
- (original is not modified). Uses `propertize' internally.
-- Region form with string (tp-reset START END PROPS STRING): Modifies the
- original string in-place using `set-text-properties'.
-- Buffer forms: Always modify in-place.
-
-Returns: For buffers, (START . END) cons. For strings, the result string."
- ;; Determine if this is the "entire string" form (first arg is a string)
- (let ((entire-string-form (stringp start-or-string)))
- (let* ((request (tp--parse-args start-or-string end-or-prop
- props-or-val rest :reset))
- (range (tp--request-range request))
- (object (tp--native-range-object range))
- (start (tp--native-range-start range))
- (finish (tp--native-range-end range))
- (props (tp--request-props request)))
- ;; Handle tp-text property - :reset means only use props, ignore embedded props
- (pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied)
- (tp--handle-tp-text-property start finish props object nil :reset)))
- (setq props new-props finish new-finish object new-object)
- (cond
- (props-applied
- (if (stringp object)
- object
- (tp--ops-register-layer-buffer props object)
- (cons start finish)))
- ;; Entire string form: create a new propertized string (non-destructive)
- ((and (stringp object) entire-string-form)
- (tp--apply-props-to-string object start finish props :reset))
- ;; Region form with string object: modify in-place
- ((stringp object)
- (set-text-properties start finish props object)
- object)
- ;; Buffer: modify in place
- (t
- (set-text-properties start finish props object)
- (tp--ops-register-layer-buffer props object)
- (cons start finish)))))))
+START-OR-STRING, END-OR-PROP, PROPS-OR-VAL and REST are passed through
+`tp--parse-args` as in `tp-set`."
+ (tp--mutate-request
+ (tp--parse-args start-or-string end-or-prop props-or-val rest :reset)))
+;;;###autoload
(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.
+ "Merge direct text properties into a string or buffer range.
+Face-family properties compose and nested plist values merge recursively.
-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
+START-OR-STRING, END-OR-PROP, PROPS-OR-VAL and REST are passed through
+`tp--parse-args` as in `tp-set` and `tp-reset`."
+ (tp--mutate-request
+ (tp--parse-args start-or-string end-or-prop props-or-val rest :add)))
-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.
-For tp-text, embedded text properties are merged with props.
+(defun tp--property-intervals (object start end property path)
+ "Return PROPERTY intervals in OBJECT between START and END using PATH."
+ (let ((position start) intervals)
+ (while (< position end)
+ (let* ((props (text-properties-at position object))
+ (member (plist-member props property))
+ (next (or (next-single-property-change
+ position property object end)
+ end)))
+ (when member
+ (push (list position next
+ (if path
+ (tp--get-nested (cadr member) path)
+ (cadr member)))
+ intervals))
+ (setq position next)))
+ (nreverse intervals)))
-**String Modification Behavior:**
-- Entire string form (tp-add STRING ...): Returns a NEW propertized string
- (original is not modified). Uses `propertize' internally.
-- Region form with string (tp-add START END PROPS STRING): Modifies the
- original string in-place using `put-text-property'.
-- Buffer forms: Always modify in-place.
+(defun tp--all-property-intervals (object start end)
+ "Return all nonempty property intervals in OBJECT from START to END."
+ (let ((position start) intervals)
+ (while (< position end)
+ (let* ((props (text-properties-at position object))
+ (next (or (next-property-change position object end) end)))
+ (when props (push (list position next props) intervals))
+ (setq position next)))
+ (nreverse intervals)))
-Returns: For buffers, (START . END) cons. For strings, the result string."
- ;; Determine if this is the "entire string" form (first arg is a string)
- (let ((entire-string-form (stringp start-or-string)))
- (let* ((request (tp--parse-args start-or-string end-or-prop
- props-or-val rest :add))
- (range (tp--request-range request))
- (object (tp--native-range-object range))
- (start (tp--native-range-start range))
- (finish (tp--native-range-end range))
- (props (tp--request-props request)))
- ;; 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 ,props-applied)
- (tp--handle-tp-text-property start finish props object t :merge)))
- (setq props new-props finish new-finish object new-object)
- (cond
- (props-applied
- (if (stringp object)
- object
- (tp--ops-register-layer-buffer props object)
- (cons start finish)))
- ;; Entire string form: create a new propertized string (non-destructive)
- ((and (stringp object) entire-string-form)
- (if has-tp-text
- (tp--apply-props-to-string object start finish props :reset)
- (tp--apply-props-to-string object start finish props :add)))
- ;; Region form with string object: modify in-place with deep merging
- ((stringp object)
- (let ((pos start))
- (while (< pos finish)
- (let* ((current-props (text-properties-at pos object))
- (next-pos (or (next-property-change
- pos object finish)
- finish)))
- (cl-loop
- for (key val) on props by #'cddr
- do (put-text-property
- pos next-pos key
- (tp--value-after-add
- key (plist-get current-props key) val)
- object))
- (setq pos next-pos))))
- object)
- ;; Buffer: modify in place with deep merging
- (t
- (let ((pos start))
- (while (< pos finish)
- (let* ((current-props (text-properties-at pos object))
- (next-pos (or (next-property-change
- pos object finish)
- finish)))
- (cl-loop
- for (key val) on props by #'cddr
- do (put-text-property
- pos next-pos key
- (tp--value-after-add
- key (plist-get current-props key) val)
- object))
- (setq pos next-pos))))
- (tp--ops-register-layer-buffer props object)
- (cons start finish))))))))
+(defun tp--get-string (string selector args)
+ "Implement the whole-string `tp-get' form for STRING, SELECTOR and ARGS.
-(defun tp-get (start-or-string &optional end-or-property &rest args)
- "Get text property value(s) with support for nested sub-properties.
-Returns list of (START END VALUE) intervals.
-Use `tp-at' for single position queries.
-OBJECT defaults to current buffer.
-
-Calling conventions:
- (tp-get STRING [PROPERTY [SUB-KEYS...]]) - entire string
- (tp-get STRING START END [PROPERTY ...]) - range within STRING
- (tp-get START END [PROPERTY ...] [OBJECT]) - region form
-String positions are 0-based; buffer positions are 1-based."
+STRING is searched from 0 to its full length. SELECTOR and ARGS mirror
+the normal `tp-get' arguments for a whole-string query."
(cond
- ;; (tp-get STRING ...) - entire string
- ;; Returns list of (START END VALUE) intervals for all property values
- ((stringp start-or-string)
- (let* ((str start-or-string)
- (len (length str))
- (property nil)
- (sub-path nil))
+ ((null selector)
+ (tp--all-property-intervals string 0 (length string)))
+ ((numberp selector)
+ (let ((end (car args)))
+ (unless (numberp end)
+ (error "TP-GET string range requires a numeric END"))
+ (apply #'tp-get selector end (append (cdr args) (list string)))))
+ ((listp selector)
+ (tp--property-intervals
+ string 0 (length string) (car selector) (cdr selector)))
+ ((symbolp selector)
+ (tp--property-intervals string 0 (length string) selector args))
+ (t (error "Invalid tp-get selector: %S" selector))))
+
+(defun tp--get-region-options (args)
+ "Parse region-form `tp-get' ARGS into (PROPERTY PATH OBJECT)."
+ (let (property path object)
+ (when args
(cond
- ;; (tp-get str) - return all property intervals
- ((null end-or-property)
- (let ((intervals nil)
- (pos 0))
- (while (< pos len)
- (let* ((current-props (text-properties-at pos str))
- (next-pos (or (next-property-change pos str len) len)))
- (when current-props
- (push (list pos next-pos current-props) intervals))
- (setq pos next-pos)))
- (nreverse intervals)))
- ;; (tp-get str START END [PROPERTY [SUB-KEYS...]]) - range within
- ;; the string, consistent with the buffer region form. Positions
- ;; are 0-based as everywhere else for strings.
- ((numberp end-or-property)
- (let ((range-start end-or-property)
- (range-end (car args)))
- (unless (numberp range-end)
- (error "tp-get: string range form requires a numeric END after START, got %S"
- range-end))
- ;; Delegate to the region form with the string as OBJECT.
- (apply #'tp-get range-start range-end
- (append (cdr args) (list str)))))
- ;; (tp-get str '(face :foreground)) - property path as list
- ((listp end-or-property)
- (setq property (car end-or-property))
- (setq sub-path (cdr end-or-property))
- (let ((intervals nil)
- (pos 0))
- (while (< pos len)
- (let* ((prop-value (get-text-property pos property str))
- (next-pos (or (next-single-property-change
- pos property str len)
- len))
- (value (if sub-path
- (tp--get-nested prop-value sub-path)
- prop-value)))
- (when value
- (push (list pos next-pos value) intervals))
- (setq pos next-pos)))
- (nreverse intervals)))
- ;; (tp-get str 'face ...) - property as symbol with optional sub-path
- ((symbolp end-or-property)
- (setq property end-or-property)
- (setq sub-path args)
- (let ((intervals nil)
- (pos 0))
- (while (< pos len)
- (let* ((prop-value (get-text-property pos property str))
- (next-pos (or (next-single-property-change
- pos property str len)
- len))
- (value (if sub-path
- (tp--get-nested prop-value sub-path)
- prop-value)))
- (when value
- (push (list pos next-pos value) intervals))
- (setq pos next-pos)))
- (nreverse intervals))))))
- ;; (tp-get START END ...) - range form
- ((and (numberp start-or-string)
- (numberp end-or-property))
- (let* ((start start-or-string)
- (end end-or-property)
- (rest-args args)
- (property nil)
- (sub-path nil)
- (object nil))
- ;; Parse remaining args
- (when rest-args
- (cond
- ;; Property path as list: (tp-get 5 20 '(face :underline) obj)
- ((listp (car rest-args))
- (let ((prop-path (car rest-args)))
- (setq property (car prop-path))
- (setq sub-path (cdr prop-path))
- (setq object (cadr rest-args))))
- ;; Property as symbol
- ((symbolp (car rest-args))
- (setq property (car rest-args))
- (setq rest-args (cdr rest-args))
- ;; Remaining args could be sub-path and/or object
- (when rest-args
- (if (or (bufferp (car (last rest-args)))
- (stringp (car (last rest-args))))
- (progn
- (setq object (car (last rest-args)))
- (setq sub-path (butlast rest-args)))
- (setq sub-path rest-args))))
- ;; First arg is object (buffer/string)
- ((or (bufferp (car rest-args)) (stringp (car rest-args)))
- (setq object (car rest-args)))))
+ ((listp (car args))
+ (setq property (caar args)
+ path (cdar args)
+ object (cadr args)))
+ ((symbolp (car args))
+ (setq property (pop args))
+ (when (and args (or (bufferp (car (last args)))
+ (stringp (car (last args)))))
+ (setq object (car (last args))
+ args (butlast args)))
+ (setq path args))
+ ((or (bufferp (car args)) (stringp (car args)))
+ (setq object (car args)))))
+ (list property path object)))
+
+;;;###autoload
+(defun tp-get (start-or-string &optional end-or-property &rest args)
+ "Return property intervals from a string or buffer range.
+
+START-OR-STRING and END-OR-PROPERTY are the query range.
+ARGS are passed to region parsing and property expansion logic.
+
+Use `tp-at' for a single position. Explicit nil values remain distinguishable
+from absent properties because intervals are emitted only for present keys."
+ (if (stringp start-or-string)
+ (tp--get-string start-or-string end-or-property args)
+ (unless (and (numberp start-or-string) (numberp end-or-property))
+ (error "Invalid arguments to tp-get"))
+ (pcase-let* ((`(,property ,path ,object) (tp--get-region-options args))
+ (target (or object (current-buffer))))
(if property
- ;; Get specific property from range - return list of (START END VALUE) for all intervals
- (let ((pos start)
- (intervals nil))
- (while (< pos end)
- (let* ((prop-value (get-text-property pos property object))
- (next-pos (or (next-single-property-change
- pos property object end)
- end))
- (value (if sub-path
- (tp--get-nested prop-value sub-path)
- prop-value)))
- (when value
- (push (list pos next-pos value) intervals))
- (setq pos next-pos)))
- (nreverse intervals))
- ;; Get all properties from range - return list of (START END PLIST) intervals
- (let ((intervals nil)
- (pos start)
- (obj (or object (current-buffer))))
- (while (< pos end)
- (let* ((current-props (text-properties-at pos obj))
- (next-pos (or (next-property-change pos obj end) end)))
- (when current-props
- (push (list pos next-pos current-props) intervals))
- (setq pos next-pos)))
- (nreverse intervals)))))
- (t (error "Invalid arguments to tp-get"))))
+ (tp--property-intervals
+ target start-or-string end-or-property property path)
+ (tp--all-property-intervals
+ target start-or-string end-or-property)))))
-(defun tp-at (pos &optional property-or-object object)
- "Get text properties at POS in OBJECT, optionally filtered by PROPERTY.
-
-This function supports multiple calling conventions:
-
-1. Get all properties at position:
- (tp-at POS)
- (tp-at POS OBJECT)
-
-2. Get specific property at position:
- (tp-at POS PROPERTY)
- (tp-at POS PROPERTY OBJECT)
-
-3. Get nested sub-property at position:
- (tp-at POS \\='(PROPERTY SUB-KEY ...))
- (tp-at POS \\='(PROPERTY SUB-KEY ...) OBJECT)
-
-POS is the position to query.
-PROPERTY-OR-OBJECT can be a property symbol/list, or an object (buffer/string).
-OBJECT is the buffer or string to query; nil defaults to current buffer.
-
-For strings, positions are 0-indexed.
-For buffers, positions are 1-indexed.
-
-Examples:
- ;; Get all properties at position 5 in current buffer
- (tp-at 5)
- ;; Get all properties at position 0 in string
- (tp-at 0 my-string)
- ;; Get face property at position 5
- (tp-at 5 \\='face)
- ;; Get face property at position 0 in string
- (tp-at 0 \\='face my-string)
- ;; Get nested sub-property
- (tp-at 5 \\='(face :foreground))
- (tp-at 5 \\='(face :box :color))
- (tp-at 5 \\='(display :width))"
- (let ((property nil)
- (sub-path nil)
- (obj nil))
- ;; Parse arguments
+;;;###autoload
+(defun tp-at (position &optional property-or-object object)
+ "Return text properties at POSITION in OBJECT.
+PROPERTY-OR-OBJECT may be a property symbol, a nested property path, or the
+target string/buffer itself."
+ (let (property path target)
(cond
- ;; property-or-object is nil - just get all props
- ((null property-or-object)
- (setq obj nil))
- ;; property-or-object is a buffer/string - it's the object
+ ((null property-or-object))
((or (bufferp property-or-object) (stringp property-or-object))
- (setq obj property-or-object))
- ;; property-or-object is a symbol - it's a property
+ (setq target property-or-object))
((symbolp property-or-object)
- (setq property property-or-object
- obj object))
- ;; property-or-object is a list - it's a property path
+ (setq property property-or-object target object))
((listp property-or-object)
(setq property (car property-or-object)
- sub-path (cdr property-or-object)
- obj object))
- (t (error "Invalid PROPERTY-OR-OBJECT argument: %S" property-or-object)))
- ;; Get the value
+ path (cdr property-or-object)
+ target object))
+ (t (error "Invalid property or object: %S" property-or-object)))
(if property
- (let ((prop-value (get-text-property pos property obj)))
- (if sub-path
- (tp--get-nested prop-value sub-path)
- prop-value))
- (text-properties-at pos obj))))
+ (let ((value (get-text-property position property target)))
+ (if path (tp--get-nested value path) value))
+ (text-properties-at position target))))
-(defun tp-member (pos property &optional object)
- "Return (PROPERTY VALUE) if PROPERTY is present at POS in OBJECT.
-Return nil when the property is absent. Unlike `tp-at' (which
-returns nil both for an absent property and for a property whose
-value is nil), this distinguishes \"present with value nil\" from
-\"not present\", like `plist-member' does for plists.
-
-OBJECT is a string or buffer; nil means the current buffer.
-
-Examples:
- (tp-member 1 \\='face) ;; => (face bold) when face is bold
- (tp-member 1 \\='face) ;; => (face nil) when face is present but nil
- (tp-member 1 \\='face) ;; => nil when face is absent"
- (let ((plist (text-properties-at pos object)))
- (when-let ((cell (plist-member plist property)))
- (list (car cell) (cadr cell)))))
+;;;###autoload
+(defun tp-member (position property &optional object)
+ "Return (PROPERTY VALUE) when PROPERTY is present at POSITION in OBJECT."
+ (when-let ((member (plist-member
+ (text-properties-at position object) property)))
+ (list (car member) (cadr member))))
(defun tp--value-after-sub-removal (value sub-property)
"Return VALUE after removing SUB-PROPERTY, or nil when empty."
(tp--remove-sub-from-face-value value sub-property))
-(defun tp--remove-sub (start end property sub-property &optional object)
- "Remove SUB-PROPERTY from PROPERTY between START and END in OBJECT."
- (let* ((pos start))
- (while (< pos end)
- (let* ((current-value (get-text-property pos property object))
- (next-pos (or (next-single-property-change pos property object end) end))
- (new-value (tp--value-after-sub-removal
- current-value sub-property)))
- (if new-value
- (put-text-property pos next-pos property new-value object)
- (remove-text-properties pos next-pos (list property nil) object))
- (setq pos next-pos))))
- nil)
+(defun tp--remove-sub (start end property sub-property object)
+ "Remove SUB-PROPERTY from PROPERTY on [START, END) in OBJECT."
+ (let ((position start))
+ (while (< position end)
+ (let* ((next (or (next-single-property-change
+ position property object end)
+ end))
+ (value (get-text-property position property object))
+ (updated (tp--value-after-sub-removal value sub-property)))
+ (if updated
+ (put-text-property position next property updated object)
+ (remove-text-properties position next (list property nil) object))
+ (setq position next)))))
-(defun tp--remove-nested-keys (plist keys-to-remove)
- "Remove KEYS-TO-REMOVE from PLIST.
-Returns the modified plist, or nil if empty after removal."
- (let ((result (copy-sequence plist)))
- (dolist (key keys-to-remove)
- (cl-remf result key))
- (if (null result) nil result)))
-
-(defun tp--remove-property (start end property object)
- "Internal function to remove PROPERTY from START to END in OBJECT.
-PROPERTY can be a symbol (including layer names) or a list for nested removal.
-If PROPERTY is a layer name, all properties added by that layer are removed."
- (cond
- ;; Simple property removal (or layer name)
- ((symbolp property)
- ;; Check if this is a layer name
- (if (tp--is-layer-name-p property)
- ;; Layer name - need to remove all properties added by the layer
- (let ((pos start))
- (while (< pos end)
- (let* ((tp-name-at-pos (get-text-property pos 'tp-name object))
- (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 dummy args (t per
- ;; parameter) since we only need key names
- (let* ((layer-props
- (cond
- ((tp-layer-parameterized-p property)
- (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)
- (when-let ((layer-props-list (tp-group-props property t)))
- (tp--build-layer-props layer-props-list)))))
- (props-to-remove
- (when layer-props
- (cl-loop for (key _val) on layer-props by #'cddr
- collect key into keys
- finally return (if (memq 'tp-name keys)
- keys
- (cons 'tp-name keys))))))
- (dolist (prop-key (or props-to-remove (list property 'tp-name)))
- (remove-text-properties pos next-pos (list prop-key nil) object))))
- (setq pos next-pos))))
- ;; Regular property removal
- (remove-text-properties start end (list property nil) object)))
- ;; Nested property removal
- ((listp property)
- (let* ((prop-name (car property))
- (sub-key (cadr property))
- (nested-keys (caddr property)))
- (if (null nested-keys)
- ;; Remove sub-key from property
- (tp--remove-sub start end prop-name sub-key object)
- ;; Remove nested keys from sub-key
- (let ((pos start))
- (while (< pos end)
- (let* ((current-value (get-text-property pos prop-name object))
- (next-pos (or (next-single-property-change
- pos prop-name object end)
- end)))
- (when current-value
- (let* ((sub-value
- (if (and (listp current-value) (keywordp (car current-value)))
- (plist-get current-value sub-key)
- nil))
- (new-sub-value
- (when (and (listp sub-value) (keywordp (car sub-value)))
- (tp--remove-nested-keys sub-value nested-keys)))
- (new-value
- (cond
- ((and (listp current-value) (keywordp (car current-value)))
- (let ((result (copy-sequence current-value)))
- (if new-sub-value
- (plist-put result sub-key new-sub-value)
- ;; Remove sub-key entirely if no keys remain
- (cl-remf result sub-key))
- (if (null result) nil result)))
- (t current-value))))
- (if new-value
- (put-text-property pos next-pos prop-name new-value object)
- (remove-text-properties pos next-pos (list prop-name nil) object))))
- (setq pos next-pos)))))))))
-
-(defun tp-remove (start-or-string end-or-prop &optional prop-or-sub &rest rest)
- "Remove properties from text.
-
-This function supports multiple calling conventions:
-
-1. Buffer region with property:
- (tp-remove START END PROPERTY)
- (tp-remove START END PROPERTY OBJECT)
-
-2. Buffer region with nested property:
- (tp-remove START END \\='(PROPERTY SUB-KEY))
- (tp-remove START END \\='(PROPERTY SUB-KEY (NESTED-KEYS...)))
-
-3. Entire string with properties to remove:
- (tp-remove STRING PROP1 PROP2 ...)
- (tp-remove \"Hello\" \\='face \\='help-echo)
-
-4. Entire string with sub-property removal:
- (tp-remove STRING PROPERTY SUB-KEY)
- (tp-remove \"Hello\" \\='face :underline)
-
-5. Entire string with nested sub-property removal:
- (tp-remove STRING PROPERTY SUB-KEY \\='(NESTED-KEYS...))
- (tp-remove \"Hello\" \\='face :underline \\='(:style :position))
-
-**String Modification Behavior:**
-- Entire string form (tp-remove STRING ...): Returns a NEW string with
- properties removed (original is not modified). Uses `propertize' internally.
-- Region form with string (tp-remove START END PROP STRING): Modifies the
- original string in-place using `remove-text-properties'.
-- Buffer forms: Always modify in-place.
-
-Returns: For buffers, nil. For entire string forms, a new string."
- (cond
- ;; First arg is a string - apply to entire string, non-destructively
- ((stringp start-or-string)
- (let* ((str start-or-string)
- (start 0)
- (end (length str)))
- (cond
- ;; (tp-remove str 'face :underline '(:style :position)) - nested sub-property removal with list
- ((and (symbolp end-or-prop)
- (keywordp prop-or-sub)
- rest
- (listp (car rest)))
- (tp--remove-property-from-string str start end (list end-or-prop prop-or-sub (car rest))))
- ;; (tp-remove str 'face :underline :position :style ...) - nested sub-property removal with keywords
- ((and (symbolp end-or-prop)
- (keywordp prop-or-sub)
- rest
- (keywordp (car rest)))
- (tp--remove-property-from-string str start end (list end-or-prop prop-or-sub rest)))
- ;; (tp-remove str 'face :underline) - sub-property removal
- ((and (symbolp end-or-prop) (keywordp prop-or-sub))
- (tp--remove-sub-from-string str start end end-or-prop prop-or-sub))
- ;; (tp-remove str 'face 'help-echo ...) - multiple properties
- ((symbolp end-or-prop)
- ;; Splice REST so the 3rd and later properties are kept, and
- ;; drop nils (nil is a symbol and would otherwise ride along
- ;; when PROP-OR-SUB is not given).
- (let ((props-to-remove (cl-remove-if-not
- (lambda (p) (and p (symbolp p)))
- (cons end-or-prop (cons prop-or-sub rest)))))
- (tp--remove-props-from-string str start end props-to-remove)))
- ;; (tp-remove str '(face :underline)) - nested property spec
- ((listp end-or-prop)
- (tp--remove-property-from-string str start end end-or-prop))
- (t str))))
- ;; First arg is a number - buffer region
- ((numberp start-or-string)
- (let* ((start start-or-string)
- (end end-or-prop)
- (property prop-or-sub)
- (object (car rest)))
- (tp--remove-property start end property object)
- nil))
- (t (error "Invalid arguments to tp-remove"))))
-
-(defun tp--remove-props-from-string (str start end props-to-remove)
- "Create a new string from STR with PROPS-TO-REMOVE removed from START to END.
-PROPS-TO-REMOVE can include layer names, which will be expanded to include
-all properties that the layer adds.
-For face properties from layers, subtracts the layer's face contribution
-instead of removing the entire face property.
-Operates per property interval, so every interval keeps its own
-remaining properties (intervals are never overwritten with properties
-sampled at START).
-Returns a new string (original is not modified)."
- (let ((result (copy-sequence str)))
- (tp--map-intervals
- str start end
- (lambda (istart iend existing-props)
- (let (;; Remaining face after layer subtractions (this interval)
- (remaining-face nil)
- ;; Track if face was modified by layer subtraction
- (face-was-modified nil)
- ;; Collect all properties to remove entirely (non-face or non-layer)
- (props-to-remove-entirely nil))
- ;; Process each property to remove against this interval's props
- (dolist (prop props-to-remove)
- (if (tp--is-layer-name-p prop)
- ;; Layer name - get its face contribution and subtract from face
- (let* ((layer-prop-value (plist-get existing-props prop))
- (layer-face (tp--get-layer-face-contribution prop layer-prop-value)))
- ;; Subtract layer's face from the current face
- (when layer-face
- (let ((current-face (or remaining-face
- (plist-get existing-props 'face))))
- (setq remaining-face
- (tp--subtract-face-from-face-value current-face layer-face))
- ;; Mark that we processed the face (even if result is nil)
- (setq face-was-modified t)))
- ;; Add the layer property itself to remove list
- (push prop props-to-remove-entirely)
- ;; Also add tp-name if it matches
- (when (eq (plist-get existing-props 'tp-name) prop)
- (push 'tp-name props-to-remove-entirely)))
- ;; Non-layer property - remove entirely
- (push prop props-to-remove-entirely)))
- ;; Build this interval's final properties
- (let ((final-props
- (let ((res nil))
- (cl-loop for (key val) on existing-props by #'cddr
- do (cond
- ;; Face property with layer subtraction
- ((and (eq key 'face) face-was-modified)
- (when remaining-face
- (setq res (plist-put res key remaining-face))))
- ;; Property to remove entirely
- ((memq key props-to-remove-entirely)
- nil) ; skip
- ;; Keep other properties
- (t (setq res (plist-put res key val)))))
- res)))
- (set-text-properties istart iend final-props result)))))
+(defun tp--remove-nested-keys (plist keys)
+ "Return PLIST without KEYS, or nil when nothing remains."
+ (let ((result (copy-tree plist)))
+ (dolist (key keys) (cl-remf result key))
result))
-(defun tp--remove-sub-from-string (str start end property sub-key)
- "Create a new string from STR with SUB-KEY removed from PROPERTY.
-Returns a new string (original is not modified).
-Handles complex face values that contain a mix of symbols and plists.
-Operates per property interval, so every interval keeps its own
-remaining properties."
- (let ((result (copy-sequence str)))
- (tp--map-intervals
- str start end
- (lambda (istart iend existing-props)
- (let* ((prop-value (plist-get existing-props property))
- (new-value (tp--value-after-sub-removal prop-value sub-key))
- (final-props (let ((res nil))
- (cl-loop for (key val) on existing-props by #'cddr
- unless (and (eq key property)
- (null new-value))
- do (setq res
- (plist-put
- res key
- (if (eq key property)
- new-value
- val))))
- res)))
- (set-text-properties istart iend final-props result))))
- result))
-
-(defun tp--remove-property-from-string (str start end property-spec)
- "Create a new string from STR with PROPERTY-SPEC removed from START to END.
-PROPERTY-SPEC can be a symbol or a nested spec like (PROPERTY SUB-KEY ...).
-Returns a new string (original is not modified)."
- (cond
- ((symbolp property-spec)
- (tp--remove-props-from-string str start end (list property-spec)))
- ((listp property-spec)
- (let ((property (car property-spec))
- (sub-key (cadr property-spec))
- (nested-keys (caddr property-spec)))
- (cond
- ;; Nested sub-property removal - per interval so every interval
- ;; keeps its own remaining properties
- ((and sub-key nested-keys)
- (let ((result (copy-sequence str)))
- (tp--map-intervals
- str start end
- (lambda (istart iend existing-props)
- (let* ((prop-value (plist-get existing-props property))
- (new-value (if (and prop-value (listp prop-value))
- (tp--remove-nested-sub-keys
- prop-value sub-key nested-keys)
- ;; Not a plist-shaped value (e.g. a bare
- ;; face symbol) - the nested spec does
- ;; not apply; keep the value unchanged.
- prop-value))
- (final-props (let ((res nil))
- (cl-loop for (key val) on existing-props by #'cddr
- do (setq res (plist-put res key
- (if (eq key property)
- new-value
- val))))
- res)))
- (set-text-properties istart iend final-props result))))
- result))
- ;; Simple sub-property removal
- (sub-key
- (tp--remove-sub-from-string str start end property sub-key))
- ;; Just a property name
- (t
- (tp--remove-props-from-string str start end (list property))))))
- (t str)))
-
(defun tp--remove-nested-sub-keys (plist sub-key nested-keys)
- "Remove NESTED-KEYS from the SUB-KEY value within PLIST.
-Returns a new plist (does not modify the original)."
- (let* ((sub-value (plist-get plist sub-key))
- (keys-to-remove (if (listp nested-keys) nested-keys (list nested-keys)))
- (new-sub-value (when (and sub-value (listp sub-value))
- (let ((result nil))
- (cl-loop for (k v) on sub-value by #'cddr
- unless (memq k keys-to-remove)
- do (setq result (plist-put result k v)))
- result))))
- (if new-sub-value
- ;; Build a new plist with the updated sub-value
- (let ((result nil))
- (cl-loop for (k v) on plist by #'cddr
- do (setq result (plist-put result k
- (if (eq k sub-key)
- new-sub-value
- v))))
- result)
- ;; Remove the sub-key entirely if no value left
- (let ((result nil))
- (cl-loop for (k v) on plist by #'cddr
- unless (eq k sub-key)
- do (setq result (plist-put result k v)))
- result))))
+ "Remove NESTED-KEYS from SUB-KEY within PLIST."
+ (let* ((result (copy-tree plist))
+ (sub-value (plist-get result sub-key))
+ (updated (when (listp sub-value)
+ (tp--remove-nested-keys
+ sub-value
+ (if (listp nested-keys) nested-keys
+ (list nested-keys))))))
+ (if updated
+ (plist-put result sub-key updated)
+ (cl-remf result sub-key))
+ result))
+
+(defun tp--remove-nested-property (start end property sub-key nested object)
+ "Remove NESTED keys below PROPERTY and SUB-KEY from START to END in OBJECT."
+ (let ((position start))
+ (while (< position end)
+ (let* ((next (or (next-single-property-change
+ position property object end)
+ end))
+ (value (get-text-property position property object)))
+ (when (listp value)
+ (let ((updated (tp--remove-nested-sub-keys value sub-key nested)))
+ (if updated
+ (put-text-property position next property updated object)
+ (remove-text-properties
+ position next (list property nil) object))))
+ (setq position next)))))
+
+(defun tp--remove-property (start end property object)
+ "Remove PROPERTY specification from [START, END) in OBJECT."
+ (cond
+ ((symbolp property)
+ (remove-text-properties start end (list property nil) object))
+ ((and (listp property) (symbolp (car property)))
+ (pcase-let ((`(,name ,sub-key ,nested) property))
+ (cond
+ (nested (tp--remove-nested-property
+ start end name sub-key nested object))
+ (sub-key (tp--remove-sub start end name sub-key object))
+ (t (remove-text-properties start end (list name nil) object)))))
+ (t (error "Invalid property removal spec: %S" property))))
+
+(defun tp--remove-properties-from-string (string properties)
+ "Return a copy of STRING without top-level PROPERTIES."
+ (let ((result (copy-sequence string)))
+ (dolist (property properties)
+ (tp--remove-property 0 (length result) property result))
+ result))
+
+(defun tp--remove-property-from-string (string start end property)
+ "Return a copy of STRING with PROPERTY removed from [START, END)."
+ (let ((result (copy-sequence string)))
+ (tp--remove-property start end property result)
+ result))
+
+(defun tp--remove-sub-from-string (string start end property sub-key)
+ "Return a copy of STRING without PROPERTY's SUB-KEY from START to END."
+ (tp--remove-property-from-string
+ string start end (list property sub-key)))
+
+;;;###autoload
+(defun tp-remove (start-or-string end-or-prop &optional prop-or-sub &rest rest)
+ "Remove direct properties from a string or buffer range.
+
+START-OR-STRING and END-OR-PROP mirror `tp-get`-style range arguments.
+PROP-OR-SUB selects the property or nested-key form and REST carries
+optional flags/object."
+ (if (stringp start-or-string)
+ (cond
+ ((and (symbolp end-or-prop) (keywordp prop-or-sub) rest)
+ (tp--remove-property-from-string
+ start-or-string 0 (length start-or-string)
+ (list end-or-prop prop-or-sub (car rest))))
+ ((and (symbolp end-or-prop) (keywordp prop-or-sub))
+ (tp--remove-sub-from-string
+ start-or-string 0 (length start-or-string)
+ end-or-prop prop-or-sub))
+ ((listp end-or-prop)
+ (tp--remove-property-from-string
+ start-or-string 0 (length start-or-string) end-or-prop))
+ (t
+ (tp--remove-properties-from-string
+ start-or-string
+ (delq nil (cons end-or-prop (cons prop-or-sub rest))))))
+ (unless (and (numberp start-or-string) (numberp end-or-prop))
+ (error "Invalid arguments to tp-remove"))
+ (tp--remove-property
+ start-or-string end-or-prop prop-or-sub (car rest))
+ nil))
+
+(defun tp--reset-apply (start end props object)
+ "Replace properties on OBJECT from START to END with PROPS."
+ (if (stringp object)
+ (tp--apply-props-to-string object start end props :reset)
+ (set-text-properties start end props object)
+ object))
+
+(defun tp--deep-merge-apply (start end props object)
+ "Merge PROPS into OBJECT from START to END."
+ (if (stringp object)
+ (tp--apply-props-to-string object start end props :add)
+ (tp--apply-props-by-operation start end props object :add)
+ object))
;;;###autoload
(defun tp-clear (&optional start end object)
- "Clear all text properties from START to END in OBJECT.
-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).
-Returns nil."
+ "Clear all text properties from START to END in OBJECT."
(interactive)
- (let ((beg (or start
- (cond ((stringp object) 0)
- ((bufferp object)
- (with-current-buffer object (point-min)))
- (t (point-min)))))
- (finish (or end
- (cond ((stringp object) (length object))
- ((bufferp object)
- (with-current-buffer object (point-max)))
- (t (point-max))))))
- (set-text-properties beg finish nil object)
- nil))
+ (pcase-let ((`(,minimum . ,maximum) (tp--object-bounds object)))
+ (set-text-properties (or start minimum) (or end maximum) nil object))
+ nil)
(provide 'tp-ops)
;;; tp-ops.el ends here
diff --git a/tp-palette.el b/tp-palette.el
index 4164b51..681991e 100644
--- a/tp-palette.el
+++ b/tp-palette.el
@@ -33,46 +33,6 @@ the library supports Emacs 28.1.")
"Alist of (NAME . PLIST) palette definitions.
This is the single source of truth for palette lookups.")
-(defvar tp-theme-generation 0
- "Monotonic generation incremented after theme enable/disable events.")
-
-(defvar tp-theme-last-hook-source nil
- "Most recent theme lifecycle function observed by tp.")
-
-(defvar tp-theme-last-refresh-mode nil
- "Refresh strategy used for the most recent theme lifecycle event.")
-
-(defvar tp-theme-last-refreshed-ranges nil
- "Managed ranges considered by the most recent theme refresh.")
-
-(defvar tp-theme-last-refresh-errors nil
- "Structured failures from the most recent theme refresh.")
-
-(defvar tp-theme-change-hook nil
- "Hook run after a theme lifecycle event.
-Each function receives the source symbol, either `enable-theme' or
-`disable-theme'. The palette module owns event detection only;
-managed renderers may subscribe without creating a reverse dependency.")
-
-(defun tp--palette-note-theme-change (source)
- "Record theme lifecycle SOURCE and notify `tp-theme-change-hook'."
- (setq tp-theme-generation (1+ tp-theme-generation)
- tp-theme-last-hook-source source)
- (run-hook-with-args 'tp-theme-change-hook source))
-
-(defun tp--palette-after-enable-theme (&rest _)
- "Record an `enable-theme' lifecycle event."
- (tp--palette-note-theme-change 'enable-theme))
-
-(defun tp--palette-after-disable-theme (&rest _)
- "Record a `disable-theme' lifecycle event."
- (tp--palette-note-theme-change 'disable-theme))
-
-(unless (advice-member-p #'tp--palette-after-enable-theme 'enable-theme)
- (advice-add 'enable-theme :after #'tp--palette-after-enable-theme))
-(unless (advice-member-p #'tp--palette-after-disable-theme 'disable-theme)
- (advice-add 'disable-theme :after #'tp--palette-after-disable-theme))
-
(defmacro define-tp-palette (name &rest plist)
"Register a color palette named NAME, defined by PLIST.
PLIST maps the keys :fg, :bg and :border to colors in any format
@@ -358,7 +318,7 @@ color."
(tp-palette--get-color symbol key))
(defun tp-palette-has-p (symbol &optional kind)
- "Return non-nil when SYMBOL names a palette that defines KIND.
+ "Return non-nil when KIND is available in SYMBOL's palette.
With nil KIND, test only that SYMBOL names a palette registered in
`tp-palette-alist' (like `tp-palette-p'). Otherwise KIND is one of
:fg, :bg or :border, and the palette's definition must contain that
diff --git a/tp-query.el b/tp-query.el
index f567706..9955b41 100644
--- a/tp-query.el
+++ b/tp-query.el
@@ -24,7 +24,10 @@ only when that overlay supplied the winning character-property value."
property value present-p source mode object position overlay)
(defun tp--lookup-direct (position property object mode)
- "Return direct text lookup result at POSITION for PROPERTY in OBJECT."
+ "Return direct text lookup result for PROPERTY at POSITION in OBJECT.
+
+POSITION, PROPERTY, and OBJECT identify the lookup target; MODE is
+returned in the result."
(let* ((obj (or object (current-buffer)))
(cell (plist-member (text-properties-at position object) property)))
(tp--make-lookup-result
@@ -33,7 +36,10 @@ only when that overlay supplied the winning character-property value."
:object obj :position position)))
(defun tp--lookup-effective (position property object mode)
- "Return effective text lookup result at POSITION for PROPERTY in OBJECT."
+ "Return effective text lookup result for PROPERTY at POSITION in OBJECT.
+
+POSITION, PROPERTY, and OBJECT identify the lookup target; MODE is
+returned in the result."
(let* ((value (get-text-property position property object))
(source-cell (tp--lookup-source-cell position property object))
(present-p (nth 2 source-cell)))
@@ -65,7 +71,7 @@ MODE is recorded in the returned `tp-lookup-result'."
(throw 'found (list alias value))))))
(defun tp--lookup-source-cell (position property object)
- "Return (SOURCE VALUE PRESENT-P) for text-only source lookup."
+ "Return (SOURCE VALUE PRESENT-P) for PROPERTY at POSITION in OBJECT."
(let* ((props (text-properties-at position object))
(direct (plist-member props property))
(category (plist-get props 'category))
@@ -83,6 +89,8 @@ MODE is recorded in the returned `tp-lookup-result'."
(cl-defun tp-lookup (position property &key object (mode :text-effective))
"Look up PROPERTY at POSITION in OBJECT according to MODE.
+POSITION, PROPERTY, OBJECT, and MODE are lookup parameters.
+
MODE is one of `:text-direct', `:text-effective', `:text-source',
`:char', or `:char-source'. Text modes ignore overlays. Character
modes delegate overlay precedence to `get-char-property-and-overlay';
@@ -103,7 +111,7 @@ absence from a direct property whose value is nil."
:position position)))
((or :char :char-source)
(tp--lookup-char position property object mode))
- (_ (error "tp-lookup: unknown mode %S" mode))))
+ (_ (error "TP-LOOKUP: unknown mode %S" mode))))
;;;###autoload
(cl-defun tp-property-change
@@ -122,28 +130,35 @@ meanings. Return the changed position or nil."
(if property
(previous-single-property-change position property object limit)
(previous-property-change position object limit)))
- (_ (error "tp-property-change: unknown direction %S" direction))))
+ (_ (error "TP-PROPERTY-CHANGE: unknown direction %S" direction))))
;;;###autoload
(defun tp-property-any (start end property value &optional object)
"Return first position in [START, END) where PROPERTY is VALUE.
-This is the facade entry for `text-property-any'; OBJECT is a string,
-a buffer, or nil for the current buffer."
+
+START and END are search bounds.
+PROPERTY and VALUE are matched directly.
+OBJECT is a string, a buffer, or nil for the current buffer."
(text-property-any start end property value object))
;;;###autoload
(defun tp-property-not-all (start end property value &optional object)
"Return first position in [START, END) where PROPERTY is not VALUE.
-This delegates directly to `text-property-not-all'."
+
+START and END are search bounds.
+PROPERTY and VALUE are matched directly.
+OBJECT is a string, a buffer, or nil for the current buffer."
(text-property-not-all start end property value object))
(defun tp--mutation-policy-modes (policy)
- "Return normalized (MODIFIED READ-ONLY) modes for POLICY."
+ "Return normalized (MODIFIED READ-ONLY) modes for POLICY.
+
+POLICY is a property list with keys `:modified' and `:read-only'."
(unless (and (proper-list-p policy) (cl-evenp (length policy)))
- (error "tp-with-mutation-policy: POLICY must be a plist"))
+ (error "TP-WITH-MUTATION-POLICY: POLICY must be a plist"))
(cl-loop for (key _value) on policy by #'cddr
unless (memq key '(:modified :read-only))
- do (error "tp-with-mutation-policy: unknown key %S" key))
+ do (error "TP-WITH-MUTATION-POLICY: unknown key %S" key))
(let ((modified (if (plist-member policy :modified)
(plist-get policy :modified)
:ordinary))
@@ -151,11 +166,11 @@ This delegates directly to `text-property-not-all'."
(plist-get policy :read-only)
:respect)))
(unless (memq modified '(:ordinary :silent))
- (error "tp-with-mutation-policy: unknown :modified %S" modified))
+ (error "TP-WITH-MUTATION-POLICY: unknown :modified %S" modified))
(unless (memq read-only '(:respect :inhibit))
- (error "tp-with-mutation-policy: unknown :read-only %S" read-only))
+ (error "TP-WITH-MUTATION-POLICY: unknown :read-only %S" read-only))
(when (and (eq modified :silent) (eq read-only :respect))
- (error "tp-with-mutation-policy: :silent requires :read-only :inhibit"))
+ (error "TP-WITH-MUTATION-POLICY: :silent requires :read-only :inhibit"))
(list modified read-only)))
;;;###autoload
diff --git a/tp-reactive.el b/tp-reactive.el
index 8980af4..f3c42d4 100644
--- a/tp-reactive.el
+++ b/tp-reactive.el
@@ -12,9 +12,7 @@
;;; Commentary:
;; TP 1.0's exact signal-to-binding dependency graph, transaction-local
-;; scheduler, scoped variable adapters, and rollback state. The lower legacy
-;; section remains temporarily available to the 0.3 layer/render facade during
-;; the staged cutover; new graph execution never calls its scan renderer.
+;; scheduler, scoped variable adapters, and rollback state.
;;; Code:
@@ -317,7 +315,8 @@ Disposed signals return zero."
"Signal a binding-cycle error for binding PATH."
(signal 'tp-binding-cycle
(list (mapcar (lambda (binding)
- (copy-tree (tp-binding-key binding)))
+ (tp--copy-property-value
+ (tp-binding-key binding)))
path))))
(defun tp--validate-binding-read (binding &optional computing-only)
@@ -446,7 +445,7 @@ EQUALITY compares values and LIFECYCLE controls retention."
(setq binding
(tp--make-binding
:id (cl-incf tp--binding-id-counter)
- :owner owner :key (copy-tree key) :compute compute
+ :owner owner :key (tp--copy-property-value key) :compute compute
:equality equality :subscribers (make-hash-table :test #'eq)
:dirty t :state 'clean :revision 0 :lifecycle lifecycle))
(tp--register-binding binding)
@@ -569,9 +568,10 @@ transaction."
(signal 'wrong-type-argument (list 'functionp rollback)))
(when (member key tp--transaction-participant-keys)
(signal 'tp-reactive-error (list :duplicate-participant-key key)))
- (push (copy-tree key) tp--transaction-participant-keys)
+ (push (tp--copy-property-value key) tp--transaction-participant-keys)
(push (tp--make-transaction-participant
- :key (copy-tree key) :publish publish :rollback rollback)
+ :key (tp--copy-property-value key)
+ :publish publish :rollback rollback)
tp--transaction-participants)
key)
@@ -812,435 +812,11 @@ OPERATION and WHERE follow the standard variable watcher protocol."
tp--variable-signal-watched nil)
(tp-reactive-reset-counters))
-(defvar tp-reactive-deps nil
- "Alist mapping reactive variables to dependent layers.
-Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).")
-
-(defvar tp-layer-watchers nil
- "Alist of layer watchers: (LAYER-NAME . ((VAR-SYMBOL . CALLBACK) ...)).")
-
-(defvar tp-reactive-observer-errors nil
- "Structured observer failures, newest first.
-Each entry is a plist containing `:kind', `:layer', `:symbol',
-`:condition', `:new-value', and `:old-value'. Watcher failures are
-recorded here and reported, but do not block the managed update.")
-
-(defvar tp-layer-computed nil
- "Alist of computed properties: (LAYER-NAME . ((VAR-SYMBOL . COMPUTE-FN) ...)).")
-
-(defvar tp-layer-data nil
- "Alist of data variables: (LAYER-NAME . (VAR-SYMBOL ...)).")
-
-(defvar tp--batch-update-pending nil
- "Queue of deferred reactive buffer re-renders.
-Each entry is a list (LAYER-NAME CHANGED-SYMBOLS WHERE TP-TEXT-AFFECTED).
-Entries are created and widened by `tp--queue-batch-update'.")
-
-(defvar tp--layer-buffers (make-hash-table :test 'equal)
- "Hash table mapping layer names to buffers showing their regions.
-Keys are layer names; values are lists of buffers registered via
-`tp-reactive--register-layer-buffer'. Reactive updates walk only
-these buffers instead of scanning `buffer-list' (see
-`tp-reactive-layer-buffers'). A key holding an empty list means
-\"known: no buffer shows this layer\", which is distinct from an
-absent key (`unknown').")
-
-(defvar tp--layer-buffers-hook-installed nil
- "Non-nil once the registry's `kill-buffer-hook' pruner is installed.")
-
-(defun tp-reactive--install-kill-buffer-hook ()
- "Install the global `kill-buffer-hook' pruning the buffer registry.
-Idempotent; guarded by `tp--layer-buffers-hook-installed'."
- (unless tp--layer-buffers-hook-installed
- (add-hook 'kill-buffer-hook #'tp-reactive--prune-killed-buffer)
- (setq tp--layer-buffers-hook-installed t)))
-
-(defun tp-reactive--prune-killed-buffer ()
- "Drop the buffer being killed from `tp--layer-buffers'.
-Runs on `kill-buffer-hook' with the dying buffer current. The layer
-entries themselves are kept: an entry left with an empty list means
-\"known: no buffer shows this layer\", not `unknown'."
- (let ((buf (current-buffer)))
- (maphash (lambda (layer bufs)
- (when (memq buf bufs)
- (puthash layer (delq buf bufs) tp--layer-buffers)))
- tp--layer-buffers)))
-
-(defun tp-reactive--register-layer-buffer (layer-name buffer)
- "Register BUFFER as showing regions of layer LAYER-NAME.
-Idempotent: registering the same live BUFFER again keeps a single
-entry. Dead buffers and a nil LAYER-NAME are ignored. Installs the
-`kill-buffer-hook' pruner on first use. See
-`tp-reactive-layer-buffers' for the consumer side of the registry."
- (when (and layer-name (buffer-live-p buffer))
- (tp-reactive--install-kill-buffer-hook)
- (let ((bufs (gethash layer-name tp--layer-buffers)))
- (unless (memq buffer bufs)
- (puthash layer-name (cons buffer bufs) tp--layer-buffers)))))
-
-(defun tp-reactive--unregister-layer-buffer (layer-name buffer)
- "Remove BUFFER from LAYER-NAME's registry entry when it is known."
- (let ((buffers (gethash layer-name tp--layer-buffers 'unknown)))
- (unless (eq buffers 'unknown)
- (puthash layer-name (delq buffer buffers) tp--layer-buffers))))
-
-(defun tp-reactive-layer-buffers (layer-name)
- "Return the live buffers registered as showing layer LAYER-NAME.
-Return a list of live buffers - possibly empty, meaning \"known: no
-buffer shows this layer\" - or the symbol `unknown' when LAYER-NAME
-has no registry entry at all. Killed buffers still recorded in the
-registry are dropped lazily by this accessor.
-
-KNOWN GAP: inserting an already-propertized STRING into a buffer
-bypasses the buffer operations that register buffers, so such a
-buffer is missing here until a reactive update's full-scan fallback
-finds it or `tp-reactive-track-buffer' is called on it."
- (let ((bufs (gethash layer-name tp--layer-buffers 'unknown)))
- (if (eq bufs 'unknown)
- 'unknown
- (let ((live (cl-remove-if-not #'buffer-live-p bufs)))
- (unless (= (length live) (length bufs))
- (puthash layer-name live tp--layer-buffers))
- live))))
-
-(defun tp-reactive--buffer-layer-names (&optional buffer)
- "Return the layer names present in BUFFER, in buffer order.
-BUFFER defaults to the current buffer; a dead BUFFER yields nil.
-Stack-aware: a layer counts as present when its name is the direct
-`tp-name' text property of a run (the rendered top layer) or the
-`tp-name' of any layer plist inside the run's `tp-layers'
-stack-storage property (layers buried below the top, or hidden - see
-tp-stack.el). The `tp-layers' value is read as a plain list of
-plists, so this helper stays below the stack module. Names are
-deduplicated with `equal'. This is the shared scan behind
-`tp-reactive-track-buffer' and the anonymous-layer GC's liveness
-test `tp--buffer-has-layer-region-p'."
- (let ((buf (or buffer (current-buffer)))
- (found nil))
- (when (buffer-live-p buf)
- (tp--map-intervals
- buf nil nil
- (lambda (_start _end props)
- (let ((direct (plist-get props 'tp-name)))
- (when (and direct (not (member direct found)))
- (push direct found)))
- (dolist (layer (plist-get props 'tp-layers))
- (let ((name (plist-get layer 'tp-name)))
- (when (and name (not (member name found)))
- (push name found)))))))
- (nreverse found)))
-
-;;;###autoload
-(defun tp-reactive-track-buffer (&optional buffer)
- "Scan BUFFER for layer regions and register it in the buffer registry.
-BUFFER defaults to the current buffer. Walk BUFFER's text-property
-runs and register BUFFER for every layer name found - rendered top
-layers (direct `tp-name') as well as layers inside `tp-layers' stack
-storage (buried below another layer, or hidden) - so reactive updates
-visit it without a full `buffer-list' scan.
-
-Call this after inserting an already-propertized string into a
-buffer: string application bypasses the buffer operations that
-register buffers (see `tp-reactive-layer-buffers'), and this command
-closes that gap. Return the list of layer names registered, in
-buffer order."
- (interactive)
- (let* ((buf (or buffer (current-buffer)))
- (found (tp-reactive--buffer-layer-names buf)))
- (dolist (name found)
- (tp-reactive--register-layer-buffer name buf))
- (when (called-interactively-p 'interactive)
- (message "tp: tracking %d layer(s) in %s"
- (length found) (buffer-name buf)))
- found))
-
-(defvar tp--batch-update-active nil
- "When non-nil, we are inside a `tp-with-batch-updates' form.")
-
-(defvar tp--reactive-updating nil
- "Non-nil while a reactive update is being applied.
-Used as a reentrancy guard: when a variable is set from within an
-update (a computed variable being written, or the tp-text two-way
-sync), the nested change still updates the variable, but its
-re-render is queued in `tp--batch-update-pending' and flushed after
-the outermost update completes instead of recursing.")
-
-(defun tp--queue-batch-update (layer-name symbol where tp-text-affected)
- "Queue a deferred re-render of LAYER-NAME in `tp--batch-update-pending'.
-SYMBOL is the changed variable, WHERE the buffer for buffer-local
-changes (nil for global ones), TP-TEXT-AFFECTED non-nil when the
-change touches the layer's `tp-text'. When the layer already has a
-pending entry, the entry is widened to the union of both changes:
-SYMBOL is added, TP-TEXT-AFFECTED is sticky (once set it stays set)
-and WHERE widens to nil (all buffers) as soon as two changes disagree
-on it."
- (let ((existing (assoc layer-name tp--batch-update-pending)))
- (if existing
- (progn
- (unless (memq symbol (nth 1 existing))
- (setf (nth 1 existing) (cons symbol (nth 1 existing))))
- (unless (eq (nth 2 existing) where)
- (setf (nth 2 existing) nil))
- (when tp-text-affected
- (setf (nth 3 existing) t)))
- (push (list layer-name (list symbol) where (and tp-text-affected t))
- tp--batch-update-pending))))
-
-(defun tp--register-reactive-deps (layer-name reactive-symbols props)
- "Register REACTIVE-SYMBOLS as dependencies for LAYER-NAME.
-PROPS is the original property specification with reactive symbols.
-Only the reactive portions of the properties are stored for each variable."
- ;; Register each reactive symbol's dependency with only its relevant properties
- (dolist (rsym reactive-symbols)
- (let* ((var-sym (tp--reactive-var-symbol rsym))
- ;; Extract only the properties that use this specific reactive variable
- (reactive-props (tp--extract-reactive-props props rsym))
- (existing (assoc var-sym tp-reactive-deps)))
- (if existing
- ;; Update or add this layer to existing dependencies
- (let ((layer-entry (assoc layer-name (cdr existing))))
- (if layer-entry
- ;; Update existing entry with new reactive-props
- (setf (cdr layer-entry) reactive-props)
- ;; Add new layer entry
- (push (cons layer-name reactive-props) (cdr existing))))
- ;; Create new dependency entry and add watcher
- (push (cons var-sym (list (cons layer-name reactive-props))) tp-reactive-deps)
- ;; Add variable watcher for this variable
- (unless (boundp var-sym) (set var-sym nil))
- (add-variable-watcher var-sym #'tp--reactive-variable-watcher)))))
-
-(defun tp--unregister-reactive-deps (layer-name)
- "Unregister all reactive dependencies for LAYER-NAME."
- ;; Collect variables that need watcher removal
- (let ((vars-to-clean nil))
- ;; First pass: remove layer from dependencies and collect empty vars
- (dolist (dep tp-reactive-deps)
- (let ((var-sym (car dep)))
- (setf (cdr dep) (assq-delete-all layer-name (cdr dep)))
- ;; If no more dependencies, mark for watcher removal
- (when (null (cdr dep))
- (push var-sym vars-to-clean))))
- ;; Remove watchers for variables with no dependencies
- (dolist (var-sym vars-to-clean)
- (remove-variable-watcher var-sym #'tp--reactive-variable-watcher)))
- ;; Clean up empty dependency entries
- (setq tp-reactive-deps
- (cl-remove-if (lambda (dep) (null (cdr dep))) tp-reactive-deps))
- ;; Also clean up layer watchers, computed properties, and data
- (tp--unregister-layer-watchers layer-name)
- (tp--unregister-layer-computed layer-name)
- (tp--unregister-layer-data layer-name)
- ;; Drop the layer's buffer-registry entry: an undefined (or about to
- ;; be redefined) layer must not linger as stale "known" state; the
- ;; next update or refresh falls back to a learning full scan.
- (remhash layer-name tp--layer-buffers))
-
-(defun tp--layer-has-reactive-deps-p (layer-name)
- "Return non-nil if LAYER-NAME has reactive dependencies registered.
-Layers with reactive deps need tp-name for reactive tracking."
- (cl-some (lambda (dep)
- (assoc layer-name (cdr dep)))
- tp-reactive-deps))
-
-(defvar tp--reactive-update-function nil
- "Function applying a reactive update to layer definitions and buffers.
-Installed by tp-render.el. Called with (LAYER-NAME REACTIVE-PROPS
-SYMBOL NEWVAL WHERE OVERRIDE-ALIST) after the user watch callbacks
-have run. When nil, variable changes only invoke watch callbacks and
-no re-rendering happens.")
-
-(defun tp--reactive-variable-watcher (symbol newval operation where)
- "Watcher function called when a reactive variable changes.
-SYMBOL is the variable that changed.
-NEWVAL is the new value being set.
-OPERATION is the type of operation (set, let, unlet, makunbound, defvaralias).
-WHERE indicates where the variable was set:
- - nil for global `setq' or `set'
- - a buffer for `setq-local'
-Updates all layers that depend on this variable.
-
-Only `set' operations trigger updates because:
-- `let'/`unlet': Temporary bindings that will be restored, no need to update UI
-- `makunbound': Variable is being undefined, not a value change
-- `defvaralias': Aliasing, the actual value change will trigger a separate `set'
-
-When `tp--batch-update-active' is non-nil, buffer updates are deferred until
-the batch completes. Layer definitions are still updated immediately.
-
-Uses `tp--equal-including-string-properties' for comparison to properly detect
-changes in text properties when the text content is the same.
-
-The actual recomputation and buffer re-rendering is delegated to
-`tp--reactive-update-function', installed by tp-render.el."
- (when (and (not (tp--equal-including-string-properties
- (when (boundp symbol)
- (symbol-value symbol))
- newval))
- (eq operation 'set))
- (tp-debug-log "Variable %s changed: %S -> %S (where: %s)"
- symbol (when (boundp symbol) (symbol-value symbol)) newval
- (if where (buffer-name where) "global"))
- (let ((deps (cdr (assoc symbol tp-reactive-deps)))
- (oldval (when (boundp symbol) (symbol-value symbol)))
- ;; Create override alist with the new value
- ;; (watcher is called before the variable is actually updated)
- (override-alist (list (cons symbol newval))))
- (dolist (dep deps)
- (let ((layer-name (car dep))
- ;; Get the reactive props stored directly in the dependency
- (reactive-props (cdr dep)))
- ;; Call user-defined watch callbacks for this layer
- (tp--invoke-layer-watchers layer-name symbol newval oldval)
- ;; Delegate recomputation and re-rendering to the update engine
- (when tp--reactive-update-function
- (funcall tp--reactive-update-function
- layer-name reactive-props symbol newval
- where override-alist)))))))
-
-(defun tp--invoke-layer-watchers (layer-name symbol newval oldval)
- "Invoke all registered watcher callbacks for LAYER-NAME watching SYMBOL.
-NEWVAL is the new value, OLDVAL is the old value."
- (when-let ((watchers (cdr (assoc layer-name tp-layer-watchers))))
- (dolist (watcher watchers)
- (let ((watch-sym (car watcher))
- (callback (cdr watcher)))
- (when (eq watch-sym symbol)
- (tp-debug-log " Invoking watcher for %s on %s" watch-sym layer-name)
- (condition-case err
- (funcall callback newval oldval layer-name)
- (error
- (push (list :kind 'watcher
- :layer layer-name
- :symbol watch-sym
- :condition err
- :new-value newval
- :old-value oldval)
- tp-reactive-observer-errors)
- (message "tp: watcher error for %s watching %s: %s"
- layer-name watch-sym err))))))))
-
-(defun tp--register-layer-watchers (layer-name watchers)
- "Register WATCHERS for LAYER-NAME.
-WATCHERS is a list of (VAR-SYMBOL CALLBACK) pairs."
- (when watchers
- (let ((watcher-pairs
- (mapcar (lambda (watcher)
- (cons (car watcher) (cadr watcher)))
- watchers)))
- (if (assoc layer-name tp-layer-watchers)
- (setf (cdr (assoc layer-name tp-layer-watchers)) watcher-pairs)
- (push (cons layer-name watcher-pairs) tp-layer-watchers)))))
-
-(defun tp--register-layer-computed (layer-name computed)
- "Register COMPUTED variable definitions for LAYER-NAME.
-COMPUTED is a list of (VAR-SYMBOL COMPUTE-FN) pairs."
- (when computed
- (let ((computed-pairs
- (mapcar (lambda (comp)
- (cons (car comp) (cadr comp)))
- computed)))
- (if (assoc layer-name tp-layer-computed)
- (setf (cdr (assoc layer-name tp-layer-computed)) computed-pairs)
- (push (cons layer-name computed-pairs) tp-layer-computed)))))
-
-(defun tp--unregister-layer-watchers (layer-name)
- "Unregister all watchers for LAYER-NAME."
- (setq tp-layer-watchers (assq-delete-all layer-name tp-layer-watchers)))
-
-(defun tp--unregister-layer-computed (layer-name)
- "Unregister all computed properties for LAYER-NAME."
- (setq tp-layer-computed (assq-delete-all layer-name tp-layer-computed)))
-
-(defun tp--apply-initial-computed (compute)
- "Apply initial computed values using COMPUTE definitions.
-COMPUTE is a list of (VAR-SYMBOL COMPUTE-FN) pairs.
-Sets the global variables to their computed values.
-A compute function returning nil is a legitimate result. Compute
-errors propagate because a skipped value would leave stale state."
- (dolist (comp compute)
- (let* ((var-sym (car comp))
- (compute-fn (cadr comp))
- (val (funcall compute-fn)))
- (set var-sym val))))
-
-(defun tp--data-var-symbol (data-entry)
- "Extract the variable symbol from DATA-ENTRY.
-DATA-ENTRY can be a symbol or a cons cell (SYMBOL . INITIAL-VALUE)."
- (if (consp data-entry)
- (car data-entry)
- data-entry))
-
-(defun tp--register-layer-data (layer-name data-vars)
- "Register DATA-VARS for LAYER-NAME.
-DATA-VARS is a list of variable symbols or cons cells (SYMBOL . INITIAL-VALUE).
-Also adds variable watchers so changes to data vars trigger computed updates."
- (when data-vars
- ;; Extract just the symbols for storage
- (let ((var-symbols (mapcar #'tp--data-var-symbol data-vars)))
- (if (assoc layer-name tp-layer-data)
- (setf (cdr (assoc layer-name tp-layer-data)) var-symbols)
- (push (cons layer-name var-symbols) tp-layer-data))
- ;; Add watchers for data variables
- (dolist (var-sym var-symbols)
- (let ((existing (assoc var-sym tp-reactive-deps)))
- (if existing
- ;; Add this layer to existing dependencies
- ;; (with nil props since data vars don't have direct props)
- (let ((layer-entry (assoc layer-name (cdr existing))))
- (unless layer-entry
- (push (cons layer-name nil) (cdr existing))))
- ;; Create new dependency entry and add watcher
- (push (cons var-sym (list (cons layer-name nil))) tp-reactive-deps)
- (unless (boundp var-sym) (set var-sym nil))
- (add-variable-watcher var-sym #'tp--reactive-variable-watcher)))))))
-
-(defun tp--unregister-layer-data (layer-name)
- "Unregister data variables for LAYER-NAME."
- (setq tp-layer-data (assq-delete-all layer-name tp-layer-data)))
-
-(defun tp--ensure-reactive-variables (var-symbols)
- "Ensure all VAR-SYMBOLS are defined as global variables.
-VAR-SYMBOLS can be a list of symbols or cons cells (SYMBOL . INITIAL-VALUE).
-If a variable is not bound, define it with the initial value (nil if
-not specified).
-If a variable has an explicit initial value (cons cell), always update
-it to allow re-definition to change initial values."
- (dolist (sym var-symbols)
- (let* ((is-cons (and (consp sym) (not (tp--reactive-symbol-p sym))))
- (var-sym (cond
- (is-cons (car sym))
- ((tp--reactive-symbol-p sym)
- (tp--reactive-var-symbol sym))
- (t sym)))
- (initial-val (if is-cons (cdr sym) nil)))
- (if is-cons
- ;; For explicit initial values, always update (allows re-definition)
- (set var-sym initial-val)
- ;; For implicit initial values, only set if not already bound
- (unless (boundp var-sym)
- (set var-sym initial-val))))))
-
;;;###autoload
(defun tp-reactive-reset ()
- "Reset all reactive text property watchers and dependencies."
+ "Reset TP's signal, binding, adapter, and scheduler graph."
(interactive)
- (tp--reactive-graph-reset)
- ;; Remove all variable watchers
- (dolist (dep tp-reactive-deps)
- (let ((var-sym (car dep)))
- (remove-variable-watcher var-sym #'tp--reactive-variable-watcher)))
- ;; Clear all registries
- (setq tp-reactive-deps nil)
- (setq tp-layer-watchers nil)
- (setq tp-reactive-observer-errors nil)
- (setq tp-layer-computed nil)
- (setq tp-layer-data nil)
- ;; Drop queued re-renders too: entries stranded by an error escaping
- ;; an update would otherwise survive the reset and replay against
- ;; freshly (re)defined layers on the next flush (ARCH-4).
- (setq tp--batch-update-pending nil)
- (clrhash tp--layer-buffers))
+ (tp--reactive-graph-reset))
(provide 'tp-reactive)
;;; tp-reactive.el ends here
diff --git a/tp-render.el b/tp-render.el
deleted file mode 100644
index d3bbe56..0000000
--- a/tp-render.el
+++ /dev/null
@@ -1,668 +0,0 @@
-;;; tp-render.el --- Reactive re-rendering engine for tp -*- lexical-binding: t -*-
-
-;; Copyright (C) 2024-2026 Geekinney
-
-;; Author: Geekinney (kinneyzhang666@gmail.com)
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 3 of
-;; the License, or (at your option) any later version.
-
-;;; Commentary:
-
-;; The reactive update engine: when a reactive variable changes, this
-;; module recomputes layer definitions and re-renders every affected
-;; buffer region, including live `tp-text' text replacement. It also
-;; owns the batching flush and the public `tp-with-batch-updates'
-;; macro (the queue state lives in tp-reactive.el). It installs
-;; itself into tp-reactive.el (update hook) and tp-layer.el (layer
-;; refresh hook), and calls down into tp-ops.el for the `tp-text'
-;; helper chain.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'tp-core)
-(require 'tp-reactive)
-(require 'tp-layer)
-(require 'tp-ops)
-(require 'tp-search)
-
-(defun tp--layer-reactive-props (layer-name)
- "Collect LAYER-NAME's unresolved reactive props from `tp-reactive-deps'.
-Each dependency entry stores only the portions of the layer's props
-that reference one variable; this merges the fragments back into a
-single plist with the `$var' markers intact. Returns nil when the
-layer has no reactive props (data-only dependencies store nil)."
- (let ((all nil))
- (dolist (dep tp-reactive-deps)
- (let ((layer-entry (assoc layer-name (cdr dep))))
- (when (and layer-entry (cdr layer-entry))
- (setq all (if all
- (tp--deep-merge-plist all (cdr layer-entry))
- (copy-sequence (cdr layer-entry)))))))
- all))
-
-(defun tp--layer-render-props (layer-name override-alist)
- "Return LAYER-NAME's props for re-rendering in the current buffer.
-Starts from the stored layer definition and deep-merges the layer's
-reactive props re-resolved against the current variable values, so
-buffer-local values are honored when the target buffer is current.
-OVERRIDE-ALIST maps variables to not-yet-visible new values (the
-variable watcher runs before the variable is actually set) and takes
-precedence over `symbol-value'. Returns nil when the layer has no
-usable definition."
- (let ((base (tp-layer-props layer-name t))) ; include tp-name for tracking
- (when base
- (let ((reactive (tp--layer-reactive-props layer-name)))
- (if reactive
- (tp--deep-merge-plist
- base (tp--resolve-reactive-symbols reactive override-alist))
- base)))))
-
-(defun tp--store-computed-value
- (layer-name var-sym computed-val override-alist)
- "Store LAYER-NAME's computed VAR-SYM and return updated OVERRIDE-ALIST."
- (set var-sym computed-val)
- (push (cons var-sym computed-val) override-alist)
- (let ((current-props (cdr (assoc layer-name tp-layer-alist)))
- (reactive-props (tp--layer-reactive-props layer-name)))
- (when (and current-props reactive-props)
- (let ((resolved
- (tp--resolve-reactive-symbols reactive-props override-alist)))
- (when resolved
- (tp--set-layer-props
- layer-name
- (tp--deep-merge-plist current-props resolved))))))
- override-alist)
-
-(defun tp--update-layer-computed (layer-name override-alist)
- "Compute LAYER-NAME values and return an updated OVERRIDE-ALIST.
-Compute errors propagate; returning nil remains a legitimate value."
- (dolist (comp (cdr (assoc layer-name tp-layer-computed)))
- (let* ((var-sym (car comp))
- (compute-fn (cdr comp))
- (computed-val
- (cl-progv
- (mapcar #'car override-alist)
- (mapcar #'cdr override-alist)
- (funcall compute-fn))))
- (setq override-alist
- (tp--store-computed-value
- layer-name var-sym computed-val override-alist))))
- override-alist)
-
-(defun tp--render-visit-buffer (buffer fn)
- "Call FN with BUFFER current and `inhibit-read-only' bound to t.
-Dead buffers are skipped. This is the per-buffer seam of the
-reactive update walk; tests may advise it to count buffer visits."
- (when (buffer-live-p buffer)
- (tp-with-current-buffer buffer
- (funcall fn))))
-
-(defun tp--map-layer-buffers (layer-name where fn)
- "Run FN in each buffer that may show LAYER-NAME's regions.
-A non-nil WHERE (a live buffer, the `setq-local' case) restricts the
-walk to that buffer. Otherwise the walk consults the buffer registry
-via `tp-reactive-layer-buffers' and visits only registered live
-buffers. When the registry answers `unknown', the walk falls back to
-a full `buffer-list' scan, registering every buffer that actually
-contains a region of LAYER-NAME; once at least one buffer is
-registered the layer is known and later updates skip the full scan.
-A layer found in no buffer at all deliberately stays `unknown', so a
-later application through a path that does not register buffers is
-still picked up by the next update's full scan."
- (if (and where (bufferp where) (buffer-live-p where))
- (tp--render-visit-buffer where fn)
- (let ((registered (tp-reactive-layer-buffers layer-name)))
- (if (not (eq registered 'unknown))
- (dolist (buf registered)
- (tp--render-visit-buffer buf fn))
- ;; Learning fallback: behave exactly like the historical full
- ;; scan, but record which buffers actually carry the layer.
- (dolist (buf (buffer-list))
- (when (buffer-live-p buf)
- (when (tp--buffer-has-layer-region-p layer-name buf)
- (tp-reactive--register-layer-buffer layer-name buf))
- (tp--render-visit-buffer buf fn)))))))
-
-(defun tp--reconcile-layer-props
- (current old-props new-props &optional include-meta)
- "Replace one layer's OLD-PROPS in CURRENT with NEW-PROPS.
-Keys owned by OLD-PROPS are removed when CURRENT still carries the old
-value, then NEW-PROPS are written in full. A differing current value
-is preserved when the new definition no longer owns that key, because
-it may be an explicit post-application edit. Stack metadata
-`tp-layers' and `tp-hidden' is never owned by a layer definition.
-`tp-meta' is rendered only when INCLUDE-META is non-nil.
-Return a fresh plist."
- (let ((result (copy-sequence current)))
- (cl-loop for (key val) on old-props by #'cddr
- unless (memq key '(tp-name tp-layers tp-hidden tp-meta))
- when (and (plist-member result key)
- (equal (plist-get result key) val))
- do (cl-remf result key))
- (cl-loop for (key val) on new-props by #'cddr
- unless (or (memq key '(tp-layers tp-hidden))
- (and (eq key 'tp-meta) (not include-meta)))
- do (setq result (plist-put result key val)))
- result))
-
-(defun tp--reconcile-layer-region (start end old-props new-props)
- "Reconcile OLD-PROPS and NEW-PROPS on every property run in START..END."
- (let ((pos start))
- (while (< pos end)
- (let* ((next (or (next-property-change pos nil end) end))
- (current (text-properties-at pos))
- (updated (tp--reconcile-layer-props
- current old-props new-props)))
- (unless (equal updated current)
- (set-text-properties pos next updated))
- (setq pos next)))))
-
-(defun tp--replace-stack-entry-props (entry old-props new-props)
- "Return ENTRY with OLD-PROPS replaced by NEW-PROPS."
- (tp--refresh-entry-meta-version
- (tp--reconcile-layer-props entry old-props new-props t)))
-
-(defun tp--refresh-entry-meta-version (entry)
- "Return ENTRY with refreshed metadata version fields when present."
- (if-let ((meta (plist-get entry 'tp-meta))
- (name (plist-get entry 'tp-name)))
- (let ((updated (copy-tree meta)))
- (setq updated
- (plist-put updated :definition-version
- (tp--layer-definition-version name)))
- (setq updated
- (plist-put updated :entry-version
- (1+ (or (plist-get meta :entry-version) 0))))
- (when (boundp 'tp-theme-generation)
- (setq updated
- (plist-put updated :palette-generation
- tp-theme-generation)))
- (plist-put entry 'tp-meta updated))
- entry))
-
-(defun tp--entry-parameterized-refresh (entry layer-name)
- "Return refreshed ENTRY for parameterized LAYER-NAME, or ENTRY."
- (let ((meta (plist-get entry 'tp-meta)))
- (if (and meta
- (eq (plist-get entry 'tp-name) layer-name)
- (not (plist-get meta :legacy-no-args))
- (plist-member meta :args)
- (tp-layer-parameterized-p layer-name))
- (tp--entry-from-parameterized-meta entry layer-name meta)
- entry)))
-
-(defun tp--entry-from-parameterized-meta (entry layer-name meta)
- "Build a refreshed managed ENTRY for LAYER-NAME from META."
- (let* ((args (plist-get meta :args))
- (props (tp-layer-props-with-args layer-name args t))
- (hidden (tp--stack-hidden-p entry))
- (updated (tp--refresh-entry-meta-version
- (plist-put props 'tp-meta (copy-tree meta)))))
- (if hidden
- (plist-put updated 'tp-hidden t)
- updated)))
-
-(defun tp--refresh-parameterized-stack (stack layer-name)
- "Refresh parameterized LAYER-NAME entries in STACK."
- (mapcar (lambda (entry)
- (tp--entry-parameterized-refresh entry layer-name))
- stack))
-
-(defun tp--refresh-parameterized-layer-regions (layer-name)
- "Refresh mounted parameterized entries for LAYER-NAME in current buffer."
- (let ((pos (point-min))
- (max (point-max)))
- (while (< pos max)
- (let* ((next (or (next-property-change pos nil max) max))
- (stack (tp--stack-props-to-list (text-properties-at pos)))
- (new-stack (tp--refresh-parameterized-stack stack layer-name)))
- (unless (equal new-stack stack)
- (set-text-properties pos next
- (tp--stack-build-props new-stack)))
- (setq pos next)))))
-
-(defun tp--managed-stack-with-direct-edits (props stored)
- "Return authoritative STORED after absorbing visible edits from PROPS.
-In managed full-stack storage, direct properties are the render
-projection of the first visible entry. A caller may legitimately
-edit that projection with native text-property primitives. Preserve
-those edits on the visible entry before refreshing definitions, while
-keeping managed identity and metadata authoritative."
- (let ((direct (copy-sequence props)))
- (cl-remf direct 'tp-layers)
- (let ((visible (seq-find (lambda (entry)
- (not (tp--stack-hidden-p entry)))
- stored)))
- (cond
- ((null visible)
- (if direct
- (signal 'tp-layer-conflict
- (list "Properties appeared while all layers were hidden"
- :actual direct))
- stored))
- ((not (equal (plist-get direct 'tp-name)
- (plist-get visible 'tp-name)))
- (signal 'tp-layer-conflict
- (list "Managed render identity changed"
- :actual direct :expected visible)))
- (t
- (let ((updated (copy-tree visible)))
- (cl-loop for (key _value)
- on (tp--entry-render-projection visible) by #'cddr
- unless (or (eq key 'tp-name)
- (plist-member direct key))
- do (cl-remf updated key))
- (cl-loop for (key value) on direct by #'cddr
- unless (eq key 'tp-name)
- do (setq updated (plist-put updated key value)))
- (mapcar (lambda (entry)
- (if (eq entry visible) updated entry))
- stored)))))))
-
-(defun tp--write-layer-through-stack-storage
- (layer-name props &optional old-props)
- "Write PROPS through to LAYER-NAME's entries in `tp-layers' storage.
-A reactive re-render rewrites a layer's direct (rendered) properties,
-but the same layer can also sit inside the `tp-layers' stack-storage
-property of a run: buried below another layer, or hidden (see
-`tp-hide-layer'), in which case the direct properties are only a
-render cache and the stored entry is what the next stack operation
-rebuilds from. OLD-PROPS, when non-nil, identifies definition-owned
-keys that disappeared and must be removed.
-
-For every run of the current buffer whose `tp-layers' holds an entry
-whose `tp-name' equals LAYER-NAME, reconcile the layer entry and
-rewrite the run via `tp--stack-props-to-list' /
-`tp--stack-build-props'. Runs already storing the current values are
-left untouched."
- (let ((pos (point-min))
- (max (point-max)))
- (while (< pos max)
- (let ((next (or (next-property-change pos nil max) max))
- (stored (get-text-property pos 'tp-layers)))
- (when (and stored
- (cl-some (lambda (entry)
- (equal (plist-get entry 'tp-name) layer-name))
- stored))
- (let* ((raw (text-properties-at pos))
- (stack
- (if (tp--entry-authoritative-storage-p stored)
- (tp--managed-stack-with-direct-edits raw stored)
- (tp--stack-props-to-list raw)))
- (new-stack
- (mapcar (lambda (entry)
- (if (equal (plist-get entry 'tp-name) layer-name)
- (tp--replace-stack-entry-props
- entry old-props props)
- entry))
- stack)))
- (unless (equal new-stack stack)
- (set-text-properties pos next
- (tp--stack-build-props new-stack)))))
- (setq pos next)))))
-
-(defun tp--update-layer-regions
- (layer-name &optional where override-alist old-props)
- "Update text regions that have LAYER-NAME applied.
-Reconcile the layer's current properties with OLD-PROPS, when given,
-so redefinition removes keys and nested values the old definition
-owned while preserving unrelated direct properties.
-
-The update also writes through to `tp-layers' stack storage: copies
-of the layer that are hidden or buried below another layer are
-refreshed in place, so a later stack operation or `tp-show-layer'
-renders current values instead of a stale snapshot.
-
-WHERE specifies which buffers to update:
- - If WHERE is a buffer, only update that buffer (setq-local case).
- - If WHERE is nil, update the buffers registered for the layer,
- falling back to a full scan when the registry has no knowledge.
-
-OVERRIDE-ALIST maps reactive variables to their new values when a
-watcher fires before those variables are set."
- (let ((update-buffer
- (lambda ()
- (let ((props (tp--layer-render-props layer-name override-alist)))
- (save-excursion
- (if props
- (progn
- ;; In hidden/full-stack mode storage is authoritative.
- ;; Update it first so the render-cache conflict guard
- ;; compares old cache with old storage.
- (tp--write-layer-through-stack-storage
- layer-name props old-props)
- (tp-search-map
- (lambda (_text start end)
- (tp--reconcile-layer-region
- start end old-props props)
- nil)
- 'tp-name layer-name))
- (tp--refresh-parameterized-layer-regions layer-name)))))))
- (tp--map-layer-buffers layer-name where update-buffer)))
-
-(defun tp--update-reactive-text (layer-name &optional where override-alist)
- "Update text regions that have tp-text property with LAYER-NAME applied.
-This is called when a reactive variable bound to tp-text changes.
-
-WHERE specifies which buffers to update:
- - If WHERE is a buffer, only update that buffer (setq-local case).
- - If WHERE is nil, update the buffers registered for the layer in
- the reactive buffer registry, falling back to one full
- `buffer-list' scan when the registry has no knowledge of the
- layer (see `tp--map-layer-buffers').
-
-OVERRIDE-ALIST maps reactive variables to their new values when the
-watcher fires before the variables are set; the layer's props are
-re-resolved against it in each target buffer.
-
-If a transform function is registered for LAYER-NAME via `:transform',
-it will be applied to the text before updating."
- (let ((update-buffer
- (lambda ()
- (let ((props (tp--layer-render-props layer-name override-alist)))
- (when props
- (let* ((raw-text (plist-get props 'tp-text))
- ;; Apply transformation if registered
- (new-text (if (stringp raw-text)
- (tp--tp-text-transform layer-name raw-text)
- raw-text)))
- (when (and new-text (stringp new-text))
- ;; No save-excursion here: the replace function
- ;; owns point restoration (its clamping semantics
- ;; would be overridden by save-excursion's own
- ;; drifting marker).
- (tp--replace-reactive-text-in-buffer
- layer-name new-text props))))))))
- (tp--map-layer-buffers layer-name where update-buffer)))
-
-(defun tp--edit-region-minimal-diff (m-start m-end plain-text skip-props)
- "Make [M-START, M-END) of the current buffer read PLAIN-TEXT.
-Only the differing span of the region is edited: the common prefix
-and suffix of the old and new text are left untouched. The
-replacement is inserted BEFORE the old span is deleted, so markers
-sitting in unchanged text keep tracking their characters - including
-a marker at the first character of the preserved suffix, which the
-old delete-then-insert order collapsed onto the edit start (TXT-1).
-Markers whose characters were deleted end up at the end of the edit.
-Does nothing when the region already reads PLAIN-TEXT, so an
-identical-text update does not mark the buffer as modified.
-Properties present at M-START whose keys the plist SKIP-PROPS does
-not contain are re-applied over the edited span (a nil SKIP-PROPS
-carries every existing property); the untouched prefix and suffix
-keep their own properties as is.
-Returns the cons (EDIT-START . EDIT-END) of the replaced span in
-PRE-edit coordinates - the caller uses it to clamp a remembered
-point that sat inside the edit - or nil when nothing was edited."
- (let ((old-text (buffer-substring-no-properties m-start m-end)))
- (unless (equal old-text plain-text)
- ;; Text content differs: trim the common prefix and suffix and
- ;; edit only the span that actually differs, so point and
- ;; markers in the unchanged parts survive the update.
- (let* ((old-len (length old-text))
- (new-len (length plain-text))
- (min-len (min old-len new-len))
- (prefix 0)
- (suffix 0))
- (while (and (< prefix min-len)
- (eq (aref old-text prefix) (aref plain-text prefix)))
- (setq prefix (1+ prefix)))
- (while (and (< suffix (- min-len prefix))
- (eq (aref old-text (- old-len suffix 1))
- (aref plain-text (- new-len suffix 1))))
- (setq suffix (1+ suffix)))
- (let ((edit-start (+ m-start prefix))
- (edit-end (- m-end suffix))
- (insert-text (substring plain-text prefix (- new-len suffix)))
- (existing-props (text-properties-at m-start)))
- ;; Insert first, then delete the (shifted) old span: an
- ;; insertion-type-nil marker at the start of the preserved
- ;; suffix sits strictly after EDIT-START, so the insertion
- ;; shifts it right with its character, and the deletion of
- ;; the old span just before it shifts it back into place.
- (goto-char edit-start)
- (insert insert-text)
- (delete-region (point) (+ (point) (- edit-end edit-start)))
- ;; Carry over existing properties whose keys SKIP-PROPS does
- ;; not name onto the newly inserted span; the untouched
- ;; prefix and suffix keep their own properties as is.
- (let ((mid-end (+ edit-start (length insert-text))))
- (cl-loop for (key val) on existing-props by #'cddr
- do (unless (plist-member skip-props key)
- (put-text-property edit-start mid-end key
- val))))
- (cons edit-start edit-end))))))
-
-(defun tp--pos-holds-layer-in-storage-only-p (pos layer-name)
- "Return non-nil when POS holds LAYER-NAME only inside `tp-layers'.
-True when the `tp-layers' stack-storage property at POS has an entry
-whose `tp-name' equals LAYER-NAME while the direct `tp-name' at POS
-is a different layer or absent (a hidden layer in all-hidden storage,
-or a layer buried below another rendered layer)."
- (and (not (equal (get-text-property pos 'tp-name) layer-name))
- (cl-some (lambda (entry)
- (equal (plist-get entry 'tp-name) layer-name))
- (get-text-property pos 'tp-layers))
- t))
-
-(defun tp--replace-reactive-text-in-buffer (layer-name new-text props)
- "Replace text in current buffer for reactive text with LAYER-NAME.
-NEW-TEXT is the new text to replace with.
-PROPS are the properties to apply to the new text.
-Only the differing span of each region is edited: the common prefix
-and suffix of the old and new text are left untouched, so point and
-markers sitting in unchanged text keep their positions (point inside
-the edited span ends up at the start of the edit). An identical-text
-update touches no buffer text at all and does not mark the buffer as
-modified.
-Text properties embedded in NEW-TEXT are merged with PROPS per
-embedded interval, so a multi-interval propertized reactive string
-keeps its per-character styling. Existing text properties whose keys
-are set neither by PROPS nor by NEW-TEXT's embedded props are
-preserved, so one layer's text update does not erase other layers'
-contributions on the same region.
-Regions where the layer sits only inside `tp-layers' stack storage -
-hidden (see `tp-hide-layer') or buried below another rendered layer -
-are updated as well: text content is physical (hide/show toggles
-properties, never text), so the model value still replaces the text
-there, but the layer's props are not applied directly; instead its
-stored stack entry, including the refreshed `tp-text', is written
-through, so `tp-show-layer' or a reveal by a later stack operation
-renders current values.
-This function owns point restoration (callers must not wrap it in
-`save-excursion', whose own marker would drift): point outside the
-edits keeps tracking its character, and point inside an edited span
-is clamped to the start of that edit."
- (let ((plain-text (substring-no-properties new-text))
- ;; Remember where the user's point was; the marker tracks all
- ;; edits, and edits that swallow point clamp it explicitly.
- (orig-point (copy-marker (point))))
- (unwind-protect
- (cl-flet ((edit-tracking-point (m-start m-end skip-props)
- ;; Run the minimal-diff edit; when the remembered
- ;; point sat inside the replaced span, clamp it to
- ;; the start of the edit (the documented
- ;; behavior).
- (let* ((was (marker-position orig-point))
- (span (tp--edit-region-minimal-diff
- m-start m-end plain-text skip-props)))
- (when (and span
- (>= was (car span))
- (< was (cdr span)))
- (set-marker orig-point (car span))))))
- (goto-char (point-min))
- ;; Pass 1: regions where the layer is the rendered top layer
- ;; (direct `tp-name').
- (let ((match (text-property-search-forward 'tp-name
- layer-name t)))
- (while match
- (let* ((m-start (prop-match-beginning match))
- (m-end (prop-match-end match)))
- (edit-tracking-point m-start m-end props)
- ;; Apply the layer's props, merged per embedded interval
- ;; of NEW-TEXT. Keys are replaced (not accumulated);
- ;; unrelated keys are untouched.
- (tp--apply-reactive-text-props new-text props m-start)
- ;; Continue searching after the fully updated region: a
- ;; preserved suffix still carries the layer's `tp-name',
- ;; and restarting the search inside it would re-match
- ;; this region.
- (goto-char (+ m-start (length plain-text))))
- (setq match (text-property-search-forward 'tp-name
- layer-name t))))
- ;; Pass 2: regions where the layer sits only inside stack
- ;; storage. Replace their text too, carrying ALL existing
- ;; properties (the visible top layer's render cache and the
- ;; `tp-layers' storage) over the edited span; the
- ;; hidden/buried layer's own props are not applied directly.
- (let ((pos (point-min)))
- (while (< pos (point-max))
- (if (tp--pos-holds-layer-in-storage-only-p pos layer-name)
- (let ((region-end pos))
- (while (and (< region-end (point-max))
- (tp--pos-holds-layer-in-storage-only-p
- region-end layer-name))
- (setq region-end (or (next-property-change
- region-end)
- (point-max))))
- (edit-tracking-point pos region-end nil)
- (setq pos (+ pos (length plain-text))))
- (setq pos (or (next-property-change pos) (point-max))))))
- ;; Write the updated props - including the refreshed
- ;; `tp-text' - through to the layer's entries in stack
- ;; storage (HID-1).
- (tp--write-layer-through-stack-storage layer-name props))
- (goto-char orig-point)
- (set-marker orig-point nil))))
-
-(defun tp--reactive-apply-update (layer-name reactive-props symbol newval
- where override-alist)
- "Recompute LAYER-NAME's definition and re-render affected regions.
-REACTIVE-PROPS are the layer's props that reference the changed
-variable SYMBOL; NEWVAL is its new value. WHERE is the buffer for
-`setq-local' changes, nil for global ones. OVERRIDE-ALIST maps SYMBOL
-to NEWVAL (the watcher runs before the variable is actually set).
-
-Buffer-local changes (WHERE a buffer) re-render only that buffer,
-resolving the layer's props against the buffer-local values, and do
-NOT touch the global layer definition, so `setq-local' cannot leak a
-buffer's value into other buffers.
-
-When `tp--batch-update-active' is non-nil the buffer update is queued
-in `tp--batch-update-pending' instead of applied immediately. When
-this function is re-entered from a nested variable write issued
-inside an update (a computed variable being set, or the tp-text
-two-way sync), the nested re-render is queued the same way and
-flushed once the outermost update completes, instead of recursing.
-
-This is the engine behind `tp--reactive-variable-watcher'; it is
-installed as `tp--reactive-update-function'."
- (ignore newval)
- (let ((tp-text-affected (and (plist-member reactive-props 'tp-text) t)))
- (if tp--reactive-updating
- ;; Nested change fired from within an update: queue, don't recurse.
- (tp--queue-batch-update layer-name symbol where tp-text-affected)
- (unwind-protect
- (let ((tp--reactive-updating t))
- ;; Update computed properties for this layer
- (let ((updated-override
- (tp--update-layer-computed layer-name override-alist)))
- ;; Update only the reactive properties in the layer definition.
- ;; Buffer-local changes must not leak into the global definition;
- ;; the buffer re-render below resolves against the buffer-local
- ;; values instead.
- (when (and reactive-props (not (bufferp where)))
- (let ((resolved-props (tp--resolve-reactive-symbols
- reactive-props updated-override))
- (current-props (cdr (assoc layer-name tp-layer-alist))))
- (when current-props
- ;; Deep merge the resolved reactive props into the current
- ;; layer props to preserve nested plist values (like face)
- (tp--set-layer-props
- layer-name
- (tp--deep-merge-plist current-props resolved-props)))))
- ;; Update text regions with this layer (or defer if batching)
- (if tp--batch-update-active
- ;; Batching: defer the buffer update
- (progn
- (tp-debug-log " Deferring buffer update for %s (batch mode)"
- layer-name)
- (tp--queue-batch-update layer-name symbol where
- tp-text-affected))
- ;; Normal: update immediately
- (tp-debug-log " Updating layer %s (tp-text affected: %s)"
- layer-name (if tp-text-affected "yes" "no"))
- (if tp-text-affected
- (tp--update-reactive-text layer-name where updated-override)
- (tp--update-layer-regions layer-name where updated-override)))))
- ;; Re-renders queued by nested variable writes during this update
- ;; are flushed now that the outermost update has finished. The
- ;; flush runs under unwind-protect so an error escaping the
- ;; re-render (for example from a modification hook) cannot strand
- ;; queued entries in the global queue (ARCH-4); the reentrancy
- ;; guard has been unbound by now, so the flush re-renders
- ;; normally.
- (unless tp--batch-update-active
- (when tp--batch-update-pending
- (tp--flush-batch-updates)))))))
-
-(defun tp--reactive-flush-entry (layer-name where tp-text-affected)
- "Re-render LAYER-NAME's regions in WHERE (or all buffers when nil).
-TP-TEXT-AFFECTED non-nil means the layer's `tp-text' changed and the
-text itself must be replaced. Runs after the changed variables have
-actually been set, so layer props re-resolve against current
-\(buffer-local aware) values. This is the per-entry worker of
-`tp--flush-batch-updates'."
- (if tp-text-affected
- (tp--update-reactive-text layer-name where)
- (tp--update-layer-regions layer-name where)))
-
-(defun tp--flush-batch-updates ()
- "Flush all pending batch updates.
-This processes all updates collected during a `tp-with-batch-updates' form."
- (tp-debug-log "Flushing %d pending batch updates" (length tp--batch-update-pending))
- (let ((processed-layers nil))
- ;; Process each pending update, avoiding duplicate layer updates
- (dolist (pending (nreverse tp--batch-update-pending))
- (let ((layer-name (car pending))
- (where (caddr pending))
- (tp-text-affected (cadddr pending)))
- (unless (memq layer-name processed-layers)
- (push layer-name processed-layers)
- (tp-debug-log " Batch updating layer %s (tp-text: %s)"
- layer-name (if tp-text-affected "yes" "no"))
- (tp--reactive-flush-entry layer-name where tp-text-affected)))))
- (setq tp--batch-update-pending nil))
-
-(defmacro tp-with-batch-updates (&rest body)
- "Execute BODY with reactive updates batched.
-Multiple variable changes within BODY are collected and applied
-together at the end, avoiding redundant buffer modifications.
-
-This is useful when changing multiple reactive variables simultaneously:
-
- (tp-with-batch-updates
- (setq my-color \"red\")
- (setq my-size 14)
- (setq my-text \"Hello\"))
-
-Without batching, each `setq' would trigger a separate buffer update.
-With batching, all updates are consolidated and applied once at the end."
- (declare (indent 0) (debug t))
- `(let ((tp--batch-update-active t)
- (tp--batch-update-pending nil))
- (tp-debug-log "Starting batch updates")
- (unwind-protect
- (progn ,@body)
- (tp-debug-log "Ending batch updates")
- (tp--flush-batch-updates))))
-
-;; Install the engine into the lower modules.
-(setq tp--reactive-update-function #'tp--reactive-apply-update)
-(setq tp--layer-refresh-function #'tp--update-layer-regions)
-
-(provide 'tp-render)
-;;; tp-render.el ends here
diff --git a/tp-search.el b/tp-search.el
index e11a670..55570e1 100644
--- a/tp-search.el
+++ b/tp-search.el
@@ -20,7 +20,6 @@
(require 'cl-lib)
(require 'text-property-search)
(require 'tp-core)
-(require 'tp-reactive)
(require 'tp-layer)
(require 'tp-ops)
@@ -31,33 +30,16 @@ Omitting VALUE selects this sentinel automatically. Pass the variable
and any present direct value should match. An explicit nil VALUE is
therefore available for exact, presence-aware nil matching.")
-(defun tp--search-register-layer-buffer (props object)
- "Record OBJECT in the reactive buffer registry for PROPS's layers.
-When OBJECT is a buffer or nil (the current buffer) and the applied
-PROPS carry a `tp-name' - directly, or inside a `tp-layers' entry
-from a group application - register that buffer under each layer name
-via `tp-reactive--register-layer-buffer', so reactive updates keep
-visiting buffers written through the pattern-apply paths. String
-OBJECTs are not registered; see `tp-reactive-layer-buffers' for that
-gap."
- (when (or (null object) (bufferp object))
- (let ((buf (or object (current-buffer))))
- (when-let ((name (plist-get props 'tp-name)))
- (tp-reactive--register-layer-buffer name buf))
- (dolist (layer (plist-get props 'tp-layers))
- (when-let ((name (plist-get layer 'tp-name)))
- (tp-reactive--register-layer-buffer name buf))))))
-
(defun tp--pattern-apply-single (pattern properties apply-fn object literal
&optional start end subexp)
- "Apply APPLY-FN to matches of single PATTERN in OBJECT.
+ "Apply PROPERTIES with APPLY-FN to matches of single PATTERN in OBJECT.
When LITERAL is non-nil, PATTERN is matched literally; otherwise it
is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for
each match.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. If START > END the bounds
-are swapped (matching the buffer path's historical narrow-to-region
+are swapped (matching the buffer path's historical `narrow-to-region'
behavior, now uniform across object types). Matching behaves as if
OBJECT consisted only of that portion (the buffer path narrows, the
string path matches against the substring), so no match crosses the
@@ -148,7 +130,7 @@ position past them, so the search always terminates."
(defun tp--pattern-apply (pattern properties apply-fn object literal
&optional start end subexp)
- "Apply APPLY-FN to matches of PATTERN (one pattern or a list).
+ "Apply PROPERTIES with APPLY-FN to matches of PATTERN.
When LITERAL is non-nil, patterns are matched literally; otherwise
they are regexps. APPLY-FN is called with (START END PROPS OBJECT)
for each match.
@@ -180,14 +162,14 @@ For buffers, returns list of regions."
(defun tp--match-apply-single (pattern properties apply-fn object
&optional start end)
- "Apply APPLY-FN to literal matches of single PATTERN in OBJECT.
+ "Apply PROPERTIES with APPLY-FN to literal matches of PATTERN in OBJECT.
START and END restrict matching to [START, END) in native coordinates.
For strings, returns a new string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(tp--pattern-apply-single pattern properties apply-fn object t start end))
(defun tp--match-apply (pattern properties apply-fn &optional object start end)
- "Internal function to apply APPLY-FN to matches of PATTERN.
+ "Apply PROPERTIES with APPLY-FN to matches of PATTERN.
PATTERN can be a string or a list of strings (multiple patterns).
When PATTERN is a list, each element is a pattern to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
@@ -198,7 +180,7 @@ For buffers, returns list of regions."
(defun tp--regexp-apply-single (pattern properties apply-fn object
&optional start end subexp)
- "Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
+ "Apply PROPERTIES with APPLY-FN to regexp matches of PATTERN in OBJECT.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target.
@@ -209,7 +191,7 @@ For buffers, modifies in-place and returns list of regions."
(defun tp--regexp-apply (pattern properties apply-fn
&optional object start end subexp)
- "Internal function to apply APPLY-FN to regexp matches of PATTERN.
+ "Apply PROPERTIES with APPLY-FN to regexp matches of PATTERN.
PATTERN can be a string (single regexp) or a list of strings (multiple regexps).
When PATTERN is a list, each element is a regexp to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
@@ -219,40 +201,6 @@ For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(tp--pattern-apply pattern properties apply-fn object nil start end subexp))
-(defun tp--deep-merge-apply (start end props obj)
- "Apply PROPS to OBJ from START to END with deep merge.
-Merges nested plists instead of replacing them.
-For strings, returns a NEW string (original is not modified).
-For buffers, modifies in-place."
- (if (stringp obj)
- ;; For strings: create a new propertized string using tp--apply-props-to-string with :add mode
- (tp--apply-props-to-string obj start end props :add)
- ;; For buffers: modify in-place. This path stamps `tp-name' for
- ;; resolved layer applications, so the buffer must be registered
- ;; in the reactive registry or later updates would skip it (REG-1).
- (tp--search-register-layer-buffer props obj)
- (let ((pos start))
- (while (< pos end)
- (let* ((current-props (text-properties-at pos obj))
- (next-pos (or (next-property-change pos obj end) end)))
- (cl-loop for (key val) on props by #'cddr
- do (let* ((current-val (plist-get current-props key))
- (new-val
- (cond
- ;; Face-family properties merge with the
- ;; incoming face taking precedence, same as
- ;; the string path (:add mode).
- ((memq key tp-face-properties)
- (tp--prepend-face val current-val))
- ((and (listp val) (keywordp (car-safe val))
- (listp current-val)
- (keywordp (car-safe current-val)))
- (tp--deep-merge-plist current-val val))
- (t val))))
- (put-text-property pos next-pos key new-val obj)))
- (setq pos next-pos))))
- obj))
-
(defun tp-match-set (pattern plist &optional object start end)
"Set properties on all occurrences of PATTERN.
@@ -274,7 +222,7 @@ Returns:
- For strings: a NEW string with properties applied (the original
string is not modified)
- For buffers: list of (START . END) pairs for all matches."
- (tp--match-apply pattern (tp--ensure-props plist) #'tp-set object
+ (tp--match-apply pattern (tp--prepare-direct-properties plist) #'tp-set object
start end))
(defun tp-match-reset (pattern plist &optional object start end)
@@ -297,22 +245,10 @@ Unlike `tp-match-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
- (tp--match-apply pattern (tp--ensure-props plist)
+ (tp--match-apply pattern (tp--prepare-direct-properties plist)
#'tp--reset-apply
object start end))
-(defun tp--reset-apply (start end props obj)
- "Apply PROPS to OBJ from START to END, completely replacing existing properties.
-For strings, returns a NEW string.
-For buffers, modifies in-place."
- (if (stringp obj)
- (tp--apply-props-to-string obj start end props :reset)
- (set-text-properties start end props obj)
- ;; A resolved layer application stamps `tp-name': register the
- ;; buffer so reactive updates keep visiting it (REG-1).
- (tp--search-register-layer-buffer props obj)
- obj))
-
(defun tp-match-add (pattern plist &optional object start end)
"Add/update properties on all occurrences of PATTERN.
@@ -333,7 +269,7 @@ Unlike `tp-match-set', this deeply merges nested properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
- (tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
+ (tp--match-apply pattern (tp--prepare-direct-properties plist) #'tp--deep-merge-apply
object start end))
(defun tp-regexp-set (pattern plist &optional object start end subexp)
@@ -362,7 +298,7 @@ Returns:
- For strings: a NEW string with properties applied (the original
string is not modified)
- For buffers: list of (START . END) pairs for all matches."
- (tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object
+ (tp--regexp-apply pattern (tp--prepare-direct-properties plist) #'tp-set object
start end subexp))
(defun tp-regexp-reset (pattern plist &optional object start end subexp)
@@ -389,7 +325,7 @@ Unlike `tp-regexp-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
- (tp--regexp-apply pattern (tp--ensure-props plist)
+ (tp--regexp-apply pattern (tp--prepare-direct-properties plist)
#'tp--reset-apply
object start end subexp))
@@ -417,7 +353,7 @@ Unlike `tp-regexp-set', this deeply merges nested properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of (START . END)
regions."
- (tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
+ (tp--regexp-apply pattern (tp--prepare-direct-properties plist) #'tp--deep-merge-apply
object start end subexp))
(defun tp-search-forward (property &optional value predicate not-current)
@@ -465,7 +401,7 @@ non-nil. `tp-any-value' matches every PROP-VALUE."
(equal value prop-value))))
(defun tp--property-matches (object start end property value predicate)
- "Return matching direct PROPERTY runs in OBJECT between START and END.
+ "Collect direct PROPERTY matches in OBJECT between START and END.
Each result is a canonical `tp--match'. A run is eligible only when
PROPERTY is present in `text-properties-at', so an explicit nil value
is distinct from absence. Boundaries caused only by unrelated
@@ -528,7 +464,8 @@ Only direct PROPERTY runs are candidates. VALUE and PREDICATE follow
(tp--match-to-prop-match found))))))
(defun tp--property-search-forward (property value predicate not-current)
- "Search forward once for a direct PROPERTY run from point."
+ "Search forward for PROPERTY matching VALUE under PREDICATE.
+When NOT-CURRENT is non-nil, skip the run containing point."
(let* ((origin (point))
(found
(seq-find
@@ -553,7 +490,7 @@ Only direct PROPERTY runs are candidates. VALUE and PREDICATE follow
(tp--match-to-prop-match found)))))
(defun tp--search-result-value (object start end property value)
- "Return public search matches for OBJECT between START and END."
+ "Return matches for PROPERTY and VALUE in OBJECT between START and END."
(let* ((range (tp--native-range-from-object object start end))
(request (tp--make-request
:operation :search :range range :property property
@@ -750,7 +687,7 @@ Any non-string return value leaves OBJ untouched."
;; (truncation or residue); reject it clearly instead.
(let ((len (- m-end m-start)))
(unless (= (length new-text) len)
- (error "tp: replacement %S is %d chars but the match is %d; \
+ (error "TP: replacement %S is %d chars but the match is %d; \
strings cannot change length in place -- use a buffer OBJECT for \
length-changing replacements" new-text (length new-text) len))
(store-substring obj m-start new-text)
@@ -960,6 +897,9 @@ When VALUE is omitted, match every run where PROPERTY is directly
present. An explicit nil matches only directly present nil values.
Use `tp-any-value' explicitly when OBJECT must also be supplied.
+START-OR-STRING selects the range start or complete string. END-OR-PROPERTY,
+PROPERTY-OR-VALUE, VALUE, and OBJECT complete the selected calling convention.
+
Returns a list of (START END VALUE) lists for all matching regions.
Each element contains the start position, end position, and property value."
(cond
diff --git a/tp-stack.el b/tp-stack.el
deleted file mode 100644
index 974310f..0000000
--- a/tp-stack.el
+++ /dev/null
@@ -1,1554 +0,0 @@
-;;; tp-stack.el --- Layer stack operations for tp -*- lexical-binding: t -*-
-
-;; Copyright (C) 2024-2026 Geekinney
-
-;; Author: Geekinney (kinneyzhang666@gmail.com)
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 3 of
-;; the License, or (at your option) any later version.
-
-;;; Commentary:
-
-;; Photoshop-style layer stack operations on text regions: put/push/
-;; 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)
-
-;;; Shared argument parsing and region iteration
-
-(defun tp--parse-layer-args (start-or-string rest n)
- "Normalize a layer operation's positional arguments.
-
-START-OR-STRING is the caller's first positional argument and REST the
-list of its remaining positional arguments, in order. N is the number
-of operation-specific arguments the caller takes (for example 2 for
-`tp-put-layer's LAYER and IDX).
-
-Two calling conventions are supported:
-- (STRING ARG1 ... ARGN): operate on the whole STRING.
-- (START END ARG1 ... ARGN OBJECT): operate on a region of OBJECT,
- where nil means the current buffer.
-
-Returns the list (START END OBJECT ARG1 ... ARGN) with START/END in
-OBJECT's native coordinates (0-based for strings, 1-based for
-buffers)."
- (cond
- ((stringp start-or-string)
- (let ((range (tp--native-range-from-object
- start-or-string 0 (length start-or-string))))
- (append (list (tp--native-range-start range)
- (tp--native-range-end range)
- (tp--native-range-object range))
- (seq-take rest n))))
- ((numberp start-or-string)
- (let* ((operation-args (seq-take (cdr rest) n))
- (object (nth (1+ n) rest))
- (range (tp--native-range-from-object
- object start-or-string (car rest))))
- (append (list (tp--native-range-start range)
- (tp--native-range-end range)
- (tp--native-range-object range))
- operation-args)))
- (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)))
-
-(define-error 'tp-layer-transaction-error "tp layer transaction failed")
-
-(defvar tp--managed-operation-counter 0
- "Monotonic counter for managed lifecycle operation ids.")
-
-(defun tp--managed-next-operation-id ()
- "Return a fresh managed lifecycle operation id."
- (setq tp--managed-operation-counter (1+ tp--managed-operation-counter))
- (intern (format "tp-managed-op-%d" tp--managed-operation-counter)))
-
-(defun tp--plist-remove-keys (plist keys)
- "Return a copy of PLIST without any key in KEYS."
- (cl-loop for (k v) on plist by #'cddr
- unless (memq k keys) append (list k v)))
-
-(defun tp--managed-render-props (layer)
- "Return LAYER without lifecycle-only storage properties."
- (tp--entry-render-projection layer))
-
-(defun tp--managed-public-layer-props (layer)
- "Return LAYER's public stack query properties."
- (tp--plist-remove-keys layer '(tp-name tp-meta)))
-
-(defun tp--managed-spec-arglist (name)
- "Return NAME's parameter arglist when available."
- (cond
- ((and (fboundp 'tp-layer-parameterized-p)
- (tp-layer-parameterized-p name))
- (tp-layer-arglist name))
- ((and (fboundp 'tp-group-parameterized-p)
- (tp-group-parameterized-p name))
- (tp--group-arglist name))))
-
-(defun tp--managed-meta-for-spec (spec layer)
- "Build managed metadata for SPEC mounted as LAYER."
- (let* ((name (plist-get layer 'tp-name))
- (spec-name (if (consp spec) (car spec) spec))
- (group-p (and (symbolp spec-name)
- (assoc spec-name tp-layer-groups)))
- (parameterized-p (and (symbolp spec-name)
- (tp--managed-spec-arglist spec-name)))
- (args (when (and (consp spec) (or group-p parameterized-p))
- (copy-tree (cdr spec))))
- (origin (cond
- (group-p 'group)
- (args 'parameterized)
- ((assoc name tp-layer-alist) 'defined)
- (name 'inline)
- (t 'anonymous))))
- (tp--managed-entry-meta
- name origin spec args (tp--managed-spec-arglist spec-name))))
-
-(defun tp--managed-add-meta-to-layers (spec layers)
- "Return LAYERS with managed metadata derived from SPEC."
- (mapcar (lambda (layer)
- (if (plist-member layer 'tp-meta)
- layer
- (append layer
- (list 'tp-meta
- (tp--managed-meta-for-spec spec layer)))))
- layers))
-
-(defun tp--stack-map-region (start end object function)
- "Call FUNCTION over each property run of [START, END) in OBJECT.
-
-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). Hidden layers
-\(see `tp-hide-layer') are included at their stack position.
-
-Returns the list of FUNCTION's non-nil results, in order.
-
-Unlike `tp-intervals-map', runs never extend beyond the requested
-region, positions are absolute for strings as well as buffers, and
-bare text is visited (with an empty STACK) so layers can be applied to
-previously property-less text."
- (delq nil
- (tp--map-intervals
- object start end
- (lambda (i-start i-end props)
- (funcall function i-start i-end
- (tp--stack-props-to-list props))))))
-
-(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
-
-(defun tp-region-layer-props (start end layer-name &optional object)
- "Return layer properties for LAYER-NAME in region from START to END.
-OBJECT defaults to current buffer.
-Returns a list of (START END PROPERTIES) for matching intervals, with
-positions in OBJECT's native coordinates (0-based for strings, 1-based
-for buffers) and clipped to the requested region."
- (tp--stack-map-region
- start end object
- (lambda (abs-start abs-end stack)
- (when-let ((props (seq-find
- (lambda (props)
- (equal layer-name
- (plist-get props 'tp-name)))
- stack)))
- (list abs-start abs-end
- (tp--plist-remove props 'tp-meta))))))
-
-(defun tp-layer-list (start end &optional object)
- "Return list of all layer names in region from START to END."
- (let ((layers nil))
- (tp--stack-map-region
- start end object
- (lambda (_abs-start _abs-end stack)
- (dolist (layer stack)
- (when-let ((name (plist-get layer 'tp-name)))
- (cl-pushnew name layers :test #'equal)))))
- (nreverse layers)))
-
-(defun tp-layer-count (start end &optional object)
- "Return number of layers in region from START to END.
-OBJECT defaults to current buffer."
- (let ((max-count 0))
- (tp--stack-map-region
- start end object
- (lambda (_abs-start _abs-end stack)
- (setq max-count (max max-count (length stack)))))
- max-count))
-
-(defun tp-layer-exists-p (start end name &optional object)
- "Return t if layer NAME exists in region from START to END.
-OBJECT defaults to current buffer."
- (not (null (tp-region-layer-props start end name object))))
-
-(defun tp-layer-top (start end &optional object)
- "Return the name of the topmost named layer in START..END of OBJECT.
-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.
-
-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--managed-public-layer-props layer)))
- (tp--stack-props-to-list (text-properties-at pos object))))
-
-;;; Managed lifecycle APIs
-
-(defun tp--managed-layer-names-in-stack (stack)
- "Return named managed layers from STACK in stack order."
- (let (names)
- (dolist (layer stack)
- (when-let ((name (plist-get layer 'tp-name)))
- (cl-pushnew name names :test #'equal)))
- (nreverse names)))
-
-(defun tp--managed-legacy-meta (layer)
- "Return safe legacy metadata for LAYER."
- (plist-put
- (tp--managed-meta-for-spec (plist-get layer 'tp-name) layer)
- :legacy-no-args t))
-
-(defun tp--managed-normalize-stack (stack)
- "Return STACK with safe legacy managed entries migrated."
- (mapcar (lambda (layer)
- (if (or (not (plist-get layer 'tp-name))
- (plist-member layer 'tp-meta))
- layer
- (append layer (list 'tp-meta
- (tp--managed-legacy-meta layer)))))
- stack))
-
-;;;###autoload
-(defun tp-attach-managed-layers (start end &optional object)
- "Attach managed layer identity in START..END of OBJECT.
-The scan is limited to the requested range. Return discovered layer
-names in range order."
- (let ((found nil))
- (tp--stack-map-region
- start end object
- (lambda (abs-start abs-end stack)
- (let ((new-stack (tp--managed-normalize-stack stack)))
- (unless (equal new-stack stack)
- (set-text-properties abs-start abs-end
- (tp--stack-build-props new-stack)
- object))
- (dolist (name (tp--managed-layer-names-in-stack new-stack))
- (cl-pushnew name found :test #'equal)))))
- (dolist (name (nreverse found))
- (when (or (null object) (bufferp object))
- (tp-reactive--register-layer-buffer
- name (or object (current-buffer)))))
- (nreverse found)))
-
-(defun tp--managed-detached-props (stack keep-rendered)
- "Return raw properties for detaching STACK.
-When KEEP-RENDERED is non-nil, preserve the current visible
- projection without managed storage properties."
- (when keep-rendered
- (tp--plist-remove
- (tp--managed-render-props
- (seq-find (lambda (layer)
- (not (tp--stack-hidden-p layer)))
- stack))
- 'tp-name)))
-
-;;;###autoload
-(defun tp-detach-managed-layers (start end &optional object keep-rendered)
- "Detach managed layer storage in START..END of OBJECT.
-When KEEP-RENDERED is non-nil, preserve currently visible text
-properties after removing lifecycle storage. Return detached layer
-names in range order."
- (let ((found nil))
- (tp--stack-map-region
- start end object
- (lambda (abs-start abs-end stack)
- (when stack
- (dolist (name (tp--managed-layer-names-in-stack stack))
- (cl-pushnew name found :test #'equal))
- (set-text-properties abs-start abs-end
- (tp--managed-detached-props
- stack keep-rendered)
- object))))
- (let ((result (nreverse found)))
- (when (or (null object) (bufferp object))
- (let* ((buffer (or object (current-buffer)))
- (remaining (tp-reactive--buffer-layer-names buffer)))
- (dolist (name result)
- (unless (member name remaining)
- (tp-reactive--unregister-layer-buffer name buffer)))))
- result)))
-
-(defun tp--managed-layer-entry (start end layer)
- "Return a diagnostics entry for LAYER covering START..END."
- (let ((meta (plist-get layer 'tp-meta)))
- (list :range (cons start end)
- :name (plist-get layer 'tp-name)
- :entry-id (plist-get meta :entry-id)
- :origin (plist-get meta :origin)
- :spec (copy-tree (plist-get meta :spec))
- :args (copy-tree (plist-get meta :args))
- :arglist (copy-tree (plist-get meta :arglist))
- :definition-version (plist-get meta :definition-version)
- :entry-version (plist-get meta :entry-version)
- :hidden (tp--stack-hidden-p layer)
- :palette-deps (copy-tree (plist-get meta :palette-deps))
- :palette-generation (plist-get meta :palette-generation)
- :legacy-no-args (plist-get meta :legacy-no-args))))
-
-(defun tp--managed-buffer-diagnostic-data (buffer layer-filter)
- "Collect managed diagnostics in BUFFER for LAYER-FILTER or all layers."
- (let ((layers nil)
- (entries nil)
- (errors nil))
- (when (buffer-live-p buffer)
- (tp--map-intervals
- buffer nil nil
- (lambda (start end props)
- (condition-case err
- (dolist (layer (tp--stack-props-to-list props))
- (let ((name (plist-get layer 'tp-name)))
- (when (and name
- (or (null layer-filter)
- (equal name layer-filter)))
- (cl-pushnew name layers :test #'equal)
- (push (tp--managed-layer-entry start end layer)
- entries))))
- (error
- (push (list :range (cons start end)
- :condition err)
- errors))))))
- (list :buffer buffer
- :layers (nreverse layers)
- :entries (nreverse entries)
- :observer-errors (copy-tree tp-reactive-observer-errors)
- :errors (nreverse errors))))
-
-;;;###autoload
-(defun tp-managed-layer-diagnostics (layer-name)
- "Return read-only managed diagnostics for LAYER-NAME."
- (let ((entries nil)
- (buffers nil)
- (errors nil)
- (registered (tp-reactive-layer-buffers layer-name)))
- (dolist (buffer (if (eq registered 'unknown)
- (buffer-list)
- registered))
- (when (buffer-live-p buffer)
- (let ((diag (tp--managed-buffer-diagnostic-data
- buffer layer-name)))
- (when (plist-get diag :entries)
- (push buffer buffers)
- (setq entries (append entries
- (plist-get diag :entries))))
- (setq errors (append errors (plist-get diag :errors))))))
- (list :layer layer-name
- :definition-version (tp--layer-definition-version layer-name)
- :entries entries
- :args (mapcar (lambda (entry)
- (plist-get entry :args))
- entries)
- :registry registered
- :buffers (nreverse buffers)
- :observer-errors
- (cl-remove-if-not
- (lambda (entry) (equal (plist-get entry :layer) layer-name))
- (copy-tree tp-reactive-observer-errors))
- :errors errors)))
-
-;;;###autoload
-(defun tp-managed-buffer-diagnostics (&optional buffer)
- "Return read-only managed diagnostics for BUFFER."
- (tp--managed-buffer-diagnostic-data
- (or buffer (current-buffer)) nil))
-
-(defun tp--managed-theme-diagnostics ()
- "Return read-only managed theme diagnostics."
- (list :generation (if (boundp 'tp-theme-generation)
- tp-theme-generation 0)
- :last-hook-source (and (boundp 'tp-theme-last-hook-source)
- tp-theme-last-hook-source)
- :refresh-mode (if (boundp 'tp-theme-last-refresh-mode)
- tp-theme-last-refresh-mode :conservative)
- :refreshed-ranges
- (and (boundp 'tp-theme-last-refreshed-ranges)
- tp-theme-last-refreshed-ranges)
- :errors (and (boundp 'tp-theme-last-refresh-errors)
- tp-theme-last-refresh-errors)))
-
-;;;###autoload
-(defun tp-managed-diagnostics ()
- "Return read-only global managed lifecycle diagnostics."
- (let ((layers nil)
- (buffers nil)
- (entries nil)
- (errors nil))
- (dolist (buffer (buffer-list))
- (when (buffer-live-p buffer)
- (let ((diag (tp--managed-buffer-diagnostic-data buffer nil)))
- (when (plist-get diag :entries)
- (push buffer buffers)
- (setq layers (append layers (plist-get diag :layers)))
- (setq entries (append entries
- (plist-get diag :entries))))
- (setq errors (append errors (plist-get diag :errors))))))
- (list :layers (delete-dups layers)
- :buffers (nreverse buffers)
- :entries entries
- :args (mapcar (lambda (entry)
- (plist-get entry :args))
- entries)
- :registry (copy-hash-table tp--layer-buffers)
- :observer-errors (copy-tree tp-reactive-observer-errors)
- :errors errors
- :theme (tp--managed-theme-diagnostics))))
-
-(defun tp--transaction-snapshot (start end object)
- "Snapshot exact text and properties in START..END of OBJECT."
- (if (stringp object)
- (substring object start end)
- (let ((buf (or object (current-buffer))))
- (with-current-buffer buf
- (buffer-substring start end)))))
-
-(defun tp--transaction-restore (start end object snapshot)
- "Restore SNAPSHOT over START..END of OBJECT."
- (if (stringp object)
- (progn
- (unless (= (- end start) (length snapshot))
- (error "Cannot restore a resized string transaction"))
- (store-substring object start (substring-no-properties snapshot))
- (set-text-properties start end nil object)
- (tp--map-intervals
- snapshot 0 (length snapshot)
- (lambda (from to props)
- (set-text-properties (+ start from) (+ start to) props object))))
- (let ((buf (or object (current-buffer))))
- (with-current-buffer buf
- (let ((inhibit-read-only t))
- (delete-region start end)
- (goto-char start)
- (insert snapshot))))))
-
-(defun tp--transaction-runs (start end object)
- "Return exact property intervals for START..END of OBJECT."
- (tp-intervals start end object t))
-
-(defun tp--transaction-changed-ranges (before after)
- "Return ranges whose text/property intervals differ between BEFORE and AFTER."
- (let (ranges)
- (cl-loop for b in before
- for a in after
- unless (equal b a)
- do (push (cons (nth 0 (or a b))
- (nth 1 (or a b)))
- ranges))
- (when (/= (length before) (length after))
- (dolist (entry (nthcdr (min (length before) (length after))
- (append before after)))
- (push (cons (nth 0 entry) (nth 1 entry)) ranges)))
- (nreverse ranges)))
-
-(defun tp--transaction-live-bounds (from to markers)
- "Return the live transaction bounds for FROM, TO, and MARKERS."
- (if markers
- (cons (marker-position (car markers))
- (marker-position (cdr markers)))
- (cons from to)))
-
-(defun tp--transaction-result
- (status operation-id stage start end object result condition rollback changed)
- "Build a structured transaction result plist."
- (list :status status
- :ok (eq status 'ok)
- :result result
- :operation-id operation-id
- :stage stage
- :object object
- :range (cons start end)
- :current-run (car (tp--transaction-runs start end object))
- :layer nil
- :entry-id nil
- :expected-version nil
- :actual-version nil
- :expected-properties nil
- :actual-properties nil
- :original-condition condition
- :rollback-applied rollback
- :changed-ranges changed))
-
-;;;###autoload
-(defun tp-layer-transaction (start end object function &optional noerror)
- "Run FUNCTION as a managed layer transaction over START..END of OBJECT.
-On success, return a structured plist whose `:result' is FUNCTION's
-value. On failure, restore the exact pre-transaction text/property
-state. Signal `tp-layer-transaction-error' unless NOERROR is non-nil,
-in which case return the structured failure plist."
- (let* ((range (tp--native-range-from-object object start end))
- (obj (tp--native-range-object range))
- (from (tp--native-range-start range))
- (to (tp--native-range-end range))
- (operation-id (tp--managed-next-operation-id))
- (snapshot (tp--transaction-snapshot from to obj))
- (before (tp--transaction-runs from to obj))
- (markers (unless (stringp obj)
- (cons (copy-marker from nil)
- (copy-marker to nil)))))
- (unwind-protect
- (condition-case err
- (let* ((result (funcall function))
- (live (tp--transaction-live-bounds from to markers)))
- (tp--transaction-result
- 'ok operation-id 'commit from to obj result nil nil
- (tp--transaction-changed-ranges
- before (tp--transaction-runs
- (car live) (cdr live) obj))))
- (error
- (let* ((live (tp--transaction-live-bounds from to markers))
- (rollback-applied nil)
- rollback-condition)
- (condition-case rollback-err
- (progn
- (tp--transaction-restore
- (car live) (cdr live) obj snapshot)
- (setq rollback-applied t))
- (error (setq rollback-condition rollback-err)))
- (let ((result (tp--transaction-result
- 'error operation-id 'body from to obj nil err
- rollback-applied
- (tp--transaction-changed-ranges
- before (tp--transaction-runs from to obj)))))
- (when rollback-condition
- (setq result
- (plist-put result :rollback-condition
- rollback-condition)))
- (if noerror
- result
- (signal 'tp-layer-transaction-error (list result)))))))
- (when markers
- (set-marker (car markers) nil)
- (set-marker (cdr markers) nil)))))
-
-;;; Layer spec normalization for tp-put-layer
-
-(defun tp--put-layer-specs (layer-spec)
- "Normalize LAYER-SPEC into a list of layer plists for `tp-put-layer'.
-
-LAYER-SPEC can be:
-- a layer name or group name (symbol);
-- (LAYER-NAME ARG) or (GROUP-NAME ARG) for parameterized layers/groups;
-- an inline plist, e.g. (face bold) or (:foreground \"red\");
-- (NAME PROP VAL ...) for a named inline layer;
-- a list of any of the above.
-
-An inline plist is recognized by its even length together with a head
-that is a keyword or an ordinary property symbol (one that is not a
-defined layer or group name); a named inline layer has odd length
-\(NAME plus prop/value pairs)."
- (cond
- ;; Group name symbol.
- ((and (symbolp layer-spec)
- (assoc layer-spec tp-layer-groups))
- (if (tp-group-parameterized-p layer-spec)
- (error "Parameterized group %S requires an argument, use '(%S ARG)"
- layer-spec layer-spec)
- (tp-group-props layer-spec t))) ; include tp-name for layer stack
- ;; 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))
- (= (safe-length layer-spec) 2)
- (tp-group-parameterized-p (car layer-spec)))
- (tp-group-props-with-arg (car layer-spec) (cadr layer-spec) t))
- ;; (LAYER-NAME ARG): parameterized layer.
- ((and (consp layer-spec)
- (symbolp (car layer-spec))
- (= (safe-length layer-spec) 2)
- (tp-layer-parameterized-p (car layer-spec)))
- (list (tp--normalize-layer-spec layer-spec)))
- ;; Keyword-headed plist: a single inline layer.
- ((and (consp layer-spec) (keywordp (car layer-spec)))
- (list (tp--normalize-layer-spec layer-spec)))
- ;; Even-length plist headed by an ordinary (non-layer) property
- ;; symbol, e.g. (face bold): a single inline layer.
- ((and (consp layer-spec)
- (car layer-spec)
- (symbolp (car layer-spec))
- (not (tp--is-layer-name-p (car layer-spec)))
- (proper-list-p layer-spec)
- (cl-evenp (length layer-spec)))
- (list layer-spec))
- ;; List whose every element is itself a spec (a layer/group name or
- ;; a list): multiple layers.
- ((and (consp layer-spec)
- (proper-list-p layer-spec)
- (cl-every (lambda (el)
- (or (consp el) (tp--is-layer-name-p el)))
- layer-spec))
- (apply #'append (mapcar #'tp--put-layer-specs layer-spec)))
- ;; Anything else, including (NAME PROP VAL ...) named inline
- ;; layers; tp--normalize-layer-spec signals on invalid specs.
- (t
- (list (tp--normalize-layer-spec layer-spec)))))
-
-;;; Mutators
-
-(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 NOERROR)
-
-2. Entire string:
- (tp-put-layer STRING LAYER IDX NOERROR)
-
-LAYER can be:
-- A symbol (layer name from `tp-layer-alist' or `tp-layer-groups')
-- A list (LAYER-NAME ARG) or (GROUP-NAME ARG) for parameterized
- layers or groups
-- A plist (inline layer definition), e.g. (face bold)
-- A list (NAME &rest PLIST) for named inline layer
-- A list of the above for multiple layers
-
-IDX specifies where to insert:
-- 0 means top (visible layer)
-- -1 means bottom
-- Other values insert at that position
-
-OBJECT defaults to current buffer for region form. Only text inside
-\[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* ((noerr (if (stringp start-or-string) idx-or-object noerror))
- (layers-to-add
- (if noerr
- (condition-case nil
- (tp--put-layer-specs layer-spec)
- (tp-unresolved-layer 'tp--unresolved))
- (tp--put-layer-specs layer-spec))))
- (unless (eq layers-to-add 'tp--unresolved)
- (setq layers-to-add
- (tp--managed-add-meta-to-layers layer-spec layers-to-add))
- (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 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 NOERROR)
-
-2. Entire string:
- (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)))
- (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.
-
-Calling conventions:
-1. Buffer/string region:
- (tp-delete-layer START END LAYER-NAME/IDX OBJECT)
-
-2. Entire string:
- (tp-delete-layer STRING LAYER-NAME/IDX)
-
-LAYER-NAME/IDX can be:
-- A symbol (layer name)
-- An integer (layer index, 0=top, -1=bottom)
-
-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)))
- (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.
-
-This is equivalent to (tp-delete-layer ... 0 ...).
-
-Calling conventions:
-1. Buffer/string region:
- (tp-pop-layer START END OBJECT)
-
-2. Entire 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)))
- (tp-delete-layer start end 0 obj)))
-
-(defun tp--move-layer-in-stack (stack from-id to-idx)
- "Move layer at FROM-ID to TO-IDX position in STACK.
-FROM-ID can be an integer index or a layer name symbol.
-TO-IDX must be an integer index.
-Both indices refer to positions before the move and can be negative
-\(counting from end).
-TO-IDX is clamped to valid range (0 to stack length - 1) if out of bounds.
-Returns the new stack, or nil if FROM-ID is invalid."
- (let* ((len (length stack))
- ;; Resolve from-id to actual index
- (found (tp--get-layer-by-idx-or-name stack from-id))
- (actual-from (when found (car found)))
- ;; Normalize to-idx
- (actual-to (if (< to-idx 0)
- (+ len to-idx)
- to-idx)))
- ;; Only proceed if from-id is valid
- (when actual-from
- (let* ((layer-props (cdr found))
- (stack-without (-remove-at actual-from stack))
- ;; Clamp to-idx to valid range for insertion
- (clamped-to (max 0 (min actual-to (length stack-without)))))
- (append (seq-take stack-without clamped-to)
- (list layer-props)
- (seq-drop stack-without clamped-to))))))
-
-(defun tp--raise-layer-in-stack (stack from-id n)
- "Raise layer at FROM-ID by N positions in STACK.
-FROM-ID can be an integer index or a layer name symbol.
-Positive N moves the layer up (toward top/visible).
-Negative N moves the layer down (toward bottom).
-The resulting position is clamped to valid range (0 to stack length - 1).
-Returns the new stack, or nil if FROM-ID is invalid."
- (let* ((found (tp--get-layer-by-idx-or-name stack from-id))
- (actual-from (when found (car found))))
- (when actual-from
- (let* ((len (length stack))
- ;; Calculate new position: subtracting N because lower index = higher in stack
- (new-idx (max 0 (min (1- len) (- actual-from n)))))
- (tp--move-layer-in-stack stack actual-from new-idx)))))
-
-(defun tp--switch-layers-in-stack (stack id1 id2)
- "Swap layers at ID1 and ID2 positions in STACK.
-ID1 and ID2 can be integer indices or layer name symbols.
-Returns the new stack, or nil if either ID is invalid."
- (let* ((found1 (tp--get-layer-by-idx-or-name stack id1))
- (found2 (tp--get-layer-by-idx-or-name stack id2)))
- (when (and found1 found2)
- (let* ((idx1 (car found1))
- (idx2 (car found2))
- (props1 (cdr found1))
- (props2 (cdr found2))
- (new-stack (copy-sequence stack)))
- (setf (nth idx1 new-stack) props2)
- (setf (nth idx2 new-stack) props1)
- new-stack))))
-
-(defun tp-move-layer (start-or-string &optional end-or-from from-or-to to-or-object object)
- "Move a layer from one position to another in the layer stack.
-
-Calling conventions:
-1. Buffer/string region:
- (tp-move-layer START END FROM-ID TO-IDX OBJECT)
-
-2. Entire string:
- (tp-move-layer STRING FROM-ID TO-IDX)
-
-FROM-ID identifies the layer to move:
-- An integer index (0 = top, 1 = second from top, -1 = bottom, etc.)
-- A layer name symbol
-
-TO-IDX is the target position (integer index):
-- 0 means top (visible)
-- Positive integers count from top
-- -1 means bottom
-- Negative integers count from bottom
-
-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.
-
-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)))
- (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.
-
-Calling conventions:
-1. Buffer/string region:
- (tp-raise-layer START END IDX/LAYER-NAME N OBJECT)
-
-2. Entire string:
- (tp-raise-layer STRING IDX/LAYER-NAME N)
-
-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'.
-
-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))
- (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-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-lower-layer START END IDX/LAYER-NAME N OBJECT)
-
-2. Entire string:
- (tp-lower-layer STRING IDX/LAYER-NAME N)
-
-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-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)
- "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:
- (tp-pin-layer START END IDX/LAYER-NAME OBJECT)
-
-2. Entire string:
- (tp-pin-layer STRING IDX/LAYER-NAME)
-
-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
- (list end-or-idx idx-or-object object) 1)))
- (tp-move-layer start end layer-id 0 obj)))
-
-(defun tp-switch-layer (start-or-string &optional end-or-id1 id1-or-id2 id2-or-object object)
- "Switch between two layers by name or index.
-
-Calling conventions:
-1. Buffer/string region:
- (tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT)
-
-2. Entire string:
- (tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)
-
-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)))
- (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.
-LAYERS is a list of (INDEX . PROPS) conses as returned by
-`tp--get-layer-by-idx-or-name'. Earlier layers take precedence: a key
-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), 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 (memq key '(tp-name tp-hidden))
- do (unless (plist-member acc key)
- (setq acc (plist-put acc key val))))
- acc)
- layers
- :initial-value initial))
-
-(defun tp-merge-layers (start-or-string &optional end-or-name name-or-ids ids-or-object object)
- "Merge specified layers into a new layer.
-
-Calling conventions:
-1. Buffer/string region:
- (tp-merge-layers START END NEW-LAYER-NAME
- \\='(IDX1 LAYER-NAME1 IDX2 ...) OBJECT)
-
-2. Entire string:
- (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.
-
-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)))
- (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.
-
-Calling conventions:
-1. Buffer/string region:
- (tp-flatten-layers START END NAME OBJECT)
-
-2. Entire string:
- (tp-flatten-layers STRING NAME)
-
-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.
-
-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)))
- (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.
-
-IDX-OR-LAYER-NAME-LIST is a list of layer indices (integers) or
-layer names (symbols) specifying which layers to add properties to.
-For indices: 0 means top layer, -1 means bottom layer.
-
-For region form, PLIST is a property list to merge into the specified layers.
-For string form, PROP VAL ... are property-value pairs to merge.
-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)
- (cond
- ;; Entire string form: (tp-add-to-layers ids string prop val ...)
- ((stringp start-or-string)
- (setq obj start-or-string
- start 0
- end (length start-or-string))
- ;; Construct plist from end-or-plist, plist-or-object, and rest
- ;; Always include plist-or-object even if nil, to handle (... 'prop nil)
- (when end-or-plist
- (setq plist (cons end-or-plist (cons plist-or-object rest)))))
- ;; Region form: (tp-add-to-layers ids start end plist object)
- ((numberp start-or-string)
- (setq start start-or-string
- end end-or-plist
- plist plist-or-object
- obj (car rest)))
- (t (error "Invalid layer arguments: %S"
- (cons start-or-string (list end-or-plist plist-or-object)))))
-
- ;; Handle plist wrapped in a list (from region form)
- (when (and (listp plist)
- (not (keywordp (car-safe plist)))
- (listp (car-safe plist)))
- (setq plist (car plist)))
-
- ;; Process each interval
- (tp--stack-map-region
- start end obj
- (lambda (abs-start abs-end stack)
- (let ((modified-stack
- (cl-loop for layer in stack
- for i from 0
- collect
- (if (cl-some
- (lambda (id)
- (let ((found (tp--get-layer-by-idx-or-name
- stack id)))
- (and found (= (car found) i))))
- layer-ids)
- ;; Merge plist into this layer
- (tp--deep-merge-plist layer plist)
- ;; Keep layer unchanged
- layer))))
- (when stack
- (set-text-properties abs-start abs-end
- (tp--stack-build-props modified-stack)
- 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)
- "Add/merge properties to all layers.
-
-This function supports two calling conventions:
-
-1. Buffer/string region:
- (tp-add-to-all-layers START END PLIST OBJECT)
-
-2. Entire string:
- (tp-add-to-all-layers STRING PROP VAL ...)
-
-For region form, PLIST is a property list to merge into all layers.
-For string form, PROP VAL ... are property-value pairs to merge.
-Properties are deeply merged (nested plists are merged, not replaced).
-
-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
- ;; Entire string form: (tp-add-to-all-layers string prop val ...)
- ((stringp start-or-string)
- (setq obj start-or-string
- start 0
- end (length start-or-string))
- ;; Construct plist from end-or-plist, plist-or-object, and rest
- ;; Always include plist-or-object even if nil, to handle (... 'prop nil)
- (when end-or-plist
- (setq plist (cons end-or-plist (cons plist-or-object rest)))))
- ;; Region form: (tp-add-to-all-layers start end plist object)
- ((numberp start-or-string)
- (setq start start-or-string
- end end-or-plist
- plist plist-or-object
- obj (car rest)))
- (t (error "Invalid layer arguments: %S"
- (cons start-or-string (list end-or-plist plist-or-object)))))
-
- ;; Handle plist wrapped in a list (from region form)
- (when (and (listp plist)
- (not (keywordp (car-safe plist)))
- (listp (car-safe plist)))
- (setq plist (car plist)))
-
- ;; Get the maximum layer count in the region to build a list of all indices
- (let ((max-count (tp-layer-count start end obj)))
- (when (> max-count 0)
- (let ((all-indices (cl-loop for i from 0 below max-count collect i)))
- (tp-add-to-layers all-indices start end plist obj))))
- (if (stringp obj) obj nil)))
-
-(provide 'tp-stack)
-;;; tp-stack.el ends here
diff --git a/tp-style.el b/tp-style.el
index cf13c43..b2c9944 100644
--- a/tp-style.el
+++ b/tp-style.el
@@ -1,87 +1,45 @@
-;;; tp-style.el --- Schema-driven text property cascade -*- lexical-binding: t; -*-
+;;; tp-style.el --- Native text property policies -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
-
-;; Author: Geekinney (kinneyzhang666@gmail.com)
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 3 of
-;; the License, or (at your option) any later version.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
-;; Pure property schema, structured selector, and cascade computation for TP.
-;; This module owns no buffers, markers, mounts, or reactive subscriptions.
+;; Native Emacs text-property policies, named direct declarations, and
+;; explicit computed value sources. This module does not implement selectors,
+;; stylesheets, CSS precedence, inheritance, or custom properties.
;;; Code:
(require 'cl-lib)
-(require 'seq)
(require 'tp-core)
-(define-error 'tp-style-error "TP style error")
-(define-error 'tp-invalid-property-schema "Invalid TP property schema"
- 'tp-style-error)
-(define-error 'tp-invalid-style "Invalid TP style declaration"
- 'tp-style-error)
-(define-error 'tp-invalid-selector "Invalid TP selector" 'tp-style-error)
+(define-error 'tp-property-error "TP property error")
+(define-error 'tp-invalid-property-policy
+ "Invalid TP property policy" 'tp-property-error)
+(define-error 'tp-invalid-declaration
+ "Invalid TP direct declaration" 'tp-property-error)
-(cl-defstruct (tp-property-schema
- (:constructor tp--make-property-schema))
- "Schema governing one namespaced cascade property."
- id initial inherits normalizer validator equality merge projector shorthand)
-
-(cl-defstruct (tp-subject (:constructor tp--make-subject))
- "Generic selector subject independent of any rendering consumer."
- type id classes attributes state parent children)
-
-(cl-defstruct (tp-computed-style (:constructor tp--make-computed-style))
- "Computed values, active properties, custom properties, and provenance."
- values custom-properties active-properties provenance)
-
-(cl-defstruct (tp-stylesheet
- (:constructor tp-stylesheet-create ())
- (:conc-name tp--stylesheet-))
- "Independent ordered rule and cascade-layer collection."
- rules layers (source-order 0))
+(cl-defstruct (tp-property-policy
+ (:constructor tp--make-property-policy))
+ "Policy governing one namespaced direct text property."
+ id normalizer validator equality merge projector)
(cl-defstruct (tp--computed-source (:constructor tp--make-computed-source))
function)
-(cl-defstruct (tp--wide (:constructor tp--make-wide)) kind)
-(cl-defstruct (tp--important (:constructor tp--make-important)) value)
-(cl-defstruct (tp--var-ref (:constructor tp--make-var-ref))
- name fallback-present-p fallback)
+(defconst tp--property-policy-option-keys
+ '(:normalizer :validator :equality :merge :projector)
+ "Accepted property policy option keys.")
-(cl-defstruct (tp--style-rule (:constructor tp--make-style-rule))
- selector declarations origin layer layer-rank scope specificity source-order)
+(defvar tp--property-policies (make-hash-table :test #'eq)
+ "Registered property policies by namespaced id.")
-(cl-defstruct (tp--candidate (:constructor tp--make-candidate))
- property value origin important layer layer-rank specificity scope-distance
- source-order declaration-order selector)
+(defvar tp--property-policy-order nil
+ "Property ids in stable registration order.")
-(defconst tp--style-origin-order
- '(default theme package author inline runtime user)
- "Cascade origins ordered from weakest to strongest.")
-
-(defconst tp--wide-kinds '(initial inherit unset revert revert-layer)
- "Supported CSS-wide value kinds.")
-
-(defconst tp--style-all-rules (make-symbol "tp-all-style-rules"))
-(defconst tp--style-invalid (make-symbol "tp-invalid-style-value"))
-(defconst tp--style-absent (make-symbol "tp-absent-style-value"))
-
-(defvar tp--property-schemas (make-hash-table :test #'eq))
-(defvar tp--property-schema-order nil)
-(defvar tp--named-styles (make-hash-table :test #'eq))
-(defvar tp--stylesheet-rules nil)
-(defvar tp--cascade-layers nil)
-(defvar tp--style-source-order 0)
-
-(defconst tp--style-runtime-properties
- '(tp-name tp-layers tp-meta tp-hidden tp-text)
- "Runtime-only properties excluded from declarative text styles.")
+(defvar tp--named-styles (make-hash-table :test #'eq)
+ "Named direct declaration sets.")
(defun tp--canonical-property-id-p (id)
"Return non-nil when ID is a namespaced property symbol."
@@ -91,127 +49,91 @@
(not (string-prefix-p "/" name))
(not (string-suffix-p "/" name))))))
-(defun tp--custom-property-p (property)
- "Return non-nil when PROPERTY names a custom cascade variable."
- (and (symbolp property)
- (string-prefix-p "--" (symbol-name property))))
+(defun tp--declaration-list-p (declarations)
+ "Return non-nil when DECLARATIONS is an even property/value list."
+ (and (listp declarations) (zerop (% (length declarations) 2))))
-(defun tp--callable-option-p (value)
- "Return non-nil when VALUE is nil or callable."
- (or (null value) (functionp value)))
+(defun tp--policy-options-valid-p (options)
+ "Return non-nil when OPTIONS is a supported property policy plist."
+ (and (listp options)
+ (zerop (% (length options) 2))
+ (cl-loop for key in options by #'cddr
+ always (memq key tp--property-policy-option-keys))))
-(defun tp--validate-schema-functions (options)
- "Validate callable fields in schema OPTIONS."
- (dolist (key '(:normalizer :validator :equality :merge
- :projector :shorthand))
- (unless (tp--callable-option-p (plist-get options key))
- (signal 'tp-invalid-property-schema
- (list key (plist-get options key))))))
+(defun tp--policy-option (options key fallback)
+ "Return KEY from OPTIONS when present, otherwise FALLBACK."
+ (if (plist-member options key) (plist-get options key) fallback))
-(defun tp--schema-option (options key default)
- "Return KEY from OPTIONS when present, otherwise DEFAULT."
- (if (plist-member options key) (plist-get options key) default))
+(defun tp--validate-policy-functions (options)
+ "Validate callable property policy fields in OPTIONS."
+ (dolist (key tp--property-policy-option-keys)
+ (let ((value (plist-get options key)))
+ (unless (or (null value) (functionp value))
+ (signal 'tp-invalid-property-policy (list key value))))))
-(defun tp--build-property-schema (id options)
- "Build and validate a property schema for ID from OPTIONS."
- (unless (tp--canonical-property-id-p id)
- (signal 'tp-invalid-property-schema (list :property id)))
- (tp--validate-schema-functions options)
- (tp--make-property-schema
+(defun tp--build-property-policy (id options)
+ "Build and validate a property policy for ID from OPTIONS."
+ (unless (and (tp--canonical-property-id-p id)
+ (tp--policy-options-valid-p options))
+ (signal 'tp-invalid-property-policy (list :property id options)))
+ (tp--validate-policy-functions options)
+ (tp--make-property-policy
:id id
- :initial (plist-get options :initial)
- :inherits (and (plist-get options :inherits) t)
- :normalizer (tp--schema-option options :normalizer #'identity)
- :validator (tp--schema-option options :validator (lambda (_value) t))
- :equality (tp--schema-option options :equality #'equal)
- :merge (tp--schema-option options :merge (lambda (_old new) new))
- :projector (plist-get options :projector)
- :shorthand (plist-get options :shorthand)))
+ :normalizer (tp--policy-option options :normalizer #'identity)
+ :validator (tp--policy-option options :validator (lambda (_value) t))
+ :equality (tp--policy-option options :equality #'equal)
+ :merge (tp--policy-option options :merge (lambda (_old new) new))
+ :projector (plist-get options :projector)))
;;;###autoload
-(defun tp-define-property (id &rest options)
- "Register namespaced property ID using schema OPTIONS.
-OPTIONS support :initial, :inherits, :normalizer, :validator, :equality,
-:merge, :projector, and :shorthand. Registration is atomic."
- (let ((schema (tp--build-property-schema id options)))
- (unless (gethash id tp--property-schemas)
- (setq tp--property-schema-order
- (append tp--property-schema-order (list id))))
- (puthash id schema tp--property-schemas)
- schema))
+(defun tp-define-property-policy (id &rest options)
+ "Atomically register namespaced property ID using policy OPTIONS.
+OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
+ (let ((policy (tp--build-property-policy id options)))
+ (unless (gethash id tp--property-policies)
+ (setq tp--property-policy-order
+ (append tp--property-policy-order (list id))))
+ (puthash id policy tp--property-policies)
+ policy))
-(defun tp-property-schema (id)
- "Return the registered property schema for ID, or nil."
- (gethash id tp--property-schemas))
+(defun tp-property-policy (id)
+ "Return the registered property policy for ID, or nil."
+ (gethash id tp--property-policies))
(defun tp-text-property-id (property)
- "Return the canonical `text/' schema id for Emacs PROPERTY."
+ "Return the canonical `text/' policy id for Emacs PROPERTY."
(unless (symbolp property)
(signal 'wrong-type-argument (list 'symbolp property)))
(intern (format "text/%s" property)))
-(defun tp--text-property-inherits-p (property)
- "Return non-nil when PROPERTY inherits in TP's text domain."
- (memq property '(face font-lock-face)))
-
(defun tp--text-property-merge-function (property)
- "Return the schema merge function for Emacs PROPERTY."
+ "Return the contribution merge function for Emacs PROPERTY."
(if (memq property tp-face-properties)
#'tp--merge-face-values
(lambda (_old new) new)))
(defun tp-register-text-property (property)
- "Register and return a canonical schema for Emacs PROPERTY."
+ "Register and return a direct policy for Emacs PROPERTY."
(let ((id (tp-text-property-id property)))
- (or (tp-property-schema id)
- (tp-define-property
- id :initial nil :inherits (tp--text-property-inherits-p property)
- :equality #'equal :merge (tp--text-property-merge-function property)
+ (or (tp-property-policy id)
+ (tp-define-property-policy
+ id :equality #'equal
+ :merge (tp--text-property-merge-function property)
:projector (lambda (value) (list property value))))))
(defun tp--register-default-text-properties ()
- "Register schemas for TP's known native Emacs properties."
+ "Register policies for TP's known native Emacs properties."
(dolist (property tp--builtin-text-properties)
(tp-register-text-property property)))
(defun tp-text-declarations (properties)
- "Convert raw Emacs PROPERTIES to canonical text declarations."
+ "Convert raw Emacs PROPERTIES to namespaced direct declarations."
(unless (tp--declaration-list-p properties)
- (signal 'tp-invalid-style (list :text-properties properties)))
+ (signal 'tp-invalid-declaration (list :text-properties properties)))
(cl-loop for (property value) on properties by #'cddr
- unless (memq property tp--style-runtime-properties)
- append (list (tp-property-schema-id
+ append (list (tp-property-policy-id
(tp-register-text-property property))
- (copy-tree value))))
-
-(defun tp-style-reset-rules (&optional stylesheet)
- "Clear rules and cascade-layer order in optional STYLESHEET.
-With nil STYLESHEET, reset TP's process-wide default stylesheet."
- (if stylesheet
- (progn
- (unless (tp-stylesheet-p stylesheet)
- (signal 'wrong-type-argument
- (list 'tp-stylesheet-p stylesheet)))
- (setf (tp--stylesheet-rules stylesheet) nil
- (tp--stylesheet-layers stylesheet) nil
- (tp--stylesheet-source-order stylesheet) 0))
- (setq tp--stylesheet-rules nil
- tp--cascade-layers nil
- tp--style-source-order 0)))
-
-(defun tp-style-reset ()
- "Clear TP's schemas, named styles, and default stylesheet state.
-Caller-owned stylesheet instances retain their rules until reset explicitly."
- (clrhash tp--property-schemas)
- (clrhash tp--named-styles)
- (setq tp--property-schema-order nil)
- (tp-style-reset-rules)
- (tp--register-default-text-properties))
-
-(defun tp-undefine-style (name)
- "Remove named style NAME and return nil."
- (remhash name tp--named-styles)
- nil)
+ (tp--copy-property-value value))))
;;;###autoload
(defun tp-computed (function)
@@ -221,753 +143,92 @@ Caller-owned stylesheet instances retain their rules until reset explicitly."
(tp--make-computed-source :function function))
;;;###autoload
-(defun tp-wide-value (kind)
- "Return a tagged CSS-wide value of KIND."
- (unless (memq kind tp--wide-kinds)
- (signal 'tp-invalid-style (list :wide-value kind)))
- (tp--make-wide :kind kind))
-
-;;;###autoload
-(defun tp-important (value)
- "Return VALUE tagged as an important declaration."
- (tp--make-important :value value))
-
-;;;###autoload
-(defun tp-var (name &rest fallback)
- "Return a custom-property reference to NAME with optional FALLBACK."
- (unless (tp--custom-property-p name)
- (signal 'tp-invalid-style (list :custom-property name)))
- (when (> (length fallback) 1)
- (signal 'wrong-number-of-arguments (list 'tp-var (+ 1 (length fallback)))))
- (tp--make-var-ref :name name
- :fallback-present-p (and fallback t)
- :fallback (car fallback)))
-
-(cl-defun tp-subject-create (&key type id classes attributes state parent children)
- "Create a generic cascade subject from TYPE, ID, and metadata.
-CLASSES and STATE are token lists compared with `equal'. ATTRIBUTES is an
-alist. PARENT and CHILDREN must be TP subjects when present."
- (when (and parent (not (tp-subject-p parent)))
- (signal 'wrong-type-argument (list 'tp-subject-p parent)))
- (let ((subject (tp--make-subject
- :type type :id id :classes (copy-sequence classes)
- :attributes (copy-tree attributes)
- :state (copy-sequence state) :parent parent)))
- (tp-subject-set-children subject children)))
-
-(defun tp-subject-set-children (subject children)
- "Replace SUBJECT's CHILDREN and establish their parent links."
- (unless (tp-subject-p subject)
- (signal 'wrong-type-argument (list 'tp-subject-p subject)))
- (dolist (child children)
- (unless (tp-subject-p child)
- (signal 'wrong-type-argument (list 'tp-subject-p child))))
- (dolist (old-child (tp-subject-children subject))
- (when (eq (tp-subject-parent old-child) subject)
- (setf (tp-subject-parent old-child) nil)))
- (setf (tp-subject-children subject) (copy-sequence children))
- (dolist (child children)
- (setf (tp-subject-parent child) subject))
- subject)
-
-(defun tp--subject-attribute-cell (subject name)
- "Return SUBJECT's attribute cell for NAME."
- (assq name (tp-subject-attributes subject)))
-
-(defun tp--subject-previous-siblings (subject)
- "Return SUBJECT's preceding siblings in document order."
- (when-let ((parent (tp-subject-parent subject)))
- (let ((siblings (tp-subject-children parent)) result)
- (while (and siblings (not (eq (car siblings) subject)))
- (push (pop siblings) result))
- (nreverse result))))
-
-(defun tp--selector-form-p (selector kind arity)
- "Return non-nil when SELECTOR is KIND with ARITY arguments."
- (and (consp selector) (eq (car selector) kind)
- (= (length (cdr selector)) arity)))
-
-(defun tp--validate-selector-list (selectors)
- "Validate every selector in SELECTORS."
- (and selectors (cl-every #'tp--selector-valid-p selectors)))
-
-(defun tp--selector-valid-p (selector)
- "Return non-nil when SELECTOR is a valid structured selector."
- (pcase (and (consp selector) (car selector))
- ((or :type :id :class :state)
- (tp--selector-form-p selector (car selector) 1))
- (:attr (memq (length (cdr selector)) '(1 2)))
- ((or :and :is :where :not)
- (tp--validate-selector-list (cdr selector)))
- ((or :descendant :child :adjacent :sibling)
- (and (tp--selector-form-p selector (car selector) 2)
- (tp--validate-selector-list (cdr selector))))
- (:universal (null (cdr selector)))
- (_ nil)))
-
-(defun tp--validate-selector (selector)
- "Signal an error unless SELECTOR is structurally valid."
- (unless (tp--selector-valid-p selector)
- (signal 'tp-invalid-selector (list selector)))
- selector)
-
-(defun tp--selector-match-attribute (selector subject)
- "Return whether attribute SELECTOR matches SUBJECT."
- (let ((cell (tp--subject-attribute-cell subject (nth 1 selector))))
- (and cell
- (or (= (length selector) 2)
- (equal (cdr cell) (nth 2 selector))))))
-
-(defun tp--selector-match-descendant (selector subject)
- "Return whether descendant SELECTOR matches SUBJECT."
- (and (tp-selector-match-p (nth 2 selector) subject)
- (cl-loop for parent = (tp-subject-parent subject)
- then (tp-subject-parent parent)
- while parent
- thereis (tp-selector-match-p (nth 1 selector) parent))))
-
-(defun tp--selector-match-adjacent (selector subject)
- "Return whether adjacent SELECTOR matches SUBJECT."
- (let ((siblings (tp--subject-previous-siblings subject)))
- (and siblings
- (tp-selector-match-p (nth 1 selector) (car (last siblings)))
- (tp-selector-match-p (nth 2 selector) subject))))
-
-(defun tp--selector-match-sibling (selector subject)
- "Return whether sibling SELECTOR matches SUBJECT."
- (and (tp-selector-match-p (nth 2 selector) subject)
- (cl-some (lambda (sibling)
- (tp-selector-match-p (nth 1 selector) sibling))
- (tp--subject-previous-siblings subject))))
-
-(defun tp--selector-match-valid (selector subject)
- "Match already validated SELECTOR against SUBJECT."
- (pcase (car selector)
- (:universal t)
- (:type (equal (nth 1 selector) (tp-subject-type subject)))
- (:id (equal (nth 1 selector) (tp-subject-id subject)))
- (:class (member (nth 1 selector) (tp-subject-classes subject)))
- (:state (member (nth 1 selector) (tp-subject-state subject)))
- (:attr (tp--selector-match-attribute selector subject))
- (:and (cl-every (lambda (item) (tp-selector-match-p item subject))
- (cdr selector)))
- (:is (cl-some (lambda (item) (tp-selector-match-p item subject))
- (cdr selector)))
- (:where (cl-some (lambda (item) (tp-selector-match-p item subject))
- (cdr selector)))
- (:not (not (cl-some (lambda (item) (tp-selector-match-p item subject))
- (cdr selector))))
- (:descendant (tp--selector-match-descendant selector subject))
- (:child (and (tp-selector-match-p (nth 2 selector) subject)
- (when-let ((parent (tp-subject-parent subject)))
- (tp-selector-match-p (nth 1 selector) parent))))
- (:adjacent (tp--selector-match-adjacent selector subject))
- (:sibling (tp--selector-match-sibling selector subject))))
-
-;;;###autoload
-(defun tp-selector-match-p (selector subject)
- "Return non-nil when structured SELECTOR matches SUBJECT."
- (unless (tp-subject-p subject)
- (signal 'wrong-type-argument (list 'tp-subject-p subject)))
- (tp--validate-selector selector)
- (tp--selector-match-valid selector subject))
-
-(defun tp--specificity-add (left right)
- "Add specificity triples LEFT and RIGHT."
- (cl-mapcar #'+ left right))
-
-(defun tp--specificity-max (values)
- "Return the lexicographically greatest specificity in VALUES."
- (cl-reduce (lambda (left right)
- (if (tp--specificity-greater-p left right) left right))
- values :initial-value '(0 0 0)))
-
-(defun tp--specificity-list-sum (selectors)
- "Return the combined specificity of SELECTORS."
- (cl-reduce #'tp--specificity-add selectors
- :key #'tp-selector-specificity
- :initial-value '(0 0 0)))
-
-(defun tp-selector-specificity (selector)
- "Return SELECTOR specificity as an (ID CLASS TYPE) list."
- (tp--validate-selector selector)
- (pcase (car selector)
- (:id '(1 0 0))
- ((or :class :attr :state) '(0 1 0))
- (:type '(0 0 1))
- ((or :universal :where) '(0 0 0))
- (:and (tp--specificity-list-sum (cdr selector)))
- ((or :is :not)
- (tp--specificity-max (mapcar #'tp-selector-specificity
- (cdr selector))))
- ((or :descendant :child :adjacent :sibling)
- (tp--specificity-list-sum (cdr selector)))))
-
-(defun tp--declaration-list-p (declarations)
- "Return non-nil when DECLARATIONS is an even property/value list."
- (and (listp declarations) (zerop (% (length declarations) 2))))
-
-(defun tp--validate-declaration-property (property)
- "Return PROPERTY when it names a registered or custom property."
- (unless (or (tp--custom-property-p property)
- (gethash property tp--property-schemas))
- (signal 'tp-invalid-style (list :unknown-property property)))
- property)
-
-(defun tp--unwrap-important (value)
- "Return VALUE and whether it carries an important tag."
- (if (tp--important-p value)
- (cons (tp--important-value value) t)
- (cons value nil)))
-
-(defun tp--tag-expanded-important (declarations important)
- "Tag expanded DECLARATIONS as IMPORTANT when requested."
- (if (not important)
- declarations
- (cl-loop for (property value) on declarations by #'cddr
- append (list property (tp-important value)))))
-
-(defun tp--expand-declaration (property value)
- "Expand one PROPERTY VALUE declaration into canonical longhands."
- (tp--validate-declaration-property property)
- (let ((schema (gethash property tp--property-schemas)))
- (if-let ((expander (and schema (tp-property-schema-shorthand schema))))
- (pcase-let* ((`(,raw . ,important) (tp--unwrap-important value))
- (expanded (funcall expander raw)))
- (unless (tp--declaration-list-p expanded)
- (signal 'tp-invalid-style (list :shorthand property expanded)))
- (cl-loop for (longhand _value) on expanded by #'cddr
- do (tp--validate-declaration-property longhand)
- when (tp-property-schema-shorthand
- (gethash longhand tp--property-schemas))
- do (signal 'tp-invalid-style
- (list :nested-shorthand property longhand)))
- (tp--tag-expanded-important expanded important))
- (list property value))))
-
-(defun tp--expand-declarations (declarations)
- "Validate and expand DECLARATIONS into canonical longhands."
- (unless (tp--declaration-list-p declarations)
- (signal 'tp-invalid-style (list :declarations declarations)))
- (cl-loop for (property value) on declarations by #'cddr
- append (tp--expand-declaration property value)))
-
-;;;###autoload
-(defun tp-define-style (name declarations)
- "Define named style NAME from DECLARATIONS and return NAME."
- (unless (symbolp name)
- (signal 'tp-invalid-style (list :style-name name)))
- (let ((expanded (tp--expand-declarations declarations)))
- (puthash name (copy-tree expanded) tp--named-styles)
- name))
-
-(defun tp-style-declarations (name)
- "Return a defensive copy of named style NAME declarations."
- (when-let ((declarations (gethash name tp--named-styles)))
- (copy-tree declarations)))
-
-(defun tp--validate-rule-origin (origin)
- "Return ORIGIN when it is a registered cascade origin."
- (unless (memq origin tp--style-origin-order)
- (signal 'tp-invalid-style (list :origin origin)))
- origin)
-
-(defun tp--register-cascade-layer (layer stylesheet)
- "Register LAYER in first-seen order for optional STYLESHEET.
-Return LAYER's zero-based rank, or nil for an unlayered rule."
- (when layer
- (let ((layers (if stylesheet
- (tp--stylesheet-layers stylesheet)
- tp--cascade-layers)))
- (unless (memq layer layers)
- (setq layers (append layers (list layer)))
- (if stylesheet
- (setf (tp--stylesheet-layers stylesheet) layers)
- (setq tp--cascade-layers layers)))
- (cl-position layer layers))))
-
-(defun tp--next-style-source-order (stylesheet)
- "Increment and return source order for optional STYLESHEET."
- (if stylesheet
- (cl-incf (tp--stylesheet-source-order stylesheet))
- (cl-incf tp--style-source-order)))
-
-(defun tp--append-stylesheet-rule (rule stylesheet)
- "Append RULE to optional STYLESHEET and return RULE."
- (if stylesheet
- (setf (tp--stylesheet-rules stylesheet)
- (append (tp--stylesheet-rules stylesheet) (list rule)))
- (setq tp--stylesheet-rules
- (append tp--stylesheet-rules (list rule))))
- rule)
-
-;;;###autoload
-(cl-defun tp-stylesheet-add-rule
- (selector declarations &key (origin 'author) layer scope stylesheet)
- "Add a structured SELECTOR rule with DECLARATIONS.
-ORIGIN defaults to `author'. LAYER is ordered by first appearance. SCOPE,
-when non-nil, is a selector that must match the subject or an ancestor.
-STYLESHEET isolates rules and layer order from TP's default stylesheet."
- (tp--validate-selector selector)
- (when scope (tp--validate-selector scope))
- (tp--validate-rule-origin origin)
- (when (and stylesheet (not (tp-stylesheet-p stylesheet)))
- (signal 'wrong-type-argument (list 'tp-stylesheet-p stylesheet)))
- (let* ((expanded (tp--expand-declarations declarations))
- (layer-rank (tp--register-cascade-layer layer stylesheet))
- (rule (tp--make-style-rule
- :selector (copy-tree selector)
- :declarations (copy-tree expanded)
- :origin origin :layer layer :layer-rank layer-rank
- :scope (copy-tree scope)
- :specificity (tp-selector-specificity selector)
- :source-order (tp--next-style-source-order stylesheet))))
- (tp--append-stylesheet-rule rule stylesheet)))
-
-(defun tp--scope-distance (scope subject)
- "Return distance from SUBJECT to matching SCOPE, or nil."
- (if (null scope)
- most-positive-fixnum
- (cl-loop for current = subject then (tp-subject-parent current)
- for distance from 0
- while current
- when (tp-selector-match-p scope current) return distance)))
-
-(defun tp--rule-matches-p (rule subject)
- "Return non-nil if RULE matches SUBJECT."
- (and (tp-selector-match-p (tp--style-rule-selector rule) subject)
- (numberp (tp--scope-distance (tp--style-rule-scope rule) subject))))
-
-(defun tp--candidate-from-entry (rule property value subject declaration-order)
- "Create a candidate from RULE PROPERTY VALUE for SUBJECT.
-DECLARATION-ORDER is the property's position within RULE."
- (pcase-let ((`(,raw . ,important) (tp--unwrap-important value)))
- (tp--make-candidate
- :property property :value raw
- :origin (tp--style-rule-origin rule) :important important
- :layer (tp--style-rule-layer rule)
- :layer-rank (tp--style-rule-layer-rank rule)
- :specificity (tp--style-rule-specificity rule)
- :scope-distance (tp--scope-distance (tp--style-rule-scope rule) subject)
- :source-order (tp--style-rule-source-order rule)
- :declaration-order declaration-order
- :selector (tp--style-rule-selector rule))))
-
-(defun tp--rule-candidates (rule subject)
- "Return all property candidates from matching RULE for SUBJECT."
- (when (tp--rule-matches-p rule subject)
- (cl-loop for (property value) on (tp--style-rule-declarations rule)
- by #'cddr
- for declaration-order from 0
- collect (tp--candidate-from-entry
- rule property value subject declaration-order))))
-
-(defun tp--inline-candidates (declarations)
- "Return inline candidates for DECLARATIONS."
- (when declarations
- (cl-loop for (property value) on (tp--expand-declarations declarations)
- by #'cddr
- for declaration-order from 0
- collect
- (pcase-let ((`(,raw . ,important) (tp--unwrap-important value)))
- (tp--make-candidate
- :property property :value raw :origin 'inline
- :important important :layer nil :layer-rank nil
- :specificity '(1 0 0)
- :scope-distance most-positive-fixnum
- :source-order (1+ tp--style-source-order)
- :declaration-order declaration-order
- :selector :inline)))))
-
-(defun tp--collect-candidates (subject declarations rules)
- "Collect matching candidates for SUBJECT, DECLARATIONS, and RULES."
- (append
- (cl-loop for rule in rules append (tp--rule-candidates rule subject))
- (tp--inline-candidates declarations)))
-
-(defun tp--specificity-greater-p (left right)
- "Return non-nil when specificity LEFT is greater than RIGHT."
- (catch 'result
- (cl-mapc (lambda (a b)
- (cond ((> a b) (throw 'result t))
- ((< a b) (throw 'result nil))))
- left right)
- nil))
-
-(defun tp--origin-rank (origin)
- "Return precedence rank for ORIGIN."
- (or (cl-position origin tp--style-origin-order) -1))
-
-(defun tp--layer-rank (candidate)
- "Return cascade layer rank for CANDIDATE."
- (let ((layer (tp--candidate-layer candidate))
- (rank (tp--candidate-layer-rank candidate))
- (important (tp--candidate-important candidate)))
- (cond
- ((and important (null layer)) -1000000)
- ((null layer) 1000000)
- (important (- (or rank 0)))
- (t (or rank 0)))))
-
-(defun tp--compare-number (left right)
- "Compare LEFT and RIGHT, returning 1, -1, or 0."
- (cond ((> left right) 1) ((< left right) -1) (t 0)))
-
-(defun tp--candidate-ranks (candidate)
- "Return ordered scalar ranks for CANDIDATE."
- (list (if (tp--candidate-important candidate) 1 0)
- (tp--origin-rank (tp--candidate-origin candidate))
- (tp--layer-rank candidate)))
-
-(defun tp--rank-list-comparison (left right)
- "Compare numeric rank lists LEFT and RIGHT."
- (catch 'comparison
- (cl-mapc (lambda (a b)
- (let ((value (tp--compare-number a b)))
- (unless (zerop value) (throw 'comparison value))))
- left right)
- 0))
-
-(defun tp--candidate-higher-p (left right)
- "Return non-nil when candidate LEFT outranks RIGHT."
- (let ((rank (tp--rank-list-comparison
- (tp--candidate-ranks left) (tp--candidate-ranks right))))
- (cond
- ((not (zerop rank)) (> rank 0))
- ((not (equal (tp--candidate-specificity left)
- (tp--candidate-specificity right)))
- (tp--specificity-greater-p (tp--candidate-specificity left)
- (tp--candidate-specificity right)))
- ((/= (tp--candidate-scope-distance left)
- (tp--candidate-scope-distance right))
- (< (tp--candidate-scope-distance left)
- (tp--candidate-scope-distance right)))
- ((/= (tp--candidate-source-order left)
- (tp--candidate-source-order right))
- (> (tp--candidate-source-order left)
- (tp--candidate-source-order right)))
- (t (> (tp--candidate-declaration-order left)
- (tp--candidate-declaration-order right))))))
-
-(defun tp--group-candidates (candidates)
- "Group CANDIDATES by property in a hash table."
- (let ((table (make-hash-table :test #'eq)))
- (dolist (candidate candidates)
- (let ((property (tp--candidate-property candidate)))
- (puthash property (cons candidate (gethash property table)) table)))
- (maphash (lambda (property values)
- (puthash property
- (sort values #'tp--candidate-higher-p) table))
- table)
- table))
-
-(defun tp--skip-reverted-origin (candidates winner)
- "Remove WINNER's origin and importance group from CANDIDATES."
- (seq-remove
- (lambda (candidate)
- (and (eq (tp--candidate-origin candidate)
- (tp--candidate-origin winner))
- (eq (tp--candidate-important candidate)
- (tp--candidate-important winner))))
- candidates))
-
-(defun tp--skip-reverted-layer (candidates winner)
- "Remove WINNER's layer group from CANDIDATES."
- (seq-remove
- (lambda (candidate)
- (and (eq (tp--candidate-origin candidate)
- (tp--candidate-origin winner))
- (eq (tp--candidate-important candidate)
- (tp--candidate-important winner))
- (eq (tp--candidate-layer candidate)
- (tp--candidate-layer winner))))
- candidates))
-
-(defun tp--evaluate-computed-source (value)
- "Evaluate VALUE only when it is an explicit computed source."
+(defun tp-resolve-value (value &optional _property _subject)
+ "Resolve VALUE only when it is an explicit `tp-computed' source.
+Ordinary function values remain literal. PROPERTY and SUBJECT are accepted
+so this function can be passed directly as a consumer value resolver."
(if (tp--computed-source-p value)
(funcall (tp--computed-source-function value))
value))
-(defun tp--parent-values (parent-style)
- "Return computed values plist from PARENT-STYLE."
- (cond ((tp-computed-style-p parent-style)
- (tp-computed-style-values parent-style))
- ((listp parent-style) parent-style)
- (t nil)))
+(defun tp--validate-direct-property (property)
+ "Return PROPERTY when it has a registered direct policy."
+ (unless (tp-property-policy property)
+ (signal 'tp-invalid-declaration (list :unknown-property property)))
+ property)
-(defun tp--parent-custom-properties (parent-style)
- "Return custom property plist from PARENT-STYLE."
- (when (tp-computed-style-p parent-style)
- (tp-computed-style-custom-properties parent-style)))
-
-(defun tp--parent-property-active-p (parent-style property)
- "Return non-nil when PARENT-STYLE actively contributes PROPERTY."
- (cond
- ((tp-computed-style-p parent-style)
- (memq property (tp-computed-style-active-properties parent-style)))
- ((listp parent-style) (and (plist-member parent-style property) t))))
-
-(defun tp--property-default-value (schema parent-style)
- "Return SCHEMA's inherited or initial value using PARENT-STYLE."
- (let* ((property (tp-property-schema-id schema))
- (parent-values (tp--parent-values parent-style)))
- (if (and (tp-property-schema-inherits schema)
- (plist-member parent-values property))
- (plist-get parent-values property)
- (tp-property-schema-initial schema))))
-
-(defun tp--wide-default-value (wide schema parent-style)
- "Resolve non-revert WIDE value for SCHEMA using PARENT-STYLE."
- (pcase (tp--wide-kind wide)
- ('initial (tp-property-schema-initial schema))
- ('inherit
- (let ((values (tp--parent-values parent-style))
- (property (tp-property-schema-id schema)))
- (if (plist-member values property)
- (plist-get values property)
- (tp-property-schema-initial schema))))
- ('unset (if (tp-property-schema-inherits schema)
- (tp--wide-default-value (tp-wide-value 'inherit)
- schema parent-style)
- (tp-property-schema-initial schema)))))
-
-(defun tp--custom-raw-table (candidate-table parent-style)
- "Build raw custom properties from CANDIDATE-TABLE and PARENT-STYLE."
- (let ((table (make-hash-table :test #'eq)))
- (cl-loop for (property value) on (tp--parent-custom-properties parent-style)
- by #'cddr do (puthash property value table))
- (maphash
- (lambda (property candidates)
- (when (tp--custom-property-p property)
- (let ((selected (tp--select-custom-candidate candidates table)))
- (if (eq selected tp--style-absent)
- (remhash property table)
- (puthash property selected table)))))
- candidate-table)
- table))
-
-(defun tp--select-custom-candidate (candidates inherited-table)
- "Select raw custom value from CANDIDATES and INHERITED-TABLE."
- (let ((remaining candidates) selected done)
- (while (and remaining (not done))
- (let* ((candidate (pop remaining))
- (value (tp--evaluate-computed-source
- (tp--candidate-value candidate))))
- (if (not (tp--wide-p value))
- (setq selected value done t)
- (pcase (tp--wide-kind value)
- ('revert (setq remaining
- (tp--skip-reverted-origin remaining candidate)))
- ('revert-layer (setq remaining
- (tp--skip-reverted-layer remaining candidate)))
- ((or 'inherit 'unset)
- (let ((old (gethash (tp--candidate-property candidate)
- inherited-table tp--style-absent)))
- (setq selected old done t)))
- ('initial (setq selected tp--style-absent done t))))))
- (if done selected
- (gethash (tp--candidate-property (car candidates))
- inherited-table tp--style-absent))))
-
-(defun tp--resolve-var-fallback (reference raw resolved stack)
- "Resolve REFERENCE fallback using RAW, RESOLVED, and STACK."
- (if (tp--var-ref-fallback-present-p reference)
- (tp--resolve-variable-value (tp--var-ref-fallback reference)
- raw resolved stack)
- tp--style-invalid))
-
-(defun tp--resolve-custom-property (name raw resolved stack)
- "Resolve custom property NAME using RAW, RESOLVED, and STACK."
- (let ((memo (gethash name resolved tp--style-absent)))
- (cond
- ((not (eq memo tp--style-absent)) memo)
- ((memq name stack) tp--style-invalid)
- (t
- (let ((value (gethash name raw tp--style-absent)))
- (if (eq value tp--style-absent)
- tp--style-invalid
- (let ((answer (tp--resolve-variable-value
- value raw resolved (cons name stack))))
- (puthash name answer resolved)
- answer)))))))
-
-(defun tp--resolve-variable-value (value raw resolved stack)
- "Resolve custom references in VALUE using RAW, RESOLVED, and STACK."
- (if (not (tp--var-ref-p value))
- value
- (let ((answer (tp--resolve-custom-property
- (tp--var-ref-name value) raw resolved stack)))
- (if (eq answer tp--style-invalid)
- (tp--resolve-var-fallback value raw resolved stack)
- answer))))
-
-(defun tp--resolved-custom-properties (raw)
- "Return resolved custom properties plist from RAW table."
- (let ((resolved (make-hash-table :test #'eq)) names result)
- (maphash
- (lambda (name _value) (push name names)) raw)
- (dolist (name (sort names
- (lambda (left right)
- (string< (symbol-name left) (symbol-name right)))))
- (let ((value (tp--resolve-custom-property name raw resolved nil)))
- (unless (eq value tp--style-invalid)
- (setq result (plist-put result name value)))))
- result))
-
-(defun tp--resolve-property-value (value schema parent-style custom)
- "Resolve VALUE for SCHEMA using PARENT-STYLE and CUSTOM properties."
- (setq value (tp--evaluate-computed-source value))
- (cond
- ((and (tp--wide-p value)
- (memq (tp--wide-kind value) '(initial inherit unset)))
- (tp--wide-default-value value schema parent-style))
- ((tp--var-ref-p value)
- (let ((raw (make-hash-table :test #'eq))
- (resolved (make-hash-table :test #'eq)))
- (cl-loop for (name item) on custom by #'cddr
- do (puthash name item raw))
- (tp--resolve-variable-value value raw resolved nil)))
- (t value)))
-
-(defun tp--normalize-property-value (schema value)
- "Normalize and validate VALUE for SCHEMA, or return invalid sentinel."
- (if (eq value tp--style-invalid)
- value
- (let ((normalized (funcall (tp-property-schema-normalizer schema) value)))
- (if (funcall (tp-property-schema-validator schema) normalized)
- normalized
- tp--style-invalid))))
-
-(defun tp--property-candidate-value (candidate schema parent-style custom)
- "Resolve CANDIDATE for SCHEMA using PARENT-STYLE and CUSTOM."
- (tp--normalize-property-value
- schema
- (tp--resolve-property-value (tp--candidate-value candidate)
- schema parent-style custom)))
-
-(defun tp--candidate-provenance (candidate)
- "Return public provenance plist for CANDIDATE."
- (if (null candidate)
- '(:selector :initial :origin default)
- (list :selector (copy-tree (tp--candidate-selector candidate))
- :origin (tp--candidate-origin candidate)
- :important (and (tp--candidate-important candidate) t)
- :layer (tp--candidate-layer candidate)
- :specificity (copy-sequence (tp--candidate-specificity candidate))
- :scope-distance (tp--candidate-scope-distance candidate)
- :source-order (tp--candidate-source-order candidate)
- :declaration-order (tp--candidate-declaration-order candidate))))
-
-(defun tp--resolve-property-candidates (schema candidates parent-style custom)
- "Resolve SCHEMA from ordered CANDIDATES, PARENT-STYLE, and CUSTOM."
- (let ((remaining candidates) winner value)
- (while (and remaining (null winner))
- (let* ((candidate (pop remaining))
- (raw (tp--evaluate-computed-source
- (tp--candidate-value candidate))))
- (cond
- ((and (tp--wide-p raw) (eq (tp--wide-kind raw) 'revert))
- (setq remaining (tp--skip-reverted-origin remaining candidate)))
- ((and (tp--wide-p raw) (eq (tp--wide-kind raw) 'revert-layer))
- (setq remaining (tp--skip-reverted-layer remaining candidate)))
- (t
- (setf (tp--candidate-value candidate) raw)
- (setq winner candidate
- value (tp--property-candidate-value
- candidate schema parent-style custom))))))
- (unless winner
- (setq value (tp--normalize-property-value
- schema (tp--property-default-value schema parent-style))))
- (when (eq value tp--style-invalid)
- (setq value (tp--normalize-property-value
- schema (tp--property-default-value schema parent-style))))
- (cons value winner)))
-
-(defun tp--compute-property-values (candidate-table parent-style custom provenance-p)
- "Compute values from CANDIDATE-TABLE, PARENT-STYLE, and CUSTOM.
-When PROVENANCE-P is non-nil, also retain winning declaration facts."
- (let (values active provenance)
- (dolist (property tp--property-schema-order)
- (let ((schema (gethash property tp--property-schemas)))
- (unless (tp-property-schema-shorthand schema)
- (pcase-let ((`(,value . ,winner)
- (tp--resolve-property-candidates
- schema (gethash property candidate-table)
- parent-style custom)))
- (setq values (plist-put values property value))
- (when (or winner value
- (and (tp-property-schema-inherits schema)
- (tp--parent-property-active-p
- parent-style property)))
- (push property active))
- (when provenance-p
- (setq provenance
- (plist-put provenance property
- (tp--candidate-provenance winner))))))))
- (list values (nreverse active) provenance)))
+(defun tp--copy-direct-declarations (declarations)
+ "Validate and defensively copy direct DECLARATIONS."
+ (unless (tp--declaration-list-p declarations)
+ (signal 'tp-invalid-declaration (list :declarations declarations)))
+ (cl-loop for (property value) on declarations by #'cddr
+ do (tp--validate-direct-property property)
+ append (list property (tp--copy-property-value value))))
;;;###autoload
-(cl-defun tp-compute-style
- (subject &key declarations (rules tp--style-all-rules)
- parent-style provenance)
- "Compute a deterministic style for SUBJECT.
-DECLARATIONS are inline values. RULES defaults to the registered stylesheet;
-an isolated stylesheet instance selects only its rules, and explicit nil
-disables stylesheet rules. PARENT-STYLE may be a computed style or values
-plist. When PROVENANCE is non-nil, winner metadata is retained."
- (unless (tp-subject-p subject)
- (signal 'wrong-type-argument (list 'tp-subject-p subject)))
- (let* ((active-rules (if (eq rules tp--style-all-rules)
- tp--stylesheet-rules
- (if (tp-stylesheet-p rules)
- (tp--stylesheet-rules rules)
- rules)))
- (candidate-table
- (tp--group-candidates
- (tp--collect-candidates subject declarations active-rules)))
- (raw-custom (tp--custom-raw-table candidate-table parent-style))
- (custom (tp--resolved-custom-properties raw-custom)))
- (pcase-let ((`(,values ,active ,facts)
- (tp--compute-property-values
- candidate-table parent-style custom provenance)))
- (tp--make-computed-style
- :values values :custom-properties custom
- :active-properties active :provenance facts))))
-
-(defun tp--projected-value (schema values active)
- "Project SCHEMA from computed VALUES when its PROPERTY is ACTIVE."
- (when-let ((projector (tp-property-schema-projector schema)))
- (let* ((property (tp-property-schema-id schema))
- (value (plist-get values property)))
- (when (or value (memq property active))
- (funcall projector value)))))
+(defun tp-merge-declarations (&rest declaration-groups)
+ "Merge direct DECLARATION-GROUPS without CSS interpretation.
+Later values replace earlier values for the same registered property. An
+explicit nil remains present and is distinct from an absent declaration."
+ (let (result)
+ (dolist (declarations declaration-groups result)
+ (cl-loop for (property value)
+ on (tp--copy-direct-declarations declarations) by #'cddr
+ do (setq result (plist-put result property value))))))
;;;###autoload
-(defun tp-project-style (style)
- "Project computed STYLE into final direct Emacs text properties."
- (unless (tp-computed-style-p style)
- (signal 'wrong-type-argument (list 'tp-computed-style-p style)))
- (let ((values (tp-computed-style-values style))
- (active (tp-computed-style-active-properties style))
- result)
- (dolist (property tp--property-schema-order)
- (let* ((schema (gethash property tp--property-schemas))
- (projected (and (not (tp-property-schema-shorthand schema))
- (tp--projected-value schema values active))))
- (when projected
- (unless (tp--declaration-list-p projected)
- (signal 'tp-invalid-style (list :projection property projected)))
- (setq result (tp--deep-merge-plist result projected)))))
+(defun tp-define-style (name declarations)
+ "Define named direct style NAME from DECLARATIONS and return NAME."
+ (unless (symbolp name)
+ (signal 'tp-invalid-declaration (list :style-name name)))
+ (puthash name (tp-merge-declarations declarations) tp--named-styles)
+ name)
+
+(defun tp-style-declarations (name)
+ "Return a defensive copy of named direct style NAME declarations."
+ (when-let ((declarations (gethash name tp--named-styles)))
+ (tp--copy-property-value declarations)))
+
+(defun tp-undefine-style (name)
+ "Remove named direct style NAME and return nil."
+ (remhash name tp--named-styles)
+ nil)
+
+(defun tp--normalized-policy-value (policy value)
+ "Resolve, normalize, and validate VALUE using POLICY."
+ (let ((normalized
+ (funcall (tp-property-policy-normalizer policy)
+ (tp-resolve-value value (tp-property-policy-id policy)))))
+ (unless (funcall (tp-property-policy-validator policy) normalized)
+ (signal 'tp-invalid-declaration
+ (list :property (tp-property-policy-id policy)
+ :value normalized)))
+ normalized))
+
+(defun tp--project-policy-value (policy value)
+ "Project VALUE through POLICY into direct Emacs text properties."
+ (when-let ((projector (tp-property-policy-projector policy)))
+ (let ((projected (funcall projector value)))
+ (unless (tp--declaration-list-p projected)
+ (signal 'tp-invalid-declaration
+ (list :projection (tp-property-policy-id policy) projected)))
+ projected)))
+
+(defun tp--project-declarations (declarations)
+ "Project namespaced direct DECLARATIONS into Emacs text properties."
+ (let (result)
+ (cl-loop for (property source)
+ on (tp--copy-direct-declarations declarations) by #'cddr
+ for policy = (tp-property-policy property)
+ for value = (tp--normalized-policy-value policy source)
+ for projected = (tp--project-policy-value policy value)
+ when projected
+ do (setq result (tp--deep-merge-plist result projected)))
result))
(defun tp--project-text-declarations (declarations)
- "Project native text property DECLARATIONS through the style core."
- (tp-project-style
- (tp-compute-style
- (tp-subject-create :type 'text)
- :declarations (tp-text-declarations declarations)
- :rules nil)))
+ "Project native text property DECLARATIONS through direct policies."
+ (tp--project-declarations (tp-text-declarations declarations)))
(tp--register-default-text-properties)
diff --git a/tp-surface.el b/tp-surface.el
index ff0cebd..3fb13cb 100644
--- a/tp-surface.el
+++ b/tp-surface.el
@@ -42,6 +42,9 @@
(define-error 'tp-dead-surface "Dead TP surface" 'tp-surface-error)
(define-error 'tp-invalid-range-anchor "Invalid TP range anchor"
'tp-surface-error)
+(define-error 'tp-producer-buffer-mutation
+ "TP producer mutated a live surface buffer during prepare"
+ 'tp-surface-error)
(define-error 'tp-scope-mismatch "Scoped TP update changed outside its objects"
'tp-surface-error)
@@ -105,10 +108,12 @@
(defvar tp--surfaces (make-hash-table :test #'eql :weakness 'value))
(defvar tp--current-prepare-context nil)
(defvar tp--surface-publishing nil)
+(defvar tp--surface-guarding-prepare nil)
(defvar tp--surface-publication-step-function nil)
(defvar-local tp--buffer-surfaces nil)
(defvar-local tp--surface-character-tick 0)
+(defvar-local tp--surface-before-change-state nil)
(defconst tp--surface-producer-key '(tp/surface . producer))
(defconst tp--surface-extension-key 'tp-surface)
@@ -119,17 +124,6 @@
(zerop (% (length value) 2))
(cl-loop for (key _value) on value by #'cddr always (symbolp key))))
-(defun tp--copy-opaque-value (value)
- "Defensively copy conses, vectors, and strings in VALUE."
- (cond ((functionp value) value)
- ((stringp value) (copy-sequence value))
- ((consp value)
- (cons (tp--copy-opaque-value (car value))
- (tp--copy-opaque-value (cdr value))))
- ((vectorp value)
- (apply #'vector (mapcar #'tp--copy-opaque-value value)))
- (t value)))
-
(defun tp--validate-plan-fields (kind text props children capability)
"Validate plan KIND, TEXT, PROPS, CHILDREN, and CAPABILITY."
(unless kind
@@ -160,17 +154,16 @@
(signal 'wrong-type-argument (list 'tp-surface-plan-p plan)))
(let* ((children (mapcar #'tp--copy-surface-plan
(tp-surface-plan-children plan)))
- (kind (tp--copy-opaque-value (tp-surface-plan-kind plan)))
- (text (and (tp-surface-plan-text plan)
- (copy-sequence (tp-surface-plan-text plan))))
- (props (tp--copy-opaque-value (tp-surface-plan-props plan)))
+ (kind (tp--copy-property-value (tp-surface-plan-kind plan)))
+ (text (tp--copy-property-value (tp-surface-plan-text plan)))
+ (props (tp--copy-property-value (tp-surface-plan-props plan)))
(capability (tp-surface-plan-capability plan)))
(tp--validate-plan-fields kind text props children capability)
(tp--validate-sibling-keys children)
(tp--make-surface-plan
- :key (tp--copy-opaque-value (tp-surface-plan-key plan))
+ :key (tp--copy-property-value (tp-surface-plan-key plan))
:kind kind :text text :props props :children children
- :tags (tp--copy-opaque-value (tp-surface-plan-tags plan))
+ :tags (tp--copy-property-value (tp-surface-plan-tags plan))
:capability capability)))
(cl-defun tp-surface-plan-create
@@ -188,6 +181,20 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
"Return a producer result containing PLAN and opaque CLIENT-STATE."
(tp--make-surface-result (tp--copy-surface-plan plan) client-state))
+(defun tp--property-value-equal-p (property left right)
+ "Return non-nil when PROPERTY values LEFT and RIGHT are policy-equal."
+ (funcall (tp-property-policy-equality (tp-register-text-property property))
+ left right))
+
+(defun tp--plan-props-equal-p (left right)
+ "Return non-nil when text property plists LEFT and RIGHT are policy-equal."
+ (and (= (length left) (length right))
+ (cl-loop for (property value) on left by #'cddr
+ for cell = (plist-member right property)
+ always (and cell
+ (tp--property-value-equal-p
+ property value (cadr cell))))))
+
(defun tp--plan-equal-p (left right)
"Return non-nil when LEFT and RIGHT plans are semantically equal."
(and (equal (tp-surface-plan-key left) (tp-surface-plan-key right))
@@ -197,7 +204,8 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
(if (and (stringp a) (stringp b))
(equal-including-properties a b)
(equal a b)))
- (equal (tp-surface-plan-props left) (tp-surface-plan-props right))
+ (tp--plan-props-equal-p (tp-surface-plan-props left)
+ (tp-surface-plan-props right))
(equal (tp-surface-plan-tags left) (tp-surface-plan-tags right))
(eq (tp-surface-plan-capability left)
(tp-surface-plan-capability right))
@@ -235,7 +243,7 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
position))
(defun tp--object-path-segment (context parent key kind)
- "Return the candidate path segment for KEY and KIND below PARENT."
+ "Return CONTEXT's candidate path segment for KEY and KIND below PARENT."
(if key
(let ((seen (tp--context-child-table context parent)))
(when (gethash key seen)
@@ -262,11 +270,11 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
(signal 'tp-invalid-prepare-context (list context))))
(defun tp--new-candidate-object (context parent key kind path)
- "Create a candidate object in CONTEXT below PARENT at PATH."
+ "Create a candidate object for KEY and KIND in CONTEXT below PARENT at PATH."
(let ((object (tp--make-surface-object
:id (cl-incf tp--object-id-counter)
:surface (tp--context-surface context) :parent parent
- :key (tp--copy-opaque-value key) :kind kind :path path
+ :key (tp--copy-property-value key) :kind kind :path path
:candidate-context context)))
(push object (tp--context-new-objects context))
object))
@@ -313,7 +321,8 @@ remain private so callers cannot mutate TP's publication coordinates."
(lambda (mount)
(list :start (marker-position (tp--surface-mount-start mount))
:end (marker-position (tp--surface-mount-end mount))
- :tags (tp--copy-opaque-value (tp--surface-mount-tags mount))))
+ :tags (tp--copy-property-value
+ (tp--surface-mount-tags mount))))
mounts)))
(defun tp--make-context (surface &optional ephemeral)
@@ -343,7 +352,7 @@ When EPHEMERAL is non-nil, no identity may be promoted."
(signal 'tp-stale-object (list object))))
(defun tp-object-retain (context object)
- "Declare candidate OBJECT live even when it owns no output fragment."
+ "Retain candidate OBJECT in CONTEXT even when it owns no output fragment."
(tp--validate-context-object context object)
(puthash object t (tp--context-retained context))
object)
@@ -362,7 +371,7 @@ marker-backed mounts after publication."
(when (assq object attachments)
(signal 'tp-surface-error (list :duplicate-fragment object fragment)))
(puthash fragment
- (cons (cons object (tp--copy-opaque-value tags)) attachments)
+ (cons (cons object (tp--copy-property-value tags)) attachments)
(tp--context-fragment-attachments context)))
(tp-object-retain context object))
@@ -377,9 +386,11 @@ marker-backed mounts after publication."
(defun tp--plist-overlay (parent child)
"Return a fresh plist where CHILD values override PARENT values."
- (let ((result (copy-tree parent)))
+ (let ((result (tp--copy-property-value parent)))
(cl-loop for (property value) on child by #'cddr
- do (setq result (plist-put result property value)))
+ do (setq result
+ (plist-put result property
+ (tp--copy-property-value value))))
result))
(defun tp--plan-segment (plan position)
@@ -445,7 +456,7 @@ marker-backed mounts after publication."
(nreverse paths)))
(defun tp--validate-context-tree (context plan)
- "Validate CONTEXT's planned, retained, and fragment object paths."
+ "Validate PLAN and CONTEXT's retained and fragment object paths."
(let ((expected (make-hash-table :test #'equal))
(actual (make-hash-table :test #'equal)))
(dolist (path (tp--plan-paths plan)) (puthash path t expected))
@@ -552,7 +563,7 @@ marker-backed mounts after publication."
"Return one content mount spec for OBJECT over RECORD with TAGS."
(list :object object :start (plist-get record :start)
:end (plist-get record :end)
- :tags (tp--copy-opaque-value
+ :tags (tp--copy-property-value
(if tags tags (plist-get record :tags)))))
(defun tp--content-mount-specs (records context)
@@ -579,12 +590,12 @@ marker-backed mounts after publication."
(tp--properties-mount-specs records context)))
(defun tp--ranges-overlap-p (left-start left-end right-start right-end)
- "Return non-nil when the two nonempty half-open ranges overlap."
+ "Return non-nil when LEFT-START..LEFT-END overlaps RIGHT-START..RIGHT-END."
(and (< left-start left-end) (< right-start right-end)
(< left-start right-end) (< right-start left-end)))
(defun tp--candidate-ranges (surface mount-specs rendered)
- "Return absolute candidate ranges for SURFACE."
+ "Return SURFACE ranges described by MOUNT-SPECS and RENDERED."
(if (eq (tp--surface-capability surface) 'content)
(let ((start (marker-position (tp--surface-start surface))))
(list (cons start (+ start (length rendered)))))
@@ -593,7 +604,7 @@ marker-backed mounts after publication."
mount-specs)))
(defun tp--validate-cross-surface-ranges (surface mount-specs rendered)
- "Reject overlapping ownership between SURFACE and other live surfaces."
+ "Reject MOUNT-SPECS and RENDERED when SURFACE overlaps another surface."
(let ((ranges (tp--candidate-ranges surface mount-specs rendered)))
(with-current-buffer (tp--surface-buffer surface)
(dolist (other tp--buffer-surfaces)
@@ -620,6 +631,23 @@ marker-backed mounts after publication."
(tp--ensure-plan-objects context plan)
(tp--producer-result plan surface options)))))
+(defun tp--call-with-prepare-buffer-guard (surface function)
+ "Call FUNCTION while rejecting producer edits to SURFACE's buffer."
+ (let* ((buffer (tp--surface-buffer surface))
+ (before-tick (with-current-buffer buffer
+ (buffer-modified-tick)))
+ (group (tp--prepare-change-group-for-buffers (list buffer)))
+ (tp--surface-guarding-prepare t))
+ (unwind-protect
+ (let ((result (funcall function)))
+ (unless (= before-tick
+ (with-current-buffer buffer
+ (buffer-modified-tick)))
+ (signal 'tp-producer-buffer-mutation
+ (list (tp--surface-id surface))))
+ result)
+ (tp--cancel-change-group-safely group))))
+
(defun tp--normalize-surface-scopes (surface objects)
"Return validated retained OBJECTS owned by SURFACE."
(unless (and (proper-list-p objects) objects)
@@ -720,7 +748,7 @@ When RELATIVE is non-nil, return offsets from the surface start."
(nreverse pairs)))
(defun tp--scope-patches-between-anchors (old new anchors)
- "Return changes between equal outside ANCHORS in OLD and NEW."
+ "Return patches between equal outside ANCHORS in OLD and NEW."
(let ((old-position 0) (new-position 0) patches)
(dolist (anchor (append anchors
(list (list (length old) (length old)
@@ -739,7 +767,8 @@ When RELATIVE is non-nil, return offsets from the surface start."
(nreverse patches)))
(defun tp--scope-replacement-analysis (old new old-ranges new-ranges)
- "Return scoped replacement metadata from OLD to NEW, or nil on mismatch."
+ "Compare OLD-RANGES and NEW-RANGES from OLD to NEW.
+Return scoped replacement metadata, or nil on mismatch."
(let* ((old-outside (tp--complement-ranges (length old) old-ranges))
(new-outside (tp--complement-ranges (length new) new-ranges)))
(when (equal-including-properties
@@ -815,7 +844,11 @@ OPTIONS configure the mount and INITIAL is non-nil for first publication."
(success nil)
result)
(unwind-protect
- (let* ((normalized (tp--prepare-input surface input options context))
+ (let* ((normalized
+ (tp--call-with-prepare-buffer-guard
+ surface
+ (lambda ()
+ (tp--prepare-input surface input options context))))
(plan (car normalized))
(client-state (cdr normalized))
(_capability (tp--validate-plan-capability
@@ -918,7 +951,8 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
:start (marker-position (tp--anchor-start anchor))
:end (marker-position (tp--anchor-end anchor))
:props (plist-get record :props)
- :tags (tp--copy-opaque-value (plist-get record :tags)))
+ :tags (tp--copy-property-value
+ (plist-get record :tags)))
specs))))
(maphash
(lambda (object _anchor)
@@ -940,6 +974,12 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(and (eq (car left) (car right))
(equal (cdr left) (cdr right))))
+(defun tp--property-state-policy-equal-p (property left right)
+ "Return non-nil when PROPERTY states LEFT and RIGHT are policy-equal."
+ (and (eq (car left) (car right))
+ (or (not (car left))
+ (tp--property-value-equal-p property (cdr left) (cdr right)))))
+
(defun tp--ledger-position (marker)
"Return live MARKER position or signal a stale-mount error."
(or (marker-position marker)
@@ -965,24 +1005,31 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
properties))
(defun tp--property-boundaries (buffer mount-specs surface properties)
- "Return sorted candidate interval boundaries in BUFFER."
- (let (boundaries)
+ "Return sorted interval boundaries in BUFFER.
+MOUNT-SPECS and SURFACE provide ranges for PROPERTIES."
+ (let (boundaries intervals)
(dolist (spec mount-specs)
- (push (plist-get spec :start) boundaries)
- (push (plist-get spec :end) boundaries))
+ (let ((start (plist-get spec :start))
+ (end (plist-get spec :end)))
+ (push start boundaries)
+ (push end boundaries)
+ (push (cons start end) intervals)))
(dolist (entry (tp--surface-ledger surface))
- (push (tp--ledger-position (tp--property-ledger-start entry)) boundaries)
- (push (tp--ledger-position (tp--property-ledger-end entry)) boundaries))
+ (let ((start (tp--ledger-position (tp--property-ledger-start entry)))
+ (end (tp--ledger-position (tp--property-ledger-end entry))))
+ (push start boundaries)
+ (push end boundaries)
+ (push (cons start end) intervals)))
(setq boundaries (sort (delete-dups boundaries) #'<))
- (when boundaries
- (let ((minimum (car boundaries)) (maximum (car (last boundaries))))
- (with-current-buffer buffer
- (dolist (property properties)
- (let ((position minimum))
- (while (< position maximum)
- (setq position (next-single-property-change
- position property buffer maximum))
- (push position boundaries)))))))
+ (with-current-buffer buffer
+ (dolist (interval (tp--coalesce-ranges intervals))
+ (dolist (property properties)
+ (let ((position (car interval))
+ (maximum (cdr interval)))
+ (while (< position maximum)
+ (setq position (next-single-property-change
+ position property buffer maximum))
+ (push position boundaries))))))
(sort (delete-dups boundaries) #'<)))
(defun tp--covering-contributions (mount-specs start end property)
@@ -997,7 +1044,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(defun tp--merge-property-contributions (baseline contributions property)
"Merge PROPERTY CONTRIBUTIONS over BASELINE property state."
(let ((state baseline)
- (merge (tp-property-schema-merge
+ (merge (tp-property-policy-merge
(tp-register-text-property property))))
(dolist (spec contributions)
(let ((value (plist-get (plist-get spec :props) property)))
@@ -1023,14 +1070,14 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(defun tp--property-segment-result
(surface mount-specs start end property)
- "Prepare one PROPERTY segment from START to END for SURFACE."
+ "Prepare one PROPERTY segment from START to END for SURFACE and MOUNT-SPECS."
(let* ((buffer (tp--surface-buffer surface))
(current (tp--property-state-at buffer start property))
(old (tp--old-ledger-at surface start property))
(contributions
(tp--covering-contributions mount-specs start end property)))
- (when (and old (not (tp--property-state-equal-p
- current (tp--ledger-published-state old))))
+ (when (and old (not (tp--property-state-policy-equal-p
+ property current (tp--ledger-published-state old))))
(signal 'tp-property-conflict
(list (tp--surface-id surface) start end property current)))
(let* ((baseline (tp--ledger-baseline-state old current))
@@ -1040,7 +1087,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(mapcar (lambda (spec) (plist-get spec :anchor))
contributions))))
(list :operation
- (unless (tp--property-state-equal-p current target)
+ (unless (tp--property-state-policy-equal-p property current target)
(list :start start :end end :property property
:present (car target) :value (cdr target)))
:ledger
@@ -1052,7 +1099,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
:published-value (cdr target) :anchors anchors))))))
(defun tp--prepare-property-ledger (surface mount-specs)
- "Return candidate ledger specs and property operations for SURFACE."
+ "Return ledger specs and property operations for SURFACE and MOUNT-SPECS."
(let* ((buffer (tp--surface-buffer surface))
(properties (tp--contribution-properties mount-specs surface))
(boundaries (tp--property-boundaries
@@ -1117,7 +1164,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(cons start end)))
(defun tp--create-surface (buffer capability options)
- "Create an unmounted surface candidate for BUFFER."
+ "Create an unmounted BUFFER surface with CAPABILITY and OPTIONS."
(unless (memq capability '(content properties))
(signal 'tp-capability-error (list capability)))
(when (buffer-base-buffer buffer)
@@ -1131,14 +1178,15 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(tp--make-surface
:id (cl-incf tp--surface-id-counter) :buffer buffer
:capability capability :start (copy-marker (car range) nil)
- :end (copy-marker (cdr range) t) :options (copy-tree options)
+ :end (copy-marker (cdr range) t)
+ :options (tp--copy-property-value options)
:objects (make-hash-table :test #'equal) :mounts nil :index nil
:mount-index (make-hash-table :test #'eq)
:ledger nil :revision 0 :live nil :stale nil
:observers (copy-sequence (plist-get options :observers)))))
(defun tp--surface-compute-function (surface input options initial)
- "Return the producer binding function for SURFACE and INPUT."
+ "Return SURFACE's producer binding for INPUT, OPTIONS, and INITIAL state."
(lambda ()
(tp--prepare-surface
surface input options (and initial (not (tp--surface-live surface))))))
@@ -1242,37 +1290,63 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
surface objects (list :on-mismatch on-mismatch)))))
(tp-surface-report surface))
-(defun tp--edit-touches-span-p (beg old-length start end)
- "Return non-nil when an external edit at BEG touches START..END."
- (if (zerop old-length)
+(defun tp--edit-touches-span-p (beg edit-end start end)
+ "Return non-nil when BEG..EDIT-END touches the old START..END span."
+ (if (= beg edit-end)
(and (> beg start) (< beg end))
- (and (>= beg start) (< beg end))))
+ (and (< beg end) (> edit-end start))))
-(defun tp--mark-anchor-after-edit (anchor beg old-length)
- "Apply ANCHOR's boundary policy after an edit at BEG."
- (let ((start (marker-position (tp--anchor-start anchor)))
- (end (marker-position (tp--anchor-end anchor))))
- (when (and start end (tp--edit-touches-span-p beg old-length start end))
+(defun tp--surface-before-change (beg end)
+ "Capture retained ranges before a BUFFER edit from BEG to END."
+ (setq tp--surface-before-change-state nil)
+ (unless (or tp--surface-publishing tp--surface-guarding-prepare)
+ (let ((anchors (make-hash-table :test #'eq)) content anchor-ranges)
+ (dolist (surface tp--buffer-surfaces)
+ (when (tp-surface-live-p surface)
+ (if (eq (tp--surface-capability surface) 'content)
+ (pcase-let ((`(,start . ,finish) (tp--surface-range surface)))
+ (push (list surface start finish) content))
+ (dolist (mount (tp--surface-mounts surface))
+ (when-let ((anchor (tp--surface-mount-anchor mount)))
+ (unless (gethash anchor anchors)
+ (puthash anchor t anchors)
+ (push (list anchor
+ (marker-position (tp--anchor-start anchor))
+ (marker-position (tp--anchor-end anchor)))
+ anchor-ranges)))))))
+ (setq tp--surface-before-change-state
+ (list :beg beg :end end
+ :content content :anchors anchor-ranges)))))
+
+(defun tp--mark-anchor-from-old-range (entry beg end)
+ "Apply ENTRY anchor policy for an old edit range BEG..END."
+ (pcase-let ((`(,anchor ,start ,finish) entry))
+ (when (and start finish
+ (tp--edit-touches-span-p beg end start finish))
(pcase (tp--anchor-boundary-policy anchor)
('shorten nil)
('remove (setf (tp--anchor-stale anchor) 'remove))
(_ (setf (tp--anchor-stale anchor) t))))))
-(defun tp--surface-after-change (beg _end old-length)
- "Maintain retained mount staleness after a host edit at BEG."
+(defun tp--surface-after-change (_beg _end _old-length)
+ "Maintain mount staleness after a host text edit."
(let* ((tick (buffer-chars-modified-tick))
- (character-change (/= tick tp--surface-character-tick)))
+ (character-change (/= tick tp--surface-character-tick))
+ (state tp--surface-before-change-state))
(setq tp--surface-character-tick tick)
- (when (and character-change (not tp--surface-publishing))
- (dolist (surface tp--buffer-surfaces)
- (when (tp-surface-live-p surface)
- (if (eq (tp--surface-capability surface) 'content)
- (pcase-let ((`(,start . ,end) (tp--surface-range surface)))
- (when (tp--edit-touches-span-p beg old-length start end)
- (setf (tp--surface-stale surface) t)))
- (dolist (mount (tp--surface-mounts surface))
- (when-let ((anchor (tp--surface-mount-anchor mount)))
- (tp--mark-anchor-after-edit anchor beg old-length)))))))))
+ (setq tp--surface-before-change-state nil)
+ (when (and character-change state
+ (not tp--surface-publishing)
+ (not tp--surface-guarding-prepare))
+ (let ((old-beg (plist-get state :beg))
+ (old-end (plist-get state :end)))
+ (dolist (entry (plist-get state :content))
+ (pcase-let ((`(,surface ,start ,end) entry))
+ (when (and (tp-surface-live-p surface)
+ (tp--edit-touches-span-p old-beg old-end start end))
+ (setf (tp--surface-stale surface) t))))
+ (dolist (entry (plist-get state :anchors))
+ (tp--mark-anchor-from-old-range entry old-beg old-end))))))
(defun tp--surface-buffer-killed ()
"Dispose every retained surface owned by the current buffer."
@@ -1286,6 +1360,7 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
(with-current-buffer (tp--surface-buffer surface)
(cl-pushnew surface tp--buffer-surfaces :test #'eq)
(setq tp--surface-character-tick (buffer-chars-modified-tick))
+ (add-hook 'before-change-functions #'tp--surface-before-change nil t)
(add-hook 'after-change-functions #'tp--surface-after-change nil t)
(add-hook 'kill-buffer-hook #'tp--surface-buffer-killed nil t)))
@@ -1317,7 +1392,8 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
(defun tp--set-surface-scope-request (surface objects options)
"Set SURFACE's one-shot scope request to OBJECTS and OPTIONS."
(puthash surface
- (list :objects (copy-sequence objects) :options (copy-tree options))
+ (list :objects (copy-sequence objects)
+ :options (tp--copy-property-value options))
(tp--surface-scope-table t)))
(defun tp--surface-prepared-table ()
@@ -1376,7 +1452,7 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
(tp--prepared-surface-rendered prepared))))))))
(defun tp--prepared-changed-p (prepared)
- "Return non-nil when PREPARED changes its committed surface."
+ "Return non-nil when PREPARED differs from its committed surface."
(let ((surface (tp--prepared-surface-surface prepared)))
(or (tp--prepared-surface-initial prepared)
(not (tp--plan-equal-p (tp--surface-plan surface)
@@ -1440,10 +1516,12 @@ OPTIONS accepts `:on-mismatch'. Its default, `error', signals
(if (equal old new) 0 1)))
(defun tp--string-property-run-diff-p (buffer start rendered from to)
- "Return non-nil when BUFFER differs from RENDERED on FROM..TO."
+ "Return non-nil when BUFFER at START differs from RENDERED on FROM..TO."
(cl-loop for offset from from below to
- thereis (not (equal (text-properties-at (+ start offset) buffer)
- (text-properties-at offset rendered)))))
+ thereis
+ (not (tp--plan-props-equal-p
+ (text-properties-at (+ start offset) buffer)
+ (text-properties-at offset rendered)))))
(defun tp--content-property-operations-in-range
(buffer start rendered from to)
@@ -1590,7 +1668,7 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set."
table))
(defun tp--surface-report-value (prepared text-ops property-ops)
- "Build PREPARED's generic commit report."
+ "Build PREPARED's report from TEXT-OPS and PROPERTY-OPS."
(let* ((surface (tp--prepared-surface-surface prepared))
(old-revision (tp--surface-revision surface))
(new-revision (1+ old-revision))
@@ -1874,6 +1952,7 @@ Return the number of text operations."
(with-current-buffer (tp--surface-buffer surface)
(setq tp--buffer-surfaces (delq surface tp--buffer-surfaces))
(unless tp--buffer-surfaces
+ (remove-hook 'before-change-functions #'tp--surface-before-change t)
(remove-hook 'after-change-functions #'tp--surface-after-change t)
(remove-hook 'kill-buffer-hook #'tp--surface-buffer-killed t)))))
@@ -2053,7 +2132,7 @@ Return the number of text operations."
(defun tp--record-observer-error (surface observer failure)
"Record OBSERVER FAILURE in SURFACE's latest report."
- (let ((report (copy-tree (tp--surface-report surface))))
+ (let ((report (tp--copy-property-value (tp--surface-report surface))))
(setq report
(plist-put report :observer-errors
(append (plist-get report :observer-errors)
@@ -2075,7 +2154,7 @@ Return the number of text operations."
(lambda () (tp--run-surface-observers surface observers report)))))
(defun tp--surface-commit-transaction ()
- "Accept buffer changes and finalize every transaction surface."
+ "Commit buffer edits and finalize every transaction surface."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let ((group (gethash 'change-group state)))
(accept-change-group group))
@@ -2162,7 +2241,7 @@ Return the number of text operations."
anchor)
(defun tp--unmount-ledger-segments (surface entry)
- "Return restoration operations and conflicts for one ledger ENTRY."
+ "Return SURFACE restoration operations and conflicts for ledger ENTRY."
(let* ((buffer (tp--surface-buffer surface))
(start (tp--ledger-position (tp--property-ledger-start entry)))
(end (tp--ledger-position (tp--property-ledger-end entry)))
@@ -2322,7 +2401,7 @@ owns the property; conflicting host values are preserved and reported."
"Return a defensive copy of SURFACE's latest generic commit report."
(unless (tp-surface-p surface)
(signal 'wrong-type-argument (list 'tp-surface-p surface)))
- (copy-tree (tp--surface-report surface)))
+ (tp--copy-property-value (tp--surface-report surface)))
(defun tp-surface-inspect (surface)
"Return read-only retained diagnostics for SURFACE."
diff --git a/tp.el b/tp.el
index 70b26e7..341e51a 100644
--- a/tp.el
+++ b/tp.el
@@ -1,11 +1,11 @@
-;;; tp.el --- Text Properties manipulation library for Emacs Lisp -*- lexical-binding: t -*-
+;;; tp.el --- Retained reactive text runtime -*- lexical-binding: t -*-
;; Copyright (C) 2024-2026 Geekinney
-;; Version: 0.3.0
+;; Version: 1.0.0
;; Keywords: convenience text-properties
;; Author: Geekinney (kinneyzhang666@gmail.com)
-;; Package-Requires: ((emacs "28.1") (dash "2.19.1"))
+;; Package-Requires: ((emacs "28.1"))
;; URL: https://github.com/Kinneyzhang/tp
;; This program is free software; you can redistribute it and/or
@@ -15,28 +15,26 @@
;;; Commentary:
-;; tp.el is a comprehensive text property manipulation library.
+;; TP projects declarative properties, reactive data, and retained text
+;; objects onto Emacs strings and buffers.
;;
;; It is organized as a stack of modules, each depending only on the
;; ones before it:
;;
-;; tp-core.el Foundation: intervals, plist/face merge engine,
-;; debug logging, pure $var utilities.
-;; tp-style.el Property schemas, structured selectors, cascade,
-;; custom properties, and explicit computed values.
-;; tp-reactive.el Exact signals, bindings, transactions, scoped variable
-;; adapters, plus temporary legacy layer watcher state.
+;; tp-core.el Foundation: ranges, intervals, plist/face merge,
+;; canonical requests/results, and debug logging.
+;; tp-style.el Native property policies, contribution composition,
+;; named declarations, and explicit computed values.
+;; tp-reactive.el Exact signals, bindings, transactions, and scoped variable
+;; adapters.
;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes,
;; and atomic buffer publication.
-;; tp-layer.el Layer registry: `define-tp', `define-tps',
-;; layer/group resolution and expansion.
+;; tp-layer.el Named declaration recipes: `define-tp', `define-tps',
+;; and direct property expansion.
;; tp-ops.el Core primitives: `tp-set', `tp-reset', `tp-add',
;; `tp-get', `tp-at', `tp-remove', `tp-clear'.
;; tp-search.el Pattern matching (`tp-match-*', `tp-regexp-*') and
;; property search/navigation (`tp-search', ...).
-;; tp-render.el Reactive re-rendering engine (installs itself into
-;; tp-reactive and tp-ops).
-;; tp-stack.el Layer stack operations: push/pop/move/merge/...
;; tp-query.el Native lookup/change wrappers and mutation policy.
;; tp-palette.el Color palette data (light/dark aware).
;; tp-builtins.el Built-in layers (tp-fg, tp-link, tp-action, ...)
@@ -60,8 +58,6 @@
(require 'tp-layer)
(require 'tp-ops)
(require 'tp-search)
-(require 'tp-render)
-(require 'tp-stack)
(require 'tp-query)
(require 'tp-palette)
(require 'tp-builtins)