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

Merge refactor/modular-architecture: 0.2.0 modular split, bug fixes, docs

Browse Source 
Splits tp.el into nine layered modules behind the tp.el umbrella,
fixes ~43 confirmed bugs across every subsystem, adds tp-member,
grows the ERT suite from 280 to 443 tests plus 63 executable README
doctests, and aligns CHANGELOG, bilingual READMEs, and docs/ with the
actual behavior.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
Kinneyzhang 2026-07-26 21:19:05 +08:00
commit 2c5ce6c27b
34 changed files with 9758 additions and 6100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
.DS_Store vendored
View File

Binary file not shown.

10
.gitignore vendored
View File

@ -7,3 +7,13 @@ dash.el
# Backup files
*~
\#*\#
# macOS
.DS_Store
# Syncthing conflict files
*.sync-conflict-*
.syncthing.*
# Claude worktrees
.claude/

BIN
.syncthing.README_CN.sync-conflict-20260318-160704-P3OUM7A.md.tmp
View File

Binary file not shown.

202
CHANGELOG.md Normal file
View File

@ -0,0 +1,202 @@
# Changelog
All notable changes to the tp library are documented here.
## 0.2.0 (2026-07-26)
### Architecture
- **tp.el was split into layered modules.** `(require 'tp)` still loads
everything; nothing changes for users. Each module depends only on
the ones before it, and the byte compiler enforces the order:
| Module | Responsibility |
|---|---|
| `tp-core.el` | Intervals, plist/face merge engine, debug logging, `$var` utilities |
| `tp-reactive.el` | Reactive dependency registry, variable watchers, batching queue |
| `tp-layer.el` | `define-tp` / `define-tps`, layer registry and resolution |
| `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` |
| `tp-search.el` | `tp-match-*`, `tp-regexp-*`, `tp-search`, navigation |
| `tp-render.el` | Reactive re-rendering engine (installs itself into lower modules) |
| `tp-stack.el` | Layer stack operations (push/pop/move/merge/flatten/...) |
| `tp-palette.el` | Light/dark color palette data |
| `tp-builtins.el` | Built-in layers, palette gallery, display-buffer helpers |
- The library now byte-compiles cleanly (previously `define-tp`
macro-expansion failed at compile time).
- New shared engine `tp--map-intervals`: a clipping interval walker that
underlies region operations; property edits can no longer bleed
outside the requested region.
- New public constant `tp-face-properties` (`'(face font-lock-face
mouse-face)`): the property family that gets face-aware merging.
### Fixed
Core operations:
- `(require 'text-property-search)` was missing; `tp-backward` signaled
`void-function` in batch/fresh sessions.
- `tp-remove` string form silently dropped the 3rd and later properties.
- String-form removal helpers sampled properties at position 0 and
smeared them across the range, destroying neighboring intervals; they
now work per-interval.
- `tp-clear` computed default bounds from the current buffer even when
clearing a string (silent no-op or range error).
- `(tp-get STRING START END ...)` returned nil silently; it now behaves
like the buffer region form.
- `tp-intervals` returned unclipped intervals (including negative
offsets); it now clips to `[START, END)`.
- Region-form calls with flat prop/val arguments — `(tp-set 1 4 'face
'bold)` — silently discarded the value and failed later; they now
signal a clear error immediately.
- Face-family prepend semantics in `tp-add` covered only `face`; they
now cover `font-lock-face` and `mouse-face` too.
- `tp--parse-face-list` no longer invents a `(:key nil)` pair for a
trailing bare keyword.
Built-ins and palette:
- Emacs 28.1 compatibility restored (`plistp` is Emacs 29+; a compat
shim is used, and `subr-x` is required where needed).
- `tp-pop-to-buffer` / `tp-switch-to-buffer` no longer bind `q` in the
shared major-mode keymap (a buffer-local minor-mode keymap is used)
and no longer capture a `buffer` variable from the caller.
- `tp-link` resolved its palette color once at load time; the color is
now resolved at application time, so theme switches are honored.
- `define-tp-palette` no longer generates per-palette defvars;
`tp-palette-alist` is the single source of truth and palette
redefinition takes effect immediately.
- `tp-headline` emitted invalid `(:height nil)` for integer heights.
- `tp-space` now produces the documented pixel `(space :width (N))`
spec.
- `tp-parse-color` accepts one-sided cons colors like `("white" . nil)`.
Layer definitions (tp-layer):
- Parameterized `define-tps` groups: the documented format returned nil
props via `tp-group-props-with-arg`; all documented element shapes now
resolve correctly.
- Cyclic layer references signal a clear error naming the cycle
(previously crashed with `excessive-lisp-nesting`); diamond-shaped
reuse is not a false positive.
- `define-tp` errors at macro-expansion time when extra body forms are
present (previously silently discarded all but the first).
- `$`-symbols in parameterized layer bodies resolve to their variables'
current values at evaluation time (previously leaked literally into
the output props); parameterized layers remain non-reactive, and the
choice is documented.
- `tp-layer-props` / `tp-group-props` and their `-with-arg` variants
return copies; mutating a returned plist can no longer corrupt the
registry.
- `:transform` in `define-tps` group elements is honored (was silently
dropped).
- Group redefinition and `tp-undefine-group` clean up the layers the
group generated, including their reactive deps and transforms
(previously orphaned).
- The group-element parser errors on unknown keywords instead of
advancing by one and re-reading a value as a key.
- Anonymous reactive layers are interned: an `equal` `$var` props spec
reuses the existing registry entry instead of minting a new one on
every `tp-set` (unbounded leak fixed).
Layer stacks (tp-stack):
- All stack mutators were rewritten onto a shared clipped region walker;
region ops no longer alter text outside `[START, END)`, and
`tp-put-layer` is region-local instead of switching behavior on
whole-object emptiness.
- The documented inline-plist spec (`(face bold ...)`) and
list-of-layer-names spec (`'(layer-a layer-b)`) for `tp-put-layer`
work (previously errored), handled at the call site.
- `tp-region-layer-props` no longer double-offsets string positions.
- `tp-merge-layers` / `tp-flatten-layers` no longer drop explicitly-nil
values (presence is checked with `plist-member`).
- Single-layer stacks no longer carry a garbage `(tp-layers nil)`
property, and its absence is tolerated everywhere.
- `tp-layer-top` respects the requested region instead of reading only
the first interval.
Search and navigation (tp-search):
- `tp-backward` buffer paths passed no predicate to
`text-property-search-backward`, so matching was inverted relative to
`tp-forward`; backward now mirrors forward's equal-matching
semantics. The legacy test that codified the inverted behavior
(`tp-test-backward`) was updated to the symmetric contract.
- Empty and zero-width patterns no longer loop forever in the
match/regexp apply engines.
- Length-changing replacements work in buffers in `tp-forward-do` /
`tp-backward-do` / `tp-search-map` (previously signaled
`args-out-of-range` via `store-substring`). On strings — which cannot
change length in place — a length-changing replacement signals a
clear error instead of silently truncating or leaving residue;
same-length string replacements are unchanged.
- `tp-search-map` with a non-current buffer OBJECT operates on that
buffer (previously read and mutated the current buffer) and no longer
corrupts buffers on length-changing replacements.
- `tp-match-add` buffer path uses face-family-aware merging like the
string path, so existing faces are preserved.
- `tp-search-map` can remove properties on strings (nil-props ranges
were previously skipped).
- The triplicated ~38-line replacement lambda was extracted into one
shared helper.
- `tp-forward-do` / `tp-backward-do` shortfall is now all-or-nothing on
both paths: TIMES targets the TIMES-th match specifically, so when
fewer matches exist nothing is applied and the available count is
returned. String paths previously acted on the last available match —
the wrong target; the two legacy tests codifying that
(`tp-test-forward-do-on-string-with-range` and its backward twin)
were updated.
Reactive rendering (tp-reactive / tp-render):
- Sub-region `tp-text` on a string no longer discards the rest of the
string.
- Computed-variable updates deep-merge resolved props with the layer
definition, preserving sibling static attributes.
- Reactive refresh replaces the re-rendered layer's own property keys
instead of accumulating (bold→italic no longer yields
`(italic bold)`), while preserving other layers' properties.
- `setq-local` re-renders the buffer without leaking buffer-local
values into the global layer definition.
- Reactive `tp-text` replacement preserves unrelated existing
properties.
- Computed values of nil propagate (nil was conflated with the error
sentinel).
- Variable-watcher reentrancy: nested `set` calls inside the update
path queue their re-render through the batch queue instead of
recursing.
- Batched updates union their WHERE and tp-text flags at flush time
instead of freezing the first change's.
- Reactive strings keep per-interval props on re-render (previously
only position-0 props survived and were smeared).
- `:transform` applies on the first render too, not only on updates.
Test infrastructure:
- The test fixture now tears down with `unwind-protect` and resets all
registries including `tp-layer-transforms` (previously leaked across
tests); the suite passes in randomized order.
- `tp-tests.el` header and `provide` renamed to match its file name.
### Added
- `tp-member`: like `tp-at`, but distinguishes "property present with
value nil" from "property absent" (plist-member-style result).
- `Makefile` with `test` / `doctest` / `compile` / `clean` targets.
- `tp-doctest.el`: executable documentation tests — 63 assertions
reproducing README examples and comparing against their exact
documented outputs (`make doctest`).
- Per-module regression test suites: `tp-core-tests.el`,
`tp-ops-tests.el`, `tp-builtins-tests.el`, `tp-layer-tests.el`,
`tp-stack-tests.el`, `tp-search-tests.el`, `tp-render-tests.el` —
the combined suite grew from 280 to 439 tests.
### Changed
- License clarified to GPLv3+ in file headers, matching the shipped
LICENSE file (headers previously said v2+).
## 0.1.0
Initial release (monolithic tp.el).

33
Makefile Normal file
View File

@ -0,0 +1,33 @@
# Makefile for the tp library.
#
# Usage:
# make test # run all ERT test suites
# make doctest # execute README examples against the code
# make compile # byte-compile all modules
# make clean # remove compiled files
#
# If dash.el is not on the default load-path, point LOAD_EXTRA at it:
# make test LOAD_EXTRA="-L ~/.emacs.d/elpa/dash-20240510.1327"
EMACS ?= emacs
LOAD_EXTRA ?=
LOADPATH = -L . $(LOAD_EXTRA)
SRC = tp-core.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \
tp-render.el tp-stack.el tp-palette.el tp-builtins.el tp.el
TESTS = $(wildcard *-tests.el)
.PHONY: test doctest compile clean
test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
-f ert-run-tests-batch-and-exit
doctest:
$(EMACS) -Q --batch $(LOADPATH) -l tp-doctest.el
compile: clean
$(EMACS) -Q --batch $(LOADPATH) -f batch-byte-compile $(SRC)
clean:
rm -f *.elc

461
README.md
View File

@ -18,6 +18,7 @@
## Table of Contents
- [Quick Start](#quick-start)
- [Overview](#overview)
- [Core Innovations](#core-innovations)
- [Features](#features)
@ -38,6 +39,7 @@
- [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)
@ -91,6 +93,8 @@
- [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)
@ -115,10 +119,45 @@
---
## 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-reactive`, `tp-layer`, `tp-ops`, `tp-search`, `tp-render`, `tp-stack`, `tp-palette`, `tp-builtins`) behind the umbrella file `tp.el` — `(require 'tp)` still loads everything, so nothing changes for users. See [Installation](#installation) for the module map.
### Core Innovations
1. **Unified API Parameter Conventions**: All functions support multiple flexible calling patterns, working seamlessly with both strings and buffers
@ -168,13 +207,13 @@ Native APIs only have simple set and get. tp.el provides three clear operation s
- ✅ **Path-style Access**: Access deeply nested property values through path syntax
```elisp
;; Get nested properties
(tp-get str 'face :underline :style) ; => wave
;; 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))
;; => ((:color "green" :style wave))
;; => ((0 5 (:color "green" :style wave)))
```
- ✅ **Sub-property Deletion**: Precisely remove specific keys from nested properties
```elisp
@ -191,7 +230,8 @@ Native APIs only have simple set and get. tp.el provides three clear operation s
'face 'bold
'face '(:background "green")
'face '(:foreground "red"))
;; Result: face is ((:background "green" :foreground "red") bold)
;; 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"
@ -275,12 +315,13 @@ Native APIs require manual searching and looping. tp.el provides convenient patt
(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")) ;; With initial values
: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)))))
: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
@ -295,16 +336,20 @@ Native APIs require manual searching and looping. tp.el provides convenient patt
(tp-search my-string 'marker) ; => ((0 5 t) (12 17 t))
;; Upcase all marker text
(tp-search-map #'upcase my-string 'marker)
(tp-search-map #'upcase 'marker nil my-string)
```
## Requirements
- **Emacs 28.1+** (uses `object-intervals` function)
- **dash.el** (list manipulation utilities)
- **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:
```elisp
;; Add to your load-path
(add-to-list 'load-path "/path/to/tp")
@ -318,6 +363,25 @@ Or with `use-package`:
:load-path "/path/to/tp")
```
The modules and their roles:
| Module | Responsibility |
|---|---|
| `tp-core.el` | Intervals, plist/face merge engine, debug logging, `$var` utilities |
| `tp-reactive.el` | Reactive dependency registry, variable watchers, batching queue |
| `tp-layer.el` | `define-tp` / `define-tps`, layer registry and resolution |
| `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` |
| `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-palette.el` | Light/dark color palette data |
| `tp-builtins.el` | Built-in layers, palette gallery, display-buffer helpers |
A `Makefile` is included: `make test` runs all ERT suites, `make doctest`
executes the README examples against the code (`tp-doctest.el`),
`make compile` byte-compiles the modules, and `make clean` removes
compiled files.
---
## API Reference
@ -334,6 +398,7 @@ A complete overview of all tp.el functions organized by category:
| [`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 |
@ -420,6 +485,17 @@ A complete overview of all tp.el functions organized by category:
| [`tp-intervals-map`](#tp-intervals-map---apply-function-to-intervals) | Apply function to all intervals in a region |
| [`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 |
| [`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 |
---
@ -495,8 +571,8 @@ LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a grou
(let ((my-buffer (generate-new-buffer "*test*")))
(with-current-buffer my-buffer
(insert "Hello World"))
(tp-set 1 10 '(face italic) my-buffer)
(kill-buffer my-buffer))
(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
@ -518,16 +594,17 @@ LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a grou
;; Use a defined layer name on entire string
(define-tp my-style ()
:props '(face (:foreground $my-color))
:data ((my-color . "blue")))
:data '((my-color . "blue")))
(tp-set " " 'my-style)
;; => #(" " 0 1 (tp-name my-style face (:foreground "blue") ...))
;; => #(" " 0 1 (face (:foreground "blue") tp-name my-style))
;; Merge multiple faces in a single call (duplicate properties auto-merged)
(tp-set "emacs"
'face 'bold
'face '(:background "green")
'face '(:foreground "red"))
;; => Three faces merged into one: ((:background "green" :foreground "red") bold)
;; => 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"
@ -806,6 +883,37 @@ For single-position property queries (previously done with `tp-get`), use `tp-at
---
#### `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.
@ -874,7 +982,7 @@ Remove a property or nested sub-property from a region or entire string.
;; Remove nested keys from string
(let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue")))))
(let ((result (tp-remove original 'face :underline '(:style))))
(get-text-property 0 '(face :underline) result)))
(tp-at 0 '(face :underline) result)))
;; => (:color "blue")
```
@ -942,7 +1050,8 @@ OBJECT is a buffer or string; nil means current buffer.
(with-temp-buffer
(insert "Hello world, Hello again")
(tp-match-set '("world" "Hello") '(face bold)))
;; => ((1 . 6) (7 . 12) (14 . 19)) ; Matches "Hello", "world", "Hello"
;; => ((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")
@ -1064,13 +1173,15 @@ OBJECT is a buffer or string; nil means current buffer.
(list (tp-at 5 'face) (tp-at 13 'face)))
;; => (font-lock-number-face font-lock-number-face)
;; On string
;; 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" 6 11 (face bold))
;; => #("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" 4 7 (face bold) 8 11 (face bold))
;; => #("abc 123 XYZ" 0 3 (face bold) 4 7 (face bold) 8 11 (face bold))
;; Use a defined layer name
(define-tp number-style ()
@ -1107,12 +1218,12 @@ OBJECT is a buffer or string; nil means current buffer.
(tp-at 5))
;; => (face bold) ; help-echo is removed
;; On string
;; 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)
(tp-regexp-reset "[0-9]+" '(face italic) str)
(tp-at 4 str))
;; => (face italic)
(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 ()
@ -1149,12 +1260,12 @@ OBJECT is a buffer or string; nil means current buffer.
(tp-at 5))
;; => (face bold help-echo "number")
;; On string
;; 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)
(tp-regexp-add "[0-9]+" '(face italic) str)
(tp-at 4 str))
;; => (face italic help-echo "number")
(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 ()
@ -1191,23 +1302,47 @@ These are low-level search functions that work directly with prop-match objects.
Search forward/backward N times for text with PROPERTY.
- **N** is the number of searches, defaulting to 1.
- **VALUE** is the optional value to match.
- **VALUE** is `equal`-matched against the property's value in buffers.
Passing nil therefore matches the next run where PROPERTY is *absent*
(its value is nil); pass the value explicitly to find a propertied region.
- **`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.
- For buffers, returns the prop-match object from the last successful search.
- For strings, returns a list of (START END VALUE) for all matches found.
- For strings, returns a list of (START END VALUE) for runs where PROPERTY
is present; VALUE nil means any value. `tp-backward` returns them from
end to start.
**Examples:**
```elisp
;; Find next text with 'marker property
;; 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
;; VALUE nil equal-matches nil - i.e. the run WITHOUT the property
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char 1)
(let ((match (tp-forward 'marker)))
(when match
(prop-match-beginning match))))
;; => 7
(list (prop-match-beginning match) (prop-match-end match))))
;; => (1 7) ; the run where marker is absent
;; 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
@ -1238,11 +1373,12 @@ Search forward/backward N times for text with PROPERTY.
Search forward/backward for text with PROPERTY and apply FUNCTION **only to the last match**.
- **FUNCTION** receives `(TEXT &optional START END)` where TEXT is the matched text, START and END are the positions of the match. The return value of FUNCTION replaces the matched text in the string or buffer.
- **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** is the optional value to match; nil means search for PROPERTY without matching value.
- **OBJECT** can be a buffer or string; nil defaults to current buffer.
- **TIMES** is the number of searches, defaulting to 1. The function searches TIMES times but only applies FUNCTION to the last (Nth) match found.
- **TIMES** 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.
- Returns the number of successful matches.
@ -1345,7 +1481,13 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT.
- TEXT is the matched text
- START and END are the positions of the match
- IDX is the 0-based index of the current match
The return value of FUNCTION replaces the matched text in the string or buffer.
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** is the optional value to match; nil means search for PROPERTY without matching value.
- **OBJECT** can be a buffer or string; nil defaults to current buffer.
@ -1424,8 +1566,8 @@ Custom text properties is a **general-purpose feature** provided by tp.el. After
'face 'bold
'face '(:background "green")
'face '(:foreground "red"))
;; Result: face is ((:background "green" :foreground "red") bold)
;; Three face properties are intelligently merged
;; 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"
@ -1499,7 +1641,7 @@ Text property layers is a **unique feature** of tp.el that requires specific fun
##### `define-tp` - Define Single Custom Text Property (Layer)
Define a custom text property. The name does not need to be quoted. Supports three formats:
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), `(ARG)` for parameterized layers. Supports three formats:
**Format 1 - Non-parameterized (empty argument list, simple properties):**
@ -1527,9 +1669,9 @@ Define a custom text property. The name does not need to be quoted. Supports thr
```elisp
(define-tp my-reactive-layer ()
:props '(face (:foreground $my-color))
:data '((my-color . "red"))
:compute '((full-name (lambda () (concat first-name " " last-name))))
: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)))
@ -1547,9 +1689,13 @@ Define a custom text property. The name does not need to be quoted. Supports thr
- **: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. Properties in the group can be used individually or with the group name to set multiple layers.
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, `(ARG)` for parameterized ones. Properties in the group can be used individually or with the group name to set multiple layers.
**Format 1 - Non-parameterized (empty argument list):**
@ -1641,8 +1787,7 @@ The first layer in the definition is the top layer (visible by default).
```elisp
;; Define status layers, then group them
(progn
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tp highlight ()
'(face (:background "yellow" :foreground "black")))
(define-tp error ()
@ -1656,20 +1801,18 @@ The first layer in the definition is the top layer (visible by default).
;; Define a layer group with named layers
(progn
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tps moon-phases ()
'("new" . (display "🌑"))
'("waxing-crescent" . (display "🌒"))
'("first-quarter" . (display "🌓"))
'("full" . (display "🌕")))
(tp-layer-props 'moon-phases-full))
;; => (display "🌕" tp-name moon-phases-full)
;; => (display "🌕")
;; Parameterized layer group referencing other defined layers
(progn
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tp tp-test-l1 (color)
`(face (:foreground ,color)))
(define-tp tp-test-l2 (color)
@ -1691,27 +1834,34 @@ The first layer in the definition is the top layer (visible by default).
#### `tp-layer-props` / `tp-group-props`
```elisp
(tp-layer-props LAYER-NAME)
(tp-group-props GROUP-NAME)
(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
;; Get layer properties (no tp-name by default)
(progn
(setq tp-layer-alist nil)
(tp-layer-reset)
(define-tp my-layer ()
'(face bold help-echo "tip"))
(tp-layer-props 'my-layer))
;; => (face bold help-echo "tip" tp-name my-layer)
(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
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(define-tps my-group ()
@ -1736,7 +1886,7 @@ Remove layer or group definition.
```elisp
;; Undefine a layer
(progn
(setq tp-layer-alist nil)
(tp-layer-reset)
(define-tp temp-layer () '(face bold))
(tp-undefine-layer 'temp-layer)
(tp-layer-props 'temp-layer))
@ -1744,8 +1894,7 @@ Remove layer or group definition.
;; Undefine a group
(progn
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tp l1 () '(face bold))
(define-tps my-group ()
'l1)
@ -1798,7 +1947,7 @@ This is useful when you want to remove all reactive bindings but keep the layer
(tp-reactive-reset)
;; Layer still exists, but changing my-reactive-color no longer updates it
(tp-layer-props 'reactive-layer))
;; => (face (:foreground "red") tp-name reactive-layer)
;; => (face (:foreground "red"))
```
---
@ -1821,6 +1970,17 @@ Set layer(s) at a specific index position in the layer stack.
- `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")`
**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.
**Examples:**
```elisp
@ -1858,6 +2018,35 @@ Set layer(s) at a specific index position in the layer stack.
(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")
```
---
@ -1899,6 +2088,21 @@ Push a layer to the top of the stack (equivalent to `tp-put-layer ... 0`).
(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 1)
```
---
@ -2471,7 +2675,11 @@ Add or merge properties to all layers in a region or string.
Get all text property intervals from START to END in OBJECT.
- Returns a list of (START END PROPERTIES) for each interval.
- 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 **0-based offsets relative to START**. For strings,
positions are absolute 0-based indices.
- Uses `object-intervals` (requires Emacs 28.1+).
- OBJECT can be a buffer or string; nil defaults to current buffer.
@ -2483,7 +2691,8 @@ Get all text property intervals from START to END in OBJECT.
(tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic))
(tp-intervals 1 12))
;; => ((0 5 (face bold)) (6 11 (face italic)))
;; => ((0 5 (face bold)) (5 6 nil) (6 11 (face italic)))
;; positions are offsets from START; (5 6 nil) is the unpropertized gap
```
---
@ -2497,8 +2706,9 @@ Get all text property intervals from START to END in OBJECT.
Apply FUNCTION to all intervals between START and END in OBJECT.
- FUNCTION receives four arguments: interval-start, interval-end, top-props (visible layer properties), and below-props-lst (list of hidden layers).
- Intervals with no properties are visited too, with nil top-props (positions follow the same offset convention as `tp-intervals`).
- OBJECT can be a buffer or string; nil defaults to current buffer.
- Returns list of function results (nil values are removed).
- Returns list of function results (nil results are removed).
**Examples:**
@ -2511,7 +2721,7 @@ Apply FUNCTION to all intervals between START and END in OBJECT.
(lambda (start end props belows)
(list start end (plist-get props 'face)))
1 12))
;; => ((0 5 bold) (6 11 italic))
;; => ((0 5 bold) (5 6 nil) (6 11 italic))
```
---
@ -2556,7 +2766,9 @@ Return layer properties for LAYER-NAME in region from START to END.
Get a property list of all properties present in a region or string.
- Returns a plist containing all properties found in the range.
- 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:**
@ -2567,7 +2779,7 @@ Get a property list of all properties present in a region or string.
(tp-set 1 6 '(face bold help-echo "Tip"))
(tp-set 7 12 '(face italic))
(tp-plist 1 12))
;; => (face bold help-echo "Tip" face italic)
;; => (help-echo "Tip" face italic) ; later interval's face wins
```
---
@ -2587,13 +2799,81 @@ Return t if OBJECT has no text properties.
```elisp
(tp-empty-p "plain text") ; => t
(let ((str (copy-sequence "text")))
(tp-set str 'face 'bold)
(tp-empty-p str)) ; => nil
;; 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:
```elisp
(define-tp-palette my-brand
:fg ("#0969da" . "#58a6ff") ; ("light" . "dark")
:bg ("#ddf4ff" . "#1f3d5c"))
```
- **`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
@ -2637,7 +2917,7 @@ Return t if OBJECT has no text properties.
(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)
(define-tps task-status () 'status-todo 'status-progress 'status-done)
;; Check group is defined
(length (tp-group-props 'task-status)))
;; => 3
@ -2658,7 +2938,7 @@ Return t if OBJECT has no text properties.
(define-tp temp-highlight ()
'(face (:background "yellow")))
(tp-layer-props 'temp-highlight))
;; => (face (:background "yellow") tp-name temp-highlight)
;; => (face (:background "yellow"))
;; Flash function (for use in real buffers)
(defun flash-region (start end)
@ -2793,10 +3073,10 @@ 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)))))
: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"
@ -2875,7 +3155,7 @@ All text property APIs (`tp-set`, `tp-match-set`, `tp-regexp-set`, etc.) now acc
Layer groups can also use reactive features:
```elisp
(define-tps status-indicators
(define-tps status-indicators ()
'("success" :props (face (:foreground $success-color))
:data ((success-color . "green")))
'("warning" :props (face (:foreground $warning-color))
@ -2960,22 +3240,18 @@ To clear all reactive dependencies and watchers:
(defvar theme-bg "black")
(defvar theme-accent "cyan")
;; Define theme-aware layers
;; Define theme-aware layers - each one references a theme variable
(define-tp code-text ()
:props '(face (:foreground $theme-fg :background $theme-bg)))
(define-tp code-keyword ()
:props '(face (:foreground $theme-accent :weight bold)))
(define-tp code-comment ()
:props '(face (:foreground "gray" :slant italic)))
(define-tp code-string ()
:props '(face (:foreground "green")))
;; Apply layers to code
;; 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)
(tp-regexp-set ";.*$" 'code-comment)
(tp-regexp-set "\"[^\"]*\"" 'code-string)
;; Switch to light theme - just change variables!
;; Switch to light theme - just change the variables!
(defun switch-to-light-theme ()
(interactive)
(setq theme-fg "black")
@ -2988,13 +3264,16 @@ To clear all reactive dependencies and watchers:
(setq theme-fg "white")
(setq theme-bg "black")
(setq theme-accent "cyan"))
;; After `switch-to-light-theme', keywords turn blue and the rest of the
;; code turns black-on-white - every region re-renders automatically
```
---
## License
GNU General Public License v2 or later.
GNU General Public License v3 or later. See the [LICENSE](LICENSE) file.
---

445
README_CN.md
View File

@ -17,6 +17,7 @@
## 目录
- [快速开始](#快速开始)
- [概述](#概述)
- [核心创新](#核心创新)
- [功能特性](#功能特性)
@ -37,6 +38,7 @@
- [tp-add](#tp-add---添加合并属性)
- [tp-get](#tp-get---获取属性值)
- [tp-at](#tp-at---获取位置属性)
- [tp-member](#tp-member---判断位置属性是否存在)
- [tp-remove](#tp-remove---移除属性)
- [tp-clear](#tp-clear---清除所有属性)
- [模式匹配函数](#模式匹配函数)
@ -90,6 +92,8 @@
- [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)
- [调色板系统](#调色板系统)
- [响应式文本属性](#响应式文本属性)
- [核心概念](#核心概念)
- [工作原理](#工作原理)
@ -114,10 +118,45 @@
---
## 快速开始
```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-reactive`、`tp-layer`、`tp-ops`、`tp-search`、`tp-render`、`tp-stack`、`tp-palette`、`tp-builtins`），由伞形文件 `tp.el` 统一加载 — `(require 'tp)` 仍会加载全部模块，对用户没有任何变化。模块一览见[安装](#安装)。
### 核心创新
1. **统一的 API 参数规范**：所有函数支持多种灵活的调用方式，同时适用于字符串和缓冲区
@ -167,13 +206,13 @@
- ✅ **路径式访问**：通过路径语法访问深层嵌套的属性值
```elisp
;; 获取嵌套属性
(tp-get str 'face :underline :style) ; => wave
;; 获取嵌套属性（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))
;; => ((:color "green" :style wave))
;; => ((0 5 (:color "green" :style wave)))
```
- ✅ **子属性删除**：精确移除嵌套属性中的特定键
```elisp
@ -190,7 +229,8 @@
'face 'bold
'face '(:background "green")
'face '(:foreground "red"))
;; 结果: face 是 ((:background "green" :foreground "red") bold)
;; 结果: face 是 ((:foreground "red") (:background "green") bold)
;; （各条目堆叠为一个 face 列表，最新的在前）
;; 同一子属性后面的覆盖前面的
(tp-set "emacs"
@ -274,15 +314,14 @@
;; 之后只需改变变量 - 文本自动更新！
(setq my-color "blue") ;; 所有 my-highlight 层的文本自动变成蓝色！
;; 高级响应式示例（使用 define-tp）：
;; 对于需要 :data、:compute、:watch 等高级特性的场景，
;; 可以使用 define-tp
;; 使用 :data、:compute、:watch 的高级示例
;; （注意：参数列表 () 是必需的，且各关键字的值必须加引号）
(define-tp full-name-layer ()
:props '(help-echo $full-name face (:foreground $name-color))
:data '((first-name . "John") (last-name . "Doe")) ;; 带初始值
: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)))))
(message "名字从 %s 改为 %s" old new)))))
```
### 增强的搜索与导航
@ -297,16 +336,19 @@
(tp-search my-string 'marker) ; => ((0 5 t) (12 17 t))
;; 将所有标记文本转为大写
(tp-search-map #'upcase my-string 'marker)
(tp-search-map #'upcase 'marker nil my-string)
```
## 系统要求
- **Emacs 28.1+**（使用 `object-intervals` 函数）
- **dash.el**（列表操作工具库）
- **dash.el 2.19.1+**（列表操作工具库）
## 安装
本库由 `tp-*.el` 模块家族加上伞形文件 `tp.el` 组成。安装即把目录加入
`load-path` 并 require 伞形文件，它会加载全部模块：
```elisp
;; 添加到 load-path
(add-to-list 'load-path "/path/to/tp")
@ -320,6 +362,24 @@
:load-path "/path/to/tp")
```
各模块及其职责：
| 模块 | 职责 |
|---|---|
| `tp-core.el` | 区间、plist/face 合并引擎、调试日志、`$var` 工具 |
| `tp-reactive.el` | 响应式依赖注册表、变量监视器、批量更新队列 |
| `tp-layer.el` | `define-tp` / `define-tps`、属性层注册表与解析 |
| `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` |
| `tp-search.el` | `tp-match-*`、`tp-regexp-*`、`tp-search`、导航 |
| `tp-render.el` | 响应式重渲染引擎 |
| `tp-stack.el` | 属性层栈操作（push/pop/移动/合并/扁平化/...） |
| `tp-palette.el` | 亮色/暗色调色板数据 |
| `tp-builtins.el` | 内置属性层、调色板画廊、display-buffer 辅助工具 |
项目附带 `Makefile`：`make test` 运行所有 ERT 测试套件，`make doctest`
将 README 示例作为可执行测试运行（`tp-doctest.el`），`make compile`
字节编译各模块，`make clean` 清除编译产物。
---
## API 参考
@ -336,6 +396,7 @@ tp.el 所有函数按类别组织的完整概览：
| [`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---清除所有属性) | 清除区域中的所有文本属性 |
@ -422,6 +483,17 @@ tp.el 所有函数按类别组织的完整概览：
| [`tp-intervals-map`](#tp-intervals-map---对区间应用函数) | 对区域中的所有区间应用函数 |
| [`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-palette-show`](#调色板系统) | 展示所有已注册调色板的画廊 |
| [`tp-parse-color`](#调色板系统) | 按当前亮色/暗色主题解析颜色规格 |
---
@ -489,8 +561,8 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或
(let ((my-buffer (generate-new-buffer "*test*")))
(with-current-buffer my-buffer
(insert "Hello World"))
(tp-set 1 10 '(face italic) my-buffer)
(kill-buffer my-buffer))
(prog1 (tp-set 1 10 '(face italic) my-buffer)
(kill-buffer my-buffer)))
;; => (1 . 10)
;; 在字符串区域设置属性（0 索引）- 修改原始字符串
@ -514,14 +586,15 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或
:props '(face (:foreground $my-color))
:data '((my-color . "blue")))
(tp-set " " 'my-style)
;; => #(" " 0 1 (tp-name my-style face (:foreground "blue") ...))
;; => #(" " 0 1 (face (:foreground "blue") tp-name my-style))
;; 单次调用中合并多个 face（重复属性自动合并）
(tp-set "emacs"
'face 'bold
'face '(:background "green")
'face '(:foreground "red"))
;; => 三个 face 合并为一个: ((:background "green" :foreground "red") bold)
;; => face 是 ((:foreground "red") (:background "green") bold)
;; （各条目堆叠为一个 face 列表，最新的在前）
;; 同一子属性后面的值覆盖前面的
(tp-set "emacs"
@ -800,6 +873,34 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或
---
#### `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` - 移除属性
从区域或整个字符串中移除属性或嵌套子属性。
@ -868,7 +969,7 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或
;; 从字符串移除嵌套键
(let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue")))))
(let ((result (tp-remove original 'face :underline '(:style))))
(get-text-property 0 '(face :underline) result)))
(tp-at 0 '(face :underline) result)))
;; => (:color "blue")
```
@ -936,7 +1037,8 @@ OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
(with-temp-buffer
(insert "Hello world, Hello again")
(tp-match-set '("world" "Hello") '(face bold)))
;; => ((1 . 6) (7 . 12) (14 . 19)) ; 匹配 "Hello", "world", "Hello"
;; => ((7 . 12) (1 . 6) (14 . 19)) ; 结果按模式分组：
;; 先是 "world" 的区域，再是每个 "Hello"，顺序与模式列表一致
;; 在字符串上使用多个模式
(tp-match-set '("Hello" "world") '(face bold) "Hello world")
@ -1058,13 +1160,15 @@ OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
(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" 6 11 (face bold))
;; => #("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" 4 7 (face bold) 8 11 (face bold))
;; => #("abc 123 XYZ" 0 3 (face bold) 4 7 (face bold) 8 11 (face bold))
;; 使用已定义的层名称
(define-tp number-style ()
@ -1101,12 +1205,12 @@ OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
(tp-at 5))
;; => (face bold) ; help-echo 被移除
;; 在字符串上
;; 在字符串上 - 返回新字符串，原字符串保持不变
(let ((str (copy-sequence "abc 123 def")))
(tp-set 4 7 '(help-echo "original") str)
(tp-regexp-reset "[0-9]+" '(face italic) str)
(tp-at 4 str))
;; => (face italic)
(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 ()
@ -1143,12 +1247,12 @@ OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。
(tp-at 5))
;; => (face bold help-echo "number")
;; 在字符串上
;; 在字符串上 - 返回新字符串，原字符串保持不变
(let ((str (copy-sequence "abc 123 def")))
(tp-set 4 7 '(help-echo "number") str)
(tp-regexp-add "[0-9]+" '(face italic) str)
(tp-at 4 str))
;; => (face italic help-echo "number")
(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 ()
@ -1185,23 +1289,46 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
向前/向后搜索 N 次具有 PROPERTY 的文本。
- **N** 是搜索次数，默认为 1。
- **VALUE** 是可选的匹配值。
- **VALUE** 在缓冲区中与属性值做 `equal` 匹配。
因此传入 nil 会匹配下一段 PROPERTY *不存在*（值为 nil）的区段；
要查找带属性的区域，请显式传入属性值。
- **`tp-backward` 与 `tp-forward` 对称**：相同的 equal 匹配语义，
方向相反。
- **OBJECT** 可以是缓冲区或字符串；nil 默认为当前缓冲区。
- 对于缓冲区，返回最后一次成功搜索的 prop-match 对象。
- 对于字符串，返回所有匹配的 (START END VALUE) 列表。
- 对于字符串，返回 PROPERTY 存在的各区段的 (START END VALUE) 列表；
VALUE 为 nil 表示匹配任意值。`tp-backward` 按从末尾到开头的顺序返回。
**示例：**
```elisp
;; 查找下一个具有 'marker 属性的文本
;; 查找下一个 '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 为 nil 时 equal 匹配 nil - 即匹配没有该属性的区段
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char 1)
(let ((match (tp-forward 'marker)))
(when match
(prop-match-beginning match))))
;; => 7
(list (prop-match-beginning match) (prop-match-end match))))
;; => (1 7) ; marker 不存在的区段
;; 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
@ -1232,11 +1359,12 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
在 OBJECT 的 START 到 END 范围内，向前/向后搜索匹配 PROPERTY 属性（值为 VALUE）的部分，**仅对最后一次匹配执行 FUNCTION 函数**。
- **FUNCTION** 的参数是 `(TEXT &optional START END)`，其中 TEXT 是此次匹配到的文本，START 和 END 为开始结束的位置。FUNCTION 的返回值将替换字符串或缓冲区中的匹配文本。
- **FUNCTION** 的参数是 `(TEXT &optional START END IDX)`，其中 TEXT 是此次匹配到的文本，START 和 END 为开始结束的位置，IDX 是从 0 开始的匹配索引。FUNCTION 会按其实际接受的参数个数被调用。当 FUNCTION 返回字符串时，它将替换字符串或缓冲区中的匹配文本。
- **在缓冲区中替换文本可以改变长度**（先删除匹配文本，再插入替换文本）。**字符串无法就地改变长度**：长度不同的替换会发出错误信号；长度相同的替换会就地应用。
- **PROPERTY** 是要搜索的文本属性。
- **VALUE** 为 nil 时，表示搜索 PROPERTY 属性，不用匹配值。
- **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。
- **TIMES** 表示向前/向后搜索几次，默认搜索一次。该函数会搜索 TIMES 次，但仅对找到的最后（第 N 次）匹配应用 FUNCTION。
- **TIMES** 表示向前/向后搜索几次，默认搜索一次。该函数会搜索 TIMES 次，但仅对第 TIMES 个匹配应用 FUNCTION。要么全有要么全无：当匹配数量不足 TIMES 时，完全不应用 FUNCTION，仅返回实际找到的匹配数量。
- **START** 和 **END** 默认为 OBJECT 的起始和结束位置。
- 返回成功匹配的数量。
@ -1339,7 +1467,11 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
- TEXT 是此次匹配到的文本
- START 和 END 为开始结束的位置
- IDX 是遍历中的当前从 0 开始的索引
FUNCTION 的返回值将替换字符串或缓冲区中的匹配文本。
FUNCTION 会按其实际接受的参数个数被调用。当 FUNCTION 返回字符串时，
它将替换字符串或缓冲区中的匹配文本。
- **在缓冲区中替换文本可以改变长度**（先删除匹配文本，再插入替换文本）。
**字符串无法就地改变长度**：长度不同的替换会发出错误信号；
长度相同的替换会就地应用。
- **PROPERTY** 是要搜索的文本属性。
- **VALUE** 为 nil 时，表示搜索 PROPERTY 属性，不用匹配值。
- **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。
@ -1418,8 +1550,8 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
'face 'bold
'face '(:background "green")
'face '(:foreground "red"))
;; 结果: face 是 ((:background "green" :foreground "red") bold)
;; 三个 face 属性被智能合并
;; 结果: face 是 ((:foreground "red") (:background "green") bold)
;; 三个 face 属性堆叠为一个 face 列表，最新的在前
;; 同一子属性后面的覆盖前面的
(tp-set "emacs"
@ -1477,6 +1609,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
### 属性层概念
```
┌─────────────────────────────┐
│ 顶层（可见） │ ← idx=0，你看到的
├─────────────────────────────┤
@ -1484,6 +1617,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
├─────────────────────────────┤
│ 底层（隐藏） │ ← idx=-1，被保留
└─────────────────────────────┘
```
### 属性层定义
@ -1491,7 +1625,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
##### `define-tp` - 定义单个自定义文本属性（层）
定义自定义文本属性，名称无需单引号引用。支持三种格式：
定义自定义文本属性，名称无需单引号引用。**所有格式中参数列表都是必需的**：无参数层（包括响应式关键字格式）用 `()`，参数化层用 `(ARG)`。支持三种格式：
**格式一 - 无参数（空参数列表，简单属性）：**
@ -1519,9 +1653,9 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
```elisp
(define-tp my-reactive-layer ()
:props '(face (:foreground $my-color))
:data '((my-color . "red"))
:compute '((full-name (lambda () (concat first-name " " last-name))))
: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)))
@ -1539,9 +1673,12 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
- **:watch** - 监听器列表，变量改变时执行回调
- **:transform** - 转换函数，在显示 `tp-text` 值之前对其进行处理
注意：`:props`、`:data`、`:compute` 和 `:watch` 的值必须**加引号**
（它们在层定义时会被求值）；`:transform` 接受一个函数。
##### `define-tps` - 定义自定义文本属性组（层组）
定义多个相关的自定义文本属性，名称无需单引号引用。属性组中定义的文本属性可以单独使用，也可以使用组名称来设置多层。
定义多个相关的自定义文本属性，名称无需单引号引用。与 `define-tp` 一样，**参数列表是必需的**：无参数层组用 `()`，参数化层组用 `(ARG)`。属性组中定义的文本属性可以单独使用，也可以使用组名称来设置多层。
**格式一 - 无参数（空参数列表）：**
@ -1636,8 +1773,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
```elisp
;; 先定义状态层，然后将它们组合成层组
(progn
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tp highlight ()
'(face (:background "yellow" :foreground "black")))
(define-tp error ()
@ -1651,20 +1787,18 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
;; 使用命名层定义层组
(progn
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tps moon-phases ()
'("new" . (display "🌑"))
'("waxing-crescent" . (display "🌒"))
'("first-quarter" . (display "🌓"))
'("full" . (display "🌕")))
(tp-layer-props 'moon-phases-full))
;; => (display "🌕" tp-name moon-phases-full)
;; => (display "🌕")
;; 参数化层组，引用其他已定义的层
(progn
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tp tp-test-l1 (color)
`(face (:foreground ,color)))
(define-tp tp-test-l2 (color)
@ -1686,27 +1820,33 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
#### `tp-layer-props` / `tp-group-props`
```elisp
(tp-layer-props LAYER-NAME)
(tp-group-props GROUP-NAME)
(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
(setq tp-layer-alist nil)
(tp-layer-reset)
(define-tp my-layer ()
'(face bold help-echo "tip"))
(tp-layer-props 'my-layer))
;; => (face bold help-echo "tip" tp-name my-layer)
(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
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tp layer1 ()
'(face bold))
(define-tp layer2 ()
@ -1733,7 +1873,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
```elisp
;; 取消定义属性层
(progn
(setq tp-layer-alist nil)
(tp-layer-reset)
(define-tp temp-layer ()
'(face bold))
(tp-undefine-layer 'temp-layer)
@ -1742,10 +1882,10 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
;; 取消定义属性层组
(progn
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-layer-reset)
(define-tp l1 () '(face bold))
(define-tps my-group 'l1)
(define-tps my-group ()
'l1)
(tp-undefine-group 'my-group)
(assoc 'my-group tp-layer-groups))
;; => nil
@ -1795,7 +1935,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(tp-reactive-reset)
;; 层仍然存在，但改变 my-reactive-color 不再更新它
(tp-layer-props 'reactive-layer))
;; => (face (:foreground "red") tp-name reactive-layer)
;; => (face (:foreground "red"))
```
---
@ -1818,6 +1958,16 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
- `IDX = -1`：底部
- 其他值在该位置插入
LAYER 接受以下几种形式：
- 用 `define-tp` 定义的层名：`'highlight`
- 内联属性 plist（无需 `define-tp`）：`'(face bold help-echo "tip")`
- 层名列表（第一个层名位于顶部）：`'(layer-a layer-b)`
- 参数化层调用：`'(tp-color "red")`
**栈模型：**只有顶层的属性是可见的文本属性；下层被保存在
`tp-layers` 文本属性中，直到被上移、轮换或扁平化。
**示例：**
```elisp
@ -1855,6 +2005,35 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(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")
```
---
@ -1896,6 +2075,21 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(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 1)
```
---
@ -2468,7 +2662,10 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
从 OBJECT 中获取 START 到 END 之间的所有文本属性区间。
- 返回每个区间的 (START END PROPERTIES) 列表。
- 返回每个区间的 (START END PROPERTIES) 列表，包括没有属性的
间隙区间，其 PROPERTIES 为 nil。
- 对于缓冲区输入，START 和 END 是从 1 开始的缓冲区位置，但返回的位置是
**相对于 START 的 0 基偏移量**。对于字符串，位置是绝对的 0 基索引。
- 使用 `object-intervals`（需要 Emacs 28.1+）。
- OBJECT 可以是缓冲区或字符串；nil 默认为当前缓冲区。
@ -2480,7 +2677,8 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic))
(tp-intervals 1 12))
;; => ((0 5 (face bold)) (6 11 (face italic)))
;; => ((0 5 (face bold)) (5 6 nil) (6 11 (face italic)))
;; 位置是相对 START 的偏移量；(5 6 nil) 是无属性的间隙
```
---
@ -2494,8 +2692,9 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
对 OBJECT 中 START 到 END 之间的所有区间应用 FUNCTION。
- FUNCTION 接收四个参数：interval-start、interval-end、top-props（可见层属性）和 below-props-lst（隐藏层列表）。
- 没有属性的区间也会被访问，此时 top-props 为 nil（位置遵循与 `tp-intervals` 相同的偏移量约定）。
- OBJECT 可以是缓冲区或字符串；nil 默认为当前缓冲区。
- 返回函数结果列表（nil 值被移除）。
- 返回函数结果列表（nil 结果被移除）。
**示例：**
@ -2508,7 +2707,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(lambda (start end props belows)
(list start end (plist-get props 'face)))
1 12))
;; => ((0 5 bold) (6 11 italic))
;; => ((0 5 bold) (5 6 nil) (6 11 italic))
```
---
@ -2553,7 +2752,8 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
获取区域或字符串中存在的所有属性的属性列表。
- 返回包含范围内找到的所有属性的 plist。
- 返回将范围内找到的属性合并成的单个 plist；当同一属性出现在多个
区间中时，靠后区间的值胜出。
- OBJECT 在区域形式中默认为当前缓冲区。
**示例：**
@ -2564,7 +2764,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(tp-set 1 6 '(face bold help-echo "Tip"))
(tp-set 7 12 '(face italic))
(tp-plist 1 12))
;; => (face bold help-echo "Tip" face italic)
;; => (help-echo "Tip" face italic) ; 靠后区间的 face 胜出
```
---
@ -2584,13 +2784,79 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
```elisp
(tp-empty-p "plain text") ; => t
(let ((str (copy-sequence "text")))
(tp-set str 'face 'bold)
(tp-empty-p str)) ; => nil
;; 整个字符串形式的 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`** — 注册（或更新）一个调色板：
```elisp
(define-tp-palette my-brand
:fg ("#0969da" . "#58a6ff") ; ("亮色" . "暗色")
:bg ("#ddf4ff" . "#1f3d5c"))
```
- **`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` 这样的
内置属性层。
---
## 实用示例
### 多属性层语法高亮
@ -2634,7 +2900,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(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)
(define-tps task-status () 'status-todo 'status-progress 'status-done)
;; 检查组是否已定义
(length (tp-group-props 'task-status)))
;; => 3
@ -2655,7 +2921,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(define-tp temp-highlight ()
'(face (:background "yellow")))
(tp-layer-props 'temp-highlight))
;; => (face (:background "yellow") tp-name temp-highlight)
;; => (face (:background "yellow"))
;; 闪烁函数（用于实际缓冲区）
(defun flash-region (start end)
@ -2791,9 +3057,9 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
(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)))))
(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"
@ -2872,7 +3138,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的
层组也可以使用响应式特性：
```elisp
(define-tps status-indicators
(define-tps status-indicators ()
'("success" :props (face (:foreground $success-color))
:data ((success-color . "green")))
'("warning" :props (face (:foreground $warning-color))
@ -2957,20 +3223,16 @@ tp.el 提供调试模式来帮助理解响应式更新流程：
(defvar theme-bg "black")
(defvar 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)))
(define-tp code-comment ()
:props '(face (:foreground "gray" :slant italic)))
(define-tp code-string ()
:props '(face (:foreground "green")))
;; 将层应用到代码
;; 将层应用到当前缓冲区中的代码
(tp-set (point-min) (point-max) 'code-text)
(tp-match-set '("defun" "defvar" "let" "if" "when") 'code-keyword)
(tp-regexp-set ";.*$" 'code-comment)
(tp-regexp-set "\"[^\"]*\"" 'code-string)
;; 切换到浅色主题 - 只需改变变量！
(defun switch-to-light-theme ()
@ -2985,13 +3247,16 @@ tp.el 提供调试模式来帮助理解响应式更新流程：
(setq theme-fg "white")
(setq theme-bg "black")
(setq theme-accent "cyan"))
;; 调用 `switch-to-light-theme' 后，关键字变为蓝色，其余代码变为
;; 白底黑字 - 每个区域都会自动重新渲染
```
---
## 许可证
GNU 通用公共许可证 v2 或更高版本。
GNU 通用公共许可证 v3 或更高版本。参见 [LICENSE](LICENSE) 文件。
---

682
docs/ARCHITECTURE.md
View File

@ -1,353 +1,495 @@
# tp.el 代码架构文档
# tp 代码架构文档
本文档描述 tp.el 的函数调用层次结构，从底层基础功能到上层 API 的分层组织。
本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。
自 0.2.0 起，原来的单文件 tp.el 已拆分为九个分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。各模块的变更缘由见 [CHANGELOG.md](../CHANGELOG.md)。
## 目录
- [架构概述](#架构概述)
- [分层结构](#分层结构)
- [第一层：基础工具函数](#第一层基础工具函数)
- [第二层：核心属性操作](#第二层核心属性操作)
- [第三层：属性层系统](#第三层属性层系统)
- [第四层：响应式系统](#第四层响应式系统)
- [第五层：高级 API](#第五层高级-api)
- [模块分层](#模块分层)
- [tp-core.el：基础工具](#tp-coreel基础工具)
- [tp-reactive.el：响应式基础设施](#tp-reactiveel响应式基础设施)
- [tp-layer.el：层定义与解析](#tp-layerel层定义与解析)
- [tp-ops.el：核心属性操作](#tp-opsel核心属性操作)
- [tp-search.el：模式匹配与搜索](#tp-searchel模式匹配与搜索)
- [tp-render.el：响应式渲染引擎](#tp-renderel响应式渲染引擎)
- [tp-stack.el：属性层栈操作](#tp-stackel属性层栈操作)
- [tp-palette.el：调色板数据](#tp-paletteel调色板数据)
- [tp-builtins.el：内置层与辅助工具](#tp-builtinsel内置层与辅助工具)
- [钩子变量：唯一许可的反向调用](#钩子变量唯一许可的反向调用)
- [函数调用关系图](#函数调用关系图)
- [设计原则](#设计原则)
---
## 架构概述
tp.el 采用分层架构设计，每一层建立在下层功能之上：
tp 采用严格的线性分层：**每个模块只允许 `require` 并调用排在它前面的模块**，字节编译器强制检查这一依赖顺序。加载顺序即依赖顺序：
```
┌─────────────────────────────────────────────────────────────────┐
│ 第五层：高级 API │
│ tp-match-set, tp-regexp-set, tp-forward-do, tp-search-map │
└─────────────────────────────────────────────────────────────────┘
↓
┌─────────────────────────────────────────────────────────────────┐
│ 第四层：响应式系统 │
│ define-tp, define-tps, tp--reactive-variable-watcher, │
│ tp--update-layer-regions, tp--register-reactive-deps │
└─────────────────────────────────────────────────────────────────┘
↓
┌─────────────────────────────────────────────────────────────────┐
│ 第三层：属性层系统 │
│ tp-push-layer, tp-pop-layer, tp-rotate-layer, │
│ tp-layer-list, tp--build-layer-props │
└─────────────────────────────────────────────────────────────────┘
↓
┌─────────────────────────────────────────────────────────────────┐
│ 第二层：核心属性操作 │
│ tp-set, tp-reset, tp-add, tp-get, tp-at, tp-remove, tp-clear │
└─────────────────────────────────────────────────────────────────┘
↓
┌─────────────────────────────────────────────────────────────────┐
│ 第一层：基础工具函数 │
│ tp--parse-args, tp--deep-merge-plist, tp--get-nested, │
│ tp-intervals, tp-empty-p │
└─────────────────────────────────────────────────────────────────┘
tp-core → tp-reactive → tp-layer → tp-ops → tp-search
→ tp-render → tp-stack → tp-palette → tp-builtins
```
```
┌────────────────────────────────────────────────────────────────┐
│ tp.el —— 总入口，按序 require 全部模块 │
└────────────────────────────────────────────────────────────────┘
┌────────────────────────────────────────────────────────────────┐
│ tp-builtins.el 内置层（tp-link, tp-space, tp-headline …）、 │
│ tp-palette-show、显示缓冲辅助宏 │
├────────────────────────────────────────────────────────────────┤
│ tp-palette.el 明/暗主题调色板数据、tp-parse-color │
├────────────────────────────────────────────────────────────────┤
│ tp-stack.el 层栈操作（push/pop/move/merge/flatten …） │
├────────────────────────────────────────────────────────────────┤
│ tp-render.el 响应式重渲染引擎 ──┐ │
├──────────────────────────────────── │ ─────────────────────────┤
│ tp-search.el tp-match-*/tp-regexp-*、tp-search、导航 │
├──────────────────────────────────── │ ─────────────────────────┤
│ tp-ops.el tp-set/reset/add/get/at/remove/clear │
│ ◁╌╌ tp--tp-text-handler-function ╌╌╌╌┤ │
├──────────────────────────────────── │ ─────────────────────────┤
│ tp-layer.el define-tp/define-tps、层注册表与解析 │
│ ◁╌╌ tp--layer-refresh-function ╌╌╌╌╌╌┤ │
├──────────────────────────────────── │ ─────────────────────────┤
│ tp-reactive.el 响应式依赖注册表、变量监听、批量队列 │
│ ◁╌╌ tp--reactive-update-function ╌╌╌╌┤ │
│ ◁╌╌ tp--reactive-flush-function ╌╌╌╌╌┘ │
├────────────────────────────────────────────────────────────────┤
│ tp-core.el 区间遍历、plist/face 合并引擎、 │
│ 调试日志、$var 符号工具 │
└────────────────────────────────────────────────────────────────┘
实线层级：上层模块调用下层模块（require 依赖）。
虚线（◁╌╌）：钩子变量 —— 下层模块预留的函数变量，
由 tp-render.el 在加载时安装实现（见下文）。
```
早期文档把"响应式系统"画在高级 API 之下、却又让它向上调用 `tp-search-map`，与自身的分层原则矛盾。现在这一矛盾已在代码层面消除：需要向上调用的逻辑全部收拢进 `tp-render.el`（位于 `tp-search.el` 之上，可以直接调用它）；下层模块（tp-reactive、tp-layer、tp-ops）通过**钩子变量**触发渲染，自身不依赖任何上层模块。
---
## 分层结构
## 模块分层
### 第一层：基础工具函数
### tp-core.el：基础工具
这些是最底层的工具函数，不依赖于其他 tp.el 函数，主要提供参数解析、数据结构操作等基础能力。
最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。
#### 区间操作
| 函数 | 描述 | 主要调用者 |
|------|------|--------|
| `tp-intervals` | 获取区域内文本属性区间列表（裁剪到 [START, END)） | tp-intervals-map, tp-get |
| `tp-intervals-map` | 对区间应用函数 | 多个属性/层操作函数 |
| `tp--map-intervals` | 共享的裁剪式区间遍历引擎 | tp-intervals-map, tp-ops/tp-stack 的区域操作 |
| `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-reactive.el：响应式基础设施
只依赖 tp-core。维护响应式依赖注册表、变量监听器与批量更新队列；**不包含任何渲染逻辑**，重渲染通过钩子变量委托给 tp-render.el。
#### 依赖注册与管理
| 函数/变量 | 描述 |
|------|------|
| `tp-reactive-deps` | 变量 → 依赖它的层及属性 的注册表 |
| `tp--register-reactive-deps` | 注册响应式依赖 |
| `tp--unregister-reactive-deps` | 取消注册依赖（含 watchers/computed/data） |
| `tp--layer-has-reactive-deps-p` | 层是否有响应式依赖 |
| `tp--register-layer-watchers` / `tp--unregister-layer-watchers` | 注册/清除 `:watch` 回调 |
| `tp--register-layer-computed` / `tp--unregister-layer-computed` | 注册/清除 `:compute` 计算属性 |
| `tp--register-layer-data` / `tp--unregister-layer-data` | 注册/清除 `:data` 变量 |
| `tp--apply-initial-computed` | 计算 `:compute` 的初始值 |
| `tp--ensure-reactive-variables` | 确保 `$var` 对应的变量已定义 |
| `tp-reactive-reset` | 重置全部响应式注册表 |
#### 变量监听与批量更新
| 函数/宏 | 描述 |
|------|------|
| `tp--reactive-variable-watcher` | `add-variable-watcher` 回调；调用 `:watch` 后经 `tp--reactive-update-function` 委托重渲染 |
| `tp--invoke-layer-watchers` | 调用层的 `:watch` 回调 |
| `tp-with-batch-updates` | 批量更新宏 |
| `tp--queue-batch-update` | 将更新加入待处理队列 |
| `tp--flush-batch-updates` | 刷新队列，经 `tp--reactive-flush-function` 委托重渲染 |
钩子变量：`tp--reactive-update-function`、`tp--reactive-flush-function`（定义于此，由 tp-render.el 安装）。
---
### tp-layer.el：层定义与解析
依赖 tp-core、tp-reactive。提供 `define-tp` / `define-tps` 宏、层注册表、层名解析，以及层栈的数据结构原语。
#### 层定义
| 函数/宏 | 描述 | 依赖 |
|---------|------|------|
| `define-tp` | 定义单个自定义文本属性（层） | tp--define-layer-internal |
| `define-tps` | 定义自定义文本属性组（层组）；别名 `define-tp-group` | tp--define-layer-group-internal |
| `tp--define-layer-internal` | 层定义的运行时实现 | tp--parse-define-layer-args, tp--collect-reactive-symbols, tp--ensure-reactive-variables, tp--register-*, tp--layer-refresh |
| `tp--parse-define-layer-args` | 解析 `:props` / `:data` / `:compute` / `:watch` / `:transform` | - |
| `tp--parse-layer-group-element` | 解析层组元素 | tp--layer-group-element-format |
| `tp--define-layer-from-parsed` | 从解析结果定义层 | （与 define-tp 类似的依赖） |
| `tp--check-layer-cycle` | 检测循环层引用并报错 | tp--layer-expansion-stack |
| `tp--anonymous-layer-name-for` | 匿名响应式层的驻留（`equal` 的 props 复用注册项） | - |
#### 注册表与查询
| 函数/变量 | 描述 |
|------|------|
| `tp-layer-alist` / `tp-layer-groups` / `tp-layer-transforms` | 层、层组、转换函数注册表 |
| `tp--set-layer-props` / `tp--set-group-layers` | 写入注册表 |
| `tp-layer-props` / `tp-group-props` | 获取层/层组属性（`&optional INCLUDE-TP-NAME`，默认不含 `tp-name`；返回副本） |
| `tp-layer-props-with-arg` / `tp-group-props-with-arg` | 参数化层/层组的属性求值 |
| `tp-layer-parameterized-p` / `tp-group-parameterized-p` | 是否参数化 |
| `tp-layer-reset` | 重置层系统 |
| `tp-undefine-layer` / `tp-undefine-group` | 删除层/层组（含其响应式依赖与转换） |
#### 属性解析
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--resolve-props` | 解析属性（展开层名、`$var`、注册依赖） | tp-layer-props, tp--collect-reactive-symbols, tp--resolve-reactive-symbols, tp--register-reactive-deps |
| `tp--expand-layer-in-plist` | 展开 plist 中的层名键 | tp--is-layer-name-p |
| `tp--expand-layer-to-props-list` | 层名展开为属性列表 | tp--check-layer-cycle |
#### 层栈数据结构原语
| 函数 | 描述 |
|------|------|
| `tp--normalize-layer-spec` | 规范化层规格 |
| `tp--get-layer-stack` | 获取位置的层栈 |
| `tp--build-layer-props` | 从层列表构建属性 |
| `tp--layer-stack-to-list` | 将层栈转换为列表 |
| `tp--get-layer-by-idx-or-name` | 通过索引或名称查找层 |
钩子变量：`tp--layer-refresh-function`（定义于此，由 tp-render.el 安装为 `tp--update-layer-regions`）；`tp--layer-refresh` 是它的调用入口，层重定义后经它触发已应用区域的重渲染。
---
### tp-ops.el：核心属性操作
依赖 tp-core、tp-layer。面向用户的核心属性读写函数，直接调用 Emacs 原生文本属性 API。
#### 参数解析
| 函数 | 描述 | 调用者 |
|------|------|--------|
| `tp--parse-args` | 解析灵活的函数参数格式 | tp-set, tp-reset, tp-add |
| `tp--parse-layer-args` | 解析属性层操作的参数 | tp-put-layer 及其他层操作函数 |
| `tp--parse-define-layer-args` | 解析 define-tp 的参数 | define-tp |
#### 数据结构操作
| 函数 | 描述 | 调用者 |
|------|------|--------|
| `tp--deep-merge-plist` | 深度合并两个 plist | tp-add, tp--prepend-face |
| `tp--prepend-face` | 处理 face 属性的合并逻辑 | tp-add |
| `tp--get-nested` | 获取嵌套属性值 | tp-get, tp-at |
| `tp--remove-nested-keys` | 从 plist 中移除指定键 | tp--remove-property |
#### 区间操作
| 函数 | 描述 | 调用者 |
|------|------|--------|
| `tp-intervals` | 获取文本属性区间列表 | tp-intervals-map, tp-get |
| `tp-intervals-map` | 对区间应用函数 | 多个层操作函数 |
| `tp-empty-p` | 检查对象是否没有文本属性 | tp-put-layer |
---
### 第二层：核心属性操作
这些是核心的文本属性操作函数，直接调用 Emacs 原生的文本属性 API。
| `tp--parse-args` | 解析灵活的调用格式（整串/区域/层名） | tp-set, tp-reset, tp-add |
| `tp--apply-props-to-string` | 字符串路径的属性应用 | tp-set, tp-reset, tp-add |
#### 设置属性
| 函数 | 描述 | 依赖 | 被依赖 |
|------|------|------|--------|
| `tp-set` | 设置文本属性（保留其他属性） | tp--parse-args, tp--handle-tp-text-property | tp-match-set, 层操作 |
| `tp-reset` | 完全替换所有文本属性 | tp--parse-args, tp--handle-tp-text-property | tp-match-reset |
| `tp-add` | 深度合并属性 | tp--parse-args, tp--deep-merge-plist, tp--prepend-face | tp-match-add, tp--update-layer-regions |
| `tp-set` | 设置文本属性（保留其他属性） | tp--parse-args, tp--handle-tp-text | tp-match-set, 层操作 |
| `tp-reset` | 完全替换所有文本属性 | tp--parse-args, tp--handle-tp-text | tp-match-reset |
| `tp-add` | 深度合并属性 | tp--parse-args, tp--deep-merge-plist, tp--prepend-face | tp-match-add |
#### 获取属性
| 函数 | 描述 | 依赖 | 被依赖 |
|------|------|------|--------|
| `tp-get` | 获取范围内的属性值（返回区间列表） | tp--get-nested | 搜索函数 |
| `tp-at` | 获取单个位置的属性值 | tp--get-nested | 大多数高层函数 |
| `tp-plist` | 获取区域中的所有属性 | tp-intervals | 用户 API |
| `tp-member` | 区分"属性值为 nil"与"属性不存在"（plist-member 风格） | - | 用户 API |
#### 删除属性
| 函数 | 描述 | 依赖 | 被依赖 |
|------|------|------|--------|
| `tp-remove` | 移除属性或子属性 | tp--remove-property, tp--remove-sub | 用户 API |
| `tp-remove` | 移除属性或子属性 | tp--remove-property, tp--remove-sub, tp--remove-*-from-string | 用户 API |
| `tp-clear` | 清除所有属性 | - | 用户 API |
---
### 第三层：属性层系统
属性层系统在核心属性操作之上，提供多层属性栈的管理能力。
#### 层栈操作（内部）
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--get-layer-stack` | 获取位置的层栈 | - |
| `tp--build-layer-props` | 从层列表构建属性 | - |
| `tp--layer-stack-to-list` | 将层栈转换为列表 | - |
| `tp--get-layer-by-idx-or-name` | 通过索引或名称查找层 | - |
| `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--normalize-layer-spec` | 规范化层规格 | tp-layer-props |
#### 层操作（公开 API）
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-put-layer` | 在指定索引放置层 | tp--normalize-layer-spec, tp--build-layer-props, tp-intervals-map |
| `tp-push-layer` | 将层推到顶部 | tp-put-layer |
| `tp-delete-layer` | 删除层 | tp--get-layer-by-idx-or-name, tp-intervals-map |
| `tp-pop-layer` | 弹出顶层 | tp-delete-layer |
| `tp-move-layer` | 移动层到指定位置 | tp--move-layer-in-stack, tp-intervals-map |
| `tp-raise-layer` | 上移/下移层 | tp--raise-layer-in-stack, tp-intervals-map |
| `tp-rotate-layer` | 轮换层 | tp-move-layer |
| `tp-pin-layer` | 将层置顶 | tp-move-layer |
| `tp-switch-layer` | 交换两个层 | tp--switch-layers-in-stack, tp-intervals-map |
| `tp-merge-layers` | 合并多个层 | tp--get-layer-by-idx-or-name, tp-intervals-map |
| `tp-flatten-layers` | 扁平化所有层 | tp-intervals-map |
#### 层查询
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-layer-list` | 列出所有层名称 | tp-intervals-map |
| `tp-layer-count` | 计算层数量 | tp-intervals-map |
| `tp-layer-exists-p` | 检查层是否存在 | tp-region-layer-props |
| `tp-layer-top` | 获取顶层名称 | tp-intervals |
| `tp-region-layer-props` | 获取区域中特定层的属性 | tp-intervals-map |
#### 层属性操作
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-add-to-layers` | 向特定层添加属性 | tp--deep-merge-plist, tp-intervals-map |
| `tp-add-to-all-layers` | 向所有层添加属性 | tp-add-to-layers, tp-layer-count |
钩子变量：`tp--tp-text-handler-function`（定义于此，由 tp-render.el 安装为 `tp--handle-tp-text-property`）；`tp--handle-tp-text` 是它的调用入口，未安装时 `tp-text` 属性按普通属性处理。
---
### 第四层：响应式系统
### tp-search.el：模式匹配与搜索
响应式系统提供当变量值改变时自动更新文本属性的能力。
#### 响应式变量处理
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--reactive-symbol-p` | 检查是否为响应式符号 | - |
| `tp--reactive-var-symbol` | 转换响应式符号为变量符号 | tp--reactive-symbol-p |
| `tp--collect-reactive-symbols` | 收集所有响应式符号 | tp--reactive-symbol-p |
| `tp--resolve-reactive-symbols` | 解析响应式符号为值 | tp--reactive-symbol-p, tp--reactive-var-symbol |
| `tp--extract-reactive-props` | 提取使用特定变量的属性 | tp--collect-reactive-symbols, tp--extract-reactive-value |
| `tp--ensure-reactive-variables` | 确保变量已定义 | tp--reactive-symbol-p, tp--reactive-var-symbol |
#### 依赖注册与管理
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--register-reactive-deps` | 注册响应式依赖 | tp--reactive-var-symbol, tp--extract-reactive-props |
| `tp--unregister-reactive-deps` | 取消注册依赖 | tp--unregister-layer-watchers, tp--unregister-layer-computed, tp--unregister-layer-data |
| `tp--register-layer-watchers` | 注册层的监听器 | - |
| `tp--register-layer-computed` | 注册计算属性 | - |
| `tp--register-layer-data` | 注册数据变量 | tp--data-var-symbol |
| `tp--unregister-layer-watchers` | 取消注册监听器 | - |
| `tp--unregister-layer-computed` | 取消注册计算属性 | - |
| `tp--unregister-layer-data` | 取消注册数据变量 | - |
#### 响应式更新
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--reactive-variable-watcher` | 变量监听器回调 | tp--invoke-layer-watchers, tp--update-layer-computed, tp--update-layer-regions, tp--update-reactive-text |
| `tp--invoke-layer-watchers` | 调用层的监听回调 | - |
| `tp--update-layer-computed` | 更新计算属性 | tp--resolve-reactive-symbols, tp--set-layer-props |
| `tp--update-layer-regions` | 更新使用层的文本区域 | tp-layer-props, tp-search-map, tp-add |
| `tp--update-reactive-text` | 更新响应式文本 | tp-layer-props, tp--replace-reactive-text-in-buffer |
| `tp--replace-reactive-text-in-buffer` | 在缓冲区中替换响应式文本 | - |
#### 层定义
| 函数/宏 | 描述 | 依赖 |
|---------|------|------|
| `define-tp` | 定义单个自定义文本属性（层）| tp--parse-define-layer-args, tp--collect-reactive-symbols, tp--ensure-reactive-variables, tp--register-* |
| `define-tps` | 定义自定义文本属性组（层组）| tp--parse-layer-group-element, tp--define-layer-from-parsed |
| `tp--define-layer-from-parsed` | 从解析结果定义层 | (与 define-tp 类似的依赖) |
| `tp--set-layer-props` | 设置层属性 | - |
| `tp--set-group-layers` | 设置组的层列表 | - |
| `tp-layer-props` | 获取层属性 | - |
| `tp-group-props` | 获取组中所有层的属性 | tp-layer-props |
| `tp--resolve-props` | 解析属性（支持层名称） | tp-layer-props, tp--collect-reactive-symbols, tp--resolve-reactive-symbols, tp--register-reactive-deps |
#### 响应式文本
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--handle-tp-text-property` | 处理 tp-text 属性 | - |
#### 批量更新
| 函数/宏 | 描述 | 依赖 |
|---------|------|------|
| `tp-with-batch-updates` | 批量更新宏 | tp--flush-batch-updates |
| `tp--flush-batch-updates` | 刷新待处理的批量更新 | tp--update-layer-regions, tp--update-reactive-text |
#### 值转换
| 变量/函数 | 描述 | 依赖 |
|-----------|------|------|
| `tp-layer-transforms` | 存储层转换函数的 alist | - |
| `:transform` 选项 | 在 define-tp 中指定转换函数 | tp-layer-transforms |
#### 调试工具
| 变量/函数 | 描述 | 依赖 |
|-----------|------|------|
| `tp-debug-mode` | 启用/禁用调试模式 | - |
| `tp-debug-echo` | 是否在 minibuffer 显示调试信息 | - |
| `tp-debug-log` | 记录调试信息 | tp-debug-mode, tp-debug-echo |
| `tp-debug-show` | 显示 *tp-debug* 缓冲区 | - |
| `tp-debug-clear` | 清除调试日志 | - |
---
### 第五层：高级 API
这些是面向用户的高级 API，构建在前四层之上。
依赖 tp-core、tp-layer、tp-ops。提供模式匹配式属性应用、属性搜索与导航。
#### 模式匹配
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-match-set` | 在字符串匹配处设置属性 | tp--match-apply |
| `tp-match-reset` | 在匹配处重置所有属性 | tp--match-apply |
| `tp-match-add` | 在匹配处添加/合并属性 | tp--match-apply |
| `tp-regexp-set` | 在正则匹配处设置属性 | tp--regexp-apply |
| `tp-regexp-reset` | 在正则匹配处重置属性 | tp--regexp-apply |
| `tp-regexp-add` | 在正则匹配处添加属性 | tp--regexp-apply |
| `tp--match-apply` | 字符串匹配的内部实现 | tp-set/tp-reset/tp-add |
| `tp--regexp-apply` | 正则匹配的内部实现 | tp-set/tp-reset/tp-add |
| `tp-match-set` / `tp-match-reset` / `tp-match-add` | 在字符串匹配处设置/重置/合并属性 | tp--match-apply |
| `tp-regexp-set` / `tp-regexp-reset` / `tp-regexp-add` | 在正则匹配处设置/重置/合并属性 | tp--regexp-apply |
| `tp--match-apply` / `tp--regexp-apply` | 字面/正则匹配的入口（含多模式支持） | tp--pattern-apply |
| `tp--pattern-apply` / `tp--pattern-apply-single` | 共享的模式匹配引擎（空模式/零宽模式安全） | tp-set/tp-reset/tp-add 风格的 apply-fn |
| `tp--deep-merge-apply` / `tp--reset-apply` | 传给引擎的合并/重置回调 | tp--deep-merge-plist 等 |
#### 搜索和导航
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-search-forward` | 向前搜索属性 | text-property-search-forward |
| `tp-search-backward` | 向后搜索属性 | text-property-search-backward |
| `tp-forward` | 向前搜索 N 次 | tp--forward-on-string, tp-search-forward |
| `tp-backward` | 向后搜索 N 次 | tp--backward-on-string, tp-search-backward |
| `tp-forward-do` | 向前搜索并对最后匹配执行函数 | tp--forward-do-on-string |
| `tp-backward-do` | 向后搜索并对最后匹配执行函数 | tp--backward-do-on-string |
| `tp-search` | 搜索所有匹配 | tp--search-do |
| `tp-search-map` | 对所有匹配应用函数 | tp--search-do |
| `tp--search-do` | 搜索的内部实现 | - |
| `tp-search-backward` | 向后搜索属性 | tp--property-search-backward |
| `tp--property-search-backward` | 带等值谓词的向后搜索（与向前语义对称） | text-property-search-backward |
| `tp-forward` | 向前搜索 N 次并移动点 | tp-search-forward |
| `tp-backward` | 向后搜索 N 次并移动点 | tp-search-backward |
| `tp-search` | 收集所有匹配区间 | tp-intervals 等 |
#### 遍历与替换
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-forward-do` / `tp-backward-do` | 向前/向后搜索并对匹配执行函数 | 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-add` 等前置模块的函数，并在加载末尾把自己的入口函数**安装**进下层模块预留的钩子变量。
#### 重渲染
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--update-layer-regions` | 重渲染携带某层的所有文本区域（替换该层自己的属性键，保留其他来源属性） | tp--layer-render-props, tp-search-map |
| `tp--update-layer-computed` | 更新 `:compute` 计算属性（nil 值可正常传播） | tp--resolve-reactive-symbols, tp--set-layer-props |
| `tp--layer-render-props` / `tp--layer-reactive-props` | 求取层的渲染属性 | tp-layer-props |
#### 响应式文本（tp-text）
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--handle-tp-text-property` | 处理 `tp-text` 属性（文本替换） | tp--tp-text-replace |
| `tp--update-reactive-text` | 变量变化后更新响应式文本 | tp--replace-reactive-text-in-buffer |
| `tp--replace-reactive-text-in-buffer` | 在缓冲区中替换响应式文本 | - |
| `tp--tp-text-transform` | 应用 `:transform` 转换（首次渲染同样生效） | tp-layer-transforms |
#### 引擎入口与钩子安装
| 函数 | 描述 |
|------|------|
| `tp--reactive-apply-update` | 变量变化的完整处理：更新 computed、合并层定义、重渲染或入批量队列（嵌套写入经队列而非递归）。安装为 `tp--reactive-update-function` |
| `tp--reactive-flush-entry` | 批量队列刷新时的重渲染入口。安装为 `tp--reactive-flush-function` |
加载末尾执行安装：
```elisp
(setq tp--reactive-update-function #'tp--reactive-apply-update)
(setq tp--reactive-flush-function #'tp--reactive-flush-entry)
(setq tp--tp-text-handler-function #'tp--handle-tp-text-property)
(setq tp--layer-refresh-function #'tp--update-layer-regions)
```
---
### tp-stack.el：属性层栈操作
依赖 tp-core、tp-layer、tp-ops。所有栈变更函数建立在共享的裁剪式区域遍历之上，区域操作不会影响 [START, END) 之外的文本。
#### 内部助手
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--parse-layer-args` | 解析层操作的灵活参数 | - |
| `tp--stack-map-region` | 按区间遍历区域内层栈的共享引擎 | tp--map-intervals 风格遍历 |
| `tp--stack-build-props` | 从层列表构建栈属性（单层栈不携带 `tp-layers`） | - |
| `tp--put-layer-specs` | 展开层规格（层名/内联 plist/层名列表/参数化/层组） | tp--normalize-layer-spec, tp-group-props(-with-arg) |
| `tp--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 |
#### 层操作（公开 API）
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-put-layer` | 在指定索引放置层（区域局部） | tp--put-layer-specs, tp--stack-map-region |
| `tp-push-layer` | 将层推到顶部 | tp-put-layer |
| `tp-delete-layer` | 删除层 | tp--stack-map-region |
| `tp-pop-layer` | 弹出顶层 | tp-delete-layer |
| `tp-move-layer` | 移动层到指定位置 | tp--move-layer-in-stack, tp--stack-map-region |
| `tp-raise-layer` | 上移/下移层 | tp--raise-layer-in-stack, tp--stack-map-region |
| `tp-rotate-layer` | 轮换层 | tp-move-layer |
| `tp-pin-layer` | 将层置顶 | tp-move-layer |
| `tp-switch-layer` | 交换两个层 | tp--switch-layers-in-stack, tp--stack-map-region |
| `tp-merge-layers` | 合并多个层（显式 nil 值保留） | tp--merge-layer-props, tp--stack-map-region |
| `tp-flatten-layers` | 扁平化所有层 | tp--merge-layer-props, tp--stack-map-region |
#### 层查询
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-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-region-layer-props` | 获取区域中特定层的属性 | tp--stack-map-region |
#### 层属性操作
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-add-to-layers` | 向特定层添加属性 | tp--deep-merge-plist, tp--stack-map-region |
| `tp-add-to-all-layers` | 向所有层添加属性 | tp-add-to-layers |
---
### tp-palette.el：调色板数据
只依赖 tp-core（及 subr-x）。明/暗主题双值调色板系统，`tp-palette-alist` 是唯一数据源。
| 函数/宏/变量 | 描述 |
|------|------|
| `define-tp-palette` | 定义调色板（重定义立即生效） |
| `tp-palette-alist` | 调色板注册表（唯一数据源） |
| `tp-parse-color` | 解析颜色规格（支持 `("light" . "dark")` 及单边 cons） |
| `tp-theme-dark-p` / `tp-theme-light-p` | 当前主题判断 |
| `tp-palette-fg-color` / `tp-palette-bg-color` / `tp-palette-border-color` | 取前景/背景/边框色 |
| `tp-palette-p` / `tp-palette-fg-p` / `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p` | 调色板谓词 |
| `tp-palette-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` | 符号加后缀助手 |
---
## 钩子变量：唯一许可的反向调用
分层规则的唯一例外是四个**钩子变量**：下层模块声明变量并在需要时 `funcall`，实现由 tp-render.el 在加载时安装。这样下层模块不必 `require` 上层模块，依赖图保持严格单向；而在未加载 tp-render 时，下层模块依然可用（钩子为 nil 时优雅降级）。
| 钩子变量 | 声明于 | 安装的实现（tp-render.el） | 用途 |
|----------|--------|---------------------------|------|
| `tp--reactive-update-function` | tp-reactive.el | `tp--reactive-apply-update` | 变量监听器触发的重计算与重渲染 |
| `tp--reactive-flush-function` | tp-reactive.el | `tp--reactive-flush-entry` | 批量更新队列刷新时的重渲染 |
| `tp--layer-refresh-function` | tp-layer.el | `tp--update-layer-regions` | 层重定义后刷新已应用区域 |
| `tp--tp-text-handler-function` | tp-ops.el | `tp--handle-tp-text-property` | `tp-set` 等操作中处理 `tp-text` 属性 |
---
## 函数调用关系图
（标注 `[模块]` 表示函数所在文件；`╌╌▷` 表示经钩子变量的间接调用。）
### tp-set 调用链
```
tp-set
├── tp--parse-args
│ └── tp--resolve-props
tp-set [tp-ops]
├── tp--parse-args [tp-ops]
│ ├── tp--merge-duplicate-keys [tp-core]
│ └── tp--resolve-props [tp-layer]
│ ├── tp-layer-props
│ ├── tp--collect-reactive-symbols
│ ├── tp--resolve-reactive-symbols
│ ├── tp--register-reactive-deps
│ └── tp--build-layer-props (for groups)
├── tp--handle-tp-text-property
└── put-text-property (Emacs 原生)
│ ├── tp--collect-reactive-symbols [tp-core]
│ ├── tp--resolve-reactive-symbols [tp-core]
│ └── tp--register-reactive-deps [tp-reactive]
├── tp--handle-tp-text [tp-ops]
│ ╌╌▷ tp--handle-tp-text-property [tp-render]（经钩子）
├── tp--apply-props-to-string [tp-ops]（整串形式，返回新字符串）
└── set-text-properties / put-text-property（Emacs 原生，区域形式）
```
### tp-add 调用链
```
tp-add
├── tp--parse-args
├── tp--handle-tp-text-property
├── text-properties-at (Emacs 原生)
├── tp--prepend-face
│ └── tp--deep-merge-plist
├── tp--deep-merge-plist
└── put-text-property (Emacs 原生)
tp-add [tp-ops]
├── tp--parse-args [tp-ops]
├── tp--handle-tp-text [tp-ops] ╌╌▷ tp--handle-tp-text-property [tp-render]
├── 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 原生）
```
### define-tp 调用链
```
define-tp
├── tp--parse-define-layer-args
├── tp--collect-reactive-symbols
├── tp--unregister-reactive-deps
│ ├── tp--unregister-layer-watchers
│ ├── tp--unregister-layer-computed
│ └── tp--unregister-layer-data
├── tp--ensure-reactive-variables
├── tp--register-layer-data
├── tp--register-layer-computed
├── tp--apply-initial-computed
├── tp--register-reactive-deps
├── tp--register-layer-watchers
├── tp--resolve-reactive-symbols
├── tp--set-layer-props
└── tp--update-layer-regions
├── tp-layer-props
└── tp-search-map
└── tp-add
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
```
### tp-push-layer 调用链
```
tp-push-layer
└── tp-put-layer
├── tp--normalize-layer-spec
│ └── tp-layer-props
├── tp-group-props
│ └── tp-layer-props
├── tp-empty-p
├── set-text-properties (Emacs 原生)
└── tp-intervals-map
└── tp-intervals
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-build-props [tp-stack]
└── set-text-properties（Emacs 原生）
```
### 响应式更新调用链
```
(setq some-reactive-var new-value)
└── tp--reactive-variable-watcher
├── tp--invoke-layer-watchers
├── tp--update-layer-computed
│ ├── tp--resolve-reactive-symbols
│ └── tp--set-layer-props
├── tp--update-layer-regions (属性更新)
│ └── tp-search-map
│ └── tp-add
└── tp--update-reactive-text (文本替换)
└── tp--replace-reactive-text-in-buffer
└── 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-search-map [tp-search]
│ └── put-text-property
└── tp--update-reactive-text [tp-render]（tp-text 文本替换）
└── tp--replace-reactive-text-in-buffer [tp-render]
批量模式（tp-with-batch-updates）/ 更新中的嵌套写入：
└── tp--queue-batch-update [tp-reactive]（入队，不递归）
└── tp--flush-batch-updates [tp-reactive]（退出批量时）
└── ╌╌▷ tp--reactive-flush-entry [tp-render]（经钩子）
├── tp--update-layer-regions
└── tp--update-reactive-text
```
---
## 设计原则
1. **分层封装**：每层只依赖于下层功能，避免跨层调用
2. **单一职责**：每个函数只做一件事
3. **复用优先**：高层函数应该复用低层函数，避免重复代码
4. **统一接口**：所有核心属性函数支持相同的调用约定
5. **响应式解耦**：响应式系统独立于核心属性操作，可选择性使用
1. **严格分层**：模块只允许 `require` 并调用排在它前面的模块，字节编译器强制检查依赖顺序
2. **钩子反转**：唯一许可的"向上调用"是四个钩子变量（`tp--tp-text-handler-function`、`tp--reactive-update-function`、`tp--reactive-flush-function`、`tp--layer-refresh-function`），由 tp-render.el 统一安装实现
3. **单一职责**：每个模块（和函数）只负责一件事
4. **复用优先**：共享引擎（`tp--map-intervals`、`tp--stack-map-region`、`tp--pattern-apply`、`tp--replace-match-text`）承载重复逻辑，高层函数复用而非复制
5. **统一接口**：所有核心属性函数支持相同的调用约定（整串/区域形式、层名、`$var`）
6. **响应式解耦**：tp-reactive/tp-layer/tp-ops 不依赖渲染引擎；不加载 tp-render 时钩子为 nil，各模块优雅降级

86
docs/CODE-ANALYSIS.md
View File

@ -1,5 +1,12 @@
# 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)。
> 下文的调用堆栈与问题分析保留为历史分析；"文件结构"与"关键代码位置"表已更新为当前模块位置。
本报告旨在帮助想要参与 tp.el 开发的开发者快速了解项目结构、核心功能实现、以及潜在的优化方向。
## 目录
@ -23,7 +30,7 @@
## 项目概述
tp.el 是一个 Emacs Lisp 文本属性操作库，采用 **五层架构设计**：
tp.el 是一个 Emacs Lisp 文本属性操作库，拆分前的单文件版本采用概念上的 **五层架构设计**：
```
┌─────────────────────────────────────────────────────────────────┐
@ -44,15 +51,30 @@ tp.el 是一个 Emacs Lisp 文本属性操作库，采用 **五层架构设计**
└─────────────────────────────────────────────────────────────────┘
```
0.2.0 的模块拆分大体沿用了这一分层思路，并把"响应式系统向上调用高级 API"的
矛盾收拢为 tp-render.el 安装的钩子变量，详见 [ARCHITECTURE.md](ARCHITECTURE.md)。
---
## 文件结构
当前（0.2.0）文件结构：
```
tp/
├── tp.el # 核心代码（4863 行）
├── tp-palette.el # 预定义颜色调色板层（333 行）
├── tp-tests.el # ERT 测试套件（4113 行，100+ 测试用例）
├── tp.el # 总入口，按序加载全部模块（62 行）
├── tp-core.el # 区间遍历、plist/face 合并引擎、调试、$var 工具（781 行）
├── tp-reactive.el # 响应式依赖注册表、变量监听、批量队列（370 行）
├── tp-layer.el # define-tp / define-tps、层注册表与解析（1295 行）
├── tp-ops.el # 核心属性操作 tp-set/get/at/remove/...（916 行）
├── tp-search.el # 模式匹配、搜索与导航（810 行）
├── tp-render.el # 响应式重渲染引擎（501 行）
├── tp-stack.el # 属性层栈操作（709 行）
├── tp-palette.el # 明/暗主题调色板数据（351 行）
├── tp-builtins.el # 内置层与辅助工具（193 行）
├── tp-tests.el # 综合 ERT 测试套件（4123 行，280 个测试）
├── tp-*-tests.el # 各模块回归测试套件（7 个文件，159 个测试；全套共 439 个测试）
├── Makefile # test / compile / clean
├── docs/
│ ├── ARCHITECTURE.md # 架构文档
│ ├── CODE-ANALYSIS.md # 代码分析报告（本文档）
@ -95,21 +117,23 @@ tp-set (用户调用入口)
#### 关键代码位置
| 函数 | 文件位置 | 作用 |
（0.2.0 模块化后按"函数 → 模块文件"定位；文件内具体行号请用 `M-x xref-find-definitions` 查找。）
| 函数 | 模块文件 | 作用 |
|------|----------|------|
| `tp-set` | tp.el:1350 | 主入口函数 |
| `tp--parse-args` | tp.el:1233 | 解析三种调用格式 |
| `tp--resolve-props` | tp.el:3730 | 展开层名称和响应式变量 |
| `tp--handle-tp-text-property` | tp.el:1124 | 处理 tp-text 文本替换 |
| `tp-add` | tp.el:1522 | 深度合并属性 |
| `tp-push-layer` | tp.el:4156 | 推送层到栈顶 |
| `tp-put-layer` | tp.el:4071 | 在指定位置放置层 |
| `define-tp` | tp.el:3154 | 定义自定义层（宏）|
| `define-tps` | tp.el:3448 | 定义层组（宏）|
| `tp--reactive-variable-watcher` | tp.el:713 | 响应式变量监听器回调 |
| `tp--update-layer-regions` | tp.el:993 | 更新使用层的文本区域 |
| `tp-search-map` | tp.el:2918 | 搜索并应用函数 |
| `tp--match-apply` | tp.el:2269 | 模式匹配内部实现 |
| `tp-set` | tp-ops.el | 主入口函数 |
| `tp--parse-args` | tp-ops.el | 解析多种调用格式 |
| `tp--resolve-props` | tp-layer.el | 展开层名称和响应式变量 |
| `tp--handle-tp-text-property` | tp-render.el | 处理 tp-text 文本替换（经钩子 `tp--tp-text-handler-function` 安装到 tp-ops） |
| `tp-add` | tp-ops.el | 深度合并属性 |
| `tp-push-layer` | tp-stack.el | 推送层到栈顶 |
| `tp-put-layer` | tp-stack.el | 在指定位置放置层 |
| `define-tp` | tp-layer.el | 定义自定义层（宏）|
| `define-tps` | tp-layer.el | 定义层组（宏）|
| `tp--reactive-variable-watcher` | tp-reactive.el | 响应式变量监听器回调 |
| `tp--update-layer-regions` | tp-render.el | 更新使用层的文本区域 |
| `tp-search-map` | tp-search.el | 搜索并应用函数 |
| `tp--match-apply` | tp-search.el | 模式匹配内部实现 |
---
@ -683,18 +707,18 @@ tp-layers -> [props1 props2 props3]
(setq tp-debug-mode t)
(setq tp-debug-echo t)
;; 运行测试
;; emacs --batch -l tp.el -l tp-tests.el -f ert-run-tests-batch-and-exit
;; 运行测试（全套 439 个 ERT 测试）
;; make test
```
### 2. 添加新功能的步骤
1. **理解分层架构**
- 确定新功能属于哪一层
- 遵循层间调用规则（只调用下层函数）
- 确定新功能属于哪个模块（见 [ARCHITECTURE.md](ARCHITECTURE.md)）
- 遵循模块间调用规则（只调用前置模块的函数）
2. **编写测试用例**
- 在 `tp-tests.el` 中添加测试
- 在对应模块的 `tp-*-tests.el`（或综合套件 `tp-tests.el`）中添加测试
- 覆盖正常流程和边界情况
3. **实现功能**
@ -731,23 +755,23 @@ tp-reactive-deps
#### 添加新的核心属性函数
1. 在第二层添加函数
1. 在 `tp-ops.el` 添加函数
2. 使用 `tp--parse-args` 解析参数
3. 调用 Emacs 原生 API
4. 添加测试用例
#### 添加新的层操作函数
#### 添加新的层栈操作函数
1. 在第三层添加函数
2. 使用 `tp-intervals-map` 遍历区间
1. 在 `tp-stack.el` 添加函数
2. 使用 `tp--stack-map-region` 遍历区域内层栈
3. 使用 `tp--get-layer-stack` 获取层栈
4. 添加测试用例
#### 扩展响应式系统
1. 在第四层添加函数
1. 注册/监听逻辑放在 `tp-reactive.el`，渲染逻辑放在 `tp-render.el`
2. 使用 `add-variable-watcher` 注册监听
3. 在适当位置调用 `tp--update-layer-regions`
3. 在适当位置调用 `tp--update-layer-regions`（下层模块经钩子变量触发）
4. 添加测试用例
---
@ -775,5 +799,5 @@ tp.el 是一个设计精良的文本属性操作库，其核心创新包括：
---
*报告生成时间: 2026-01-10*
*tp.el 版本: 0.1.0*
*报告生成时间: 2026-01-10（分析对象：拆分前的单文件 tp.el 0.1.0）*
*文件结构与"关键代码位置"表更新于 2026-07-26（tp 0.2.0 模块化后）*

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

@ -10,7 +10,7 @@ The following evaluates and documents the implementation status of six optimizat
**Suggestion**: Support partial updates within a region - only updating the reactive portion while preserving surrounding text properties.
**Evaluation**: Already implemented. tp.el uses `tp-intervals-map` and interval-based update mechanisms to support fine-grained property updates. Updates only affect regions with specific `tp-name` properties.
**Evaluation**: Already implemented. tp.el uses `tp-search-map` over `tp-name`-tagged regions and interval-based update mechanisms to support fine-grained property updates. Updates only affect regions with specific `tp-name` properties, and only the layer's own property keys are replaced — properties contributed by other sources are left untouched.
### 2. Reactive Symbol Cleanup ✅ Already Implemented
@ -192,9 +192,9 @@ Debug mode helps developers understand the reactive update flow:
These optimizations follow tp.el's layered architecture principles:
1. **Debug Mode** - Basic utility layer functionality
2. **Batch Updates** - Implemented in the reactive system layer
3. **Value Transformation** - Implemented in layer definition and reactive text handling
1. **Debug Mode** - Basic utility layer functionality (`tp-core.el`)
2. **Batch Updates** - Implemented in the reactive system layer (`tp-reactive.el`)
3. **Value Transformation** - Implemented in layer definition and reactive text handling (`tp-layer.el` / `tp-render.el`)
All new features integrate seamlessly with the existing reactive system without breaking existing APIs.

8
docs/reactive-optimization.md
View File

@ -10,7 +10,7 @@
**建议**：支持区域内的部分更新，只更新响应式部分，保留周围文本属性。
**评估**：已经实现。tp.el 通过 `tp-intervals-map` 和基于区间的更新机制，已经支持细粒度的属性更新。更新只影响具有特定 `tp-name` 的区域。
**评估**：已经实现。tp.el 通过在带 `tp-name` 标记的区域上使用 `tp-search-map`，以及基于区间的更新机制，已经支持细粒度的属性更新。更新只影响具有特定 `tp-name` 的区域，并且只替换该层自身的属性键——由其他来源贡献的属性保持不变。
### 2. 响应式符号清理（Reactive Symbol Cleanup）✅ 已实现
@ -192,9 +192,9 @@
这些优化遵循 tp.el 的分层架构原则：
1. **调试模式** - 作为基础工具层功能
2. **批量更新** - 在响应式系统层实现
3. **值转换** - 在层定义和响应式文本处理中实现
1. **调试模式** - 作为基础工具层功能（`tp-core.el`）
2. **批量更新** - 在响应式系统层实现（`tp-reactive.el`）
3. **值转换** - 在层定义和响应式文本处理中实现（`tp-layer.el` / `tp-render.el`）
所有新功能都与现有的响应式系统无缝集成，不破坏现有 API。

212
docs/reactive-optimization.sync-conflict-20260318-162447-WX2NETI.md
View File

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

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

@ -395,13 +395,13 @@ The real power of `tp-text` comes from combining it with reactive variables:
(tp-set 1 12 'dynamic-content)
;; Text now shows "Loading..."
(message "Initial text: %s" (buffer-string))
;; => "Loading... "
;; => "Loading..."
;; Change the variable
(setq my-dynamic-text "Data loaded successfully!")
;; Text updates automatically!
(message "After update: %s" (buffer-string)))
;; => "Data loaded successfully! "
;; => "Data loaded successfully!"
```
### Using :compute for Dynamic Text
@ -451,7 +451,7 @@ You can also use reactive `tp-text` directly in property lists without defining
### Important Notes
1. **tp-text only affects buffer text**: For string objects, since Emacs string length is fixed, `tp-text` won't replace string content.
1. **tp-text on strings returns a new string**: Emacs strings cannot change length in place, so string-object calls return a new string instead of modifying the original. A sub-region `tp-text` replaces only that region and keeps the rest of the string; the whole-string form returns just the replacement text.
2. **Preserves existing properties**: When using `tp-set` or `tp-add` to set `tp-text`, existing text properties are preserved.
3. **Non-reactive properties don't add tp-name**: If there are no reactive variables (`$` prefix) in the text properties, `tp-name` and other reactive-specific properties won't be added, maintaining native text property behavior.
@ -466,7 +466,7 @@ The `:transform` keyword allows you to register a transformation function that p
:data '((price . "99.9"))
:transform (lambda (text)
(format "$%.2f" (string-to-number text))))
;; 99.9 displays as $99.00
;; 99.9 displays as $99.90
;; Date formatting
(define-tp date-display ()

507
docs/reactive-text-properties-en.sync-conflict-20260318-162431-WX2NETI.md
View File

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

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

@ -395,13 +395,13 @@ tp.el 的响应式系统借鉴了 Vue 的 API，提供了三个强大的关键
(tp-set 1 12 'dynamic-content)
;; 文本现在显示 "Loading..."
(message "初始文本: %s" (buffer-string))
;; => "Loading... "
;; => "Loading..."
;; 改变变量
(setq my-dynamic-text "数据加载完成!")
;; 文本自动更新！
(message "更新后: %s" (buffer-string)))
;; => "数据加载完成! "
;; => "数据加载完成!"
```
### 使用 :compute 生成动态文本
@ -451,7 +451,7 @@ tp.el 的响应式系统借鉴了 Vue 的 API，提供了三个强大的关键
### 注意事项
1. **tp-text 只影响缓冲区文本**：对于字符串对象，由于 Emacs 字符串长度固定，`tp-text` 不会替换字符串内容。
1. **tp-text 作用于字符串时返回新字符串**：Emacs 字符串长度无法原地改变，因此字符串形式的调用会返回一个新字符串，而不是修改原字符串。子区域的 `tp-text` 只替换该区域并保留字符串的其余部分；整串形式则只返回替换后的文本。
2. **保留现有属性**：使用 `tp-set` 或 `tp-add` 设置 `tp-text` 时，现有的文本属性会被保留。
3. **非响应式属性不添加 tp-name**：如果文本属性中没有响应式变量（`$` 前缀），则不会添加 `tp-name` 等响应式专用属性，保持原生文本属性行为。
@ -466,7 +466,7 @@ tp.el 的响应式系统借鉴了 Vue 的 API，提供了三个强大的关键
:data '((price . "99.9"))
:transform (lambda (text)
(format "$%.2f" (string-to-number text))))
;; 99.9 显示为 $99.00
;; 99.9 显示为 $99.90
;; 日期格式化
(define-tp date-display ()

238
tp-builtins-tests.el Normal file
View File

@ -0,0 +1,238 @@
;;; tp-builtins-tests.el --- ERT tests for tp-builtins.el and tp-palette.el -*- lexical-binding: t -*-
;;; Commentary:
;; Regression tests for the built-in layers, the display buffer
;; macros, and the palette module (tp-builtins.el / tp-palette.el).
;;
;; Run with:
;; emacs --batch -L . -l tp.el -l tp-builtins-tests.el \
;; -f ert-run-tests-batch-and-exit
;;; Code:
(require 'ert)
(require 'tp)
;;; Test helpers
(defmacro tp-builtins-test--with-builtins (&rest body)
"Run BODY ensuring the shipped built-in layers are registered.
Other test files reset `tp-layer-alist' globally; reloading
tp-builtins restores the shipped layer definitions."
(declare (indent defun))
`(progn
(unless (assoc 'tp-link tp-layer-alist)
(load "tp-builtins" nil t))
,@body))
(defmacro tp-builtins-test--with-background-mode (mode &rest body)
"Run BODY with the frame background-mode set to MODE, restoring it after."
(declare (indent 1))
(let ((old (gensym "old-mode-")))
`(let ((,old (frame-parameter nil 'background-mode)))
(unwind-protect
(progn (set-frame-parameter nil 'background-mode ,mode)
,@body)
(set-frame-parameter nil 'background-mode ,old)))))
;;; B45: plistp / subr-x compatibility with Emacs 28.1
(ert-deftest tp-builtins-test-plistp-compat ()
"The `tp-palette--plistp' compat helper mirrors `plistp' semantics."
(should (tp-palette--plistp nil))
(should (tp-palette--plistp '(:a 1)))
(should (tp-palette--plistp '(:a 1 :b 2)))
(should-not (tp-palette--plistp '(:a 1 :b)))
(should-not (tp-palette--plistp "string"))
(should-not (tp-palette--plistp '(:a . 1))))
(ert-deftest tp-builtins-test-palette-pure-suffix-stripping ()
"`tp-palette-pure' strips variant suffixes (needs subr-x loaded)."
(should (eq (tp-palette-pure 'info) 'info))
(should (eq (tp-palette-pure 'info-fg) 'info))
(should (eq (tp-palette-pure 'info-bg) 'info))
(should (eq (tp-palette-pure 'info-fbg) 'info))
(should (eq (tp-palette-pure 'heading-1-border) 'heading-1))
(should-error (tp-palette-pure 'no-such-palette)))
;;; B46: display buffer macros must not mutate shared keymaps
(ert-deftest tp-builtins-test-display-buffer-no-shared-keymap-pollution ()
"Using the display macros must leave the major-mode keymap untouched."
(unwind-protect
(progn
(tp-switch-to-buffer "*tp-builtins-test-display*"
(text-mode)
(insert "hello"))
;; The shared text-mode keymap must NOT have gained a q binding.
(should-not (lookup-key text-mode-map "q"))
(with-current-buffer "*tp-builtins-test-display*"
;; q still quits, via the buffer-local minor mode.
(should (eq (key-binding "q") #'quit-window))
(should tp-display-buffer-mode)
(should buffer-read-only)
(should (equal (buffer-string) "hello"))))
(when (get-buffer "*tp-builtins-test-display*")
(kill-buffer "*tp-builtins-test-display*"))))
(ert-deftest tp-builtins-test-display-buffer-hygienic-binding ()
"BODY must see the user's own `buffer' variable, not a macro capture."
(unwind-protect
(let ((buffer "user-value"))
(tp-switch-to-buffer "*tp-builtins-test-hygiene*"
(insert buffer))
(with-current-buffer "*tp-builtins-test-hygiene*"
(should (equal (buffer-string) "user-value"))))
(when (get-buffer "*tp-builtins-test-hygiene*")
(kill-buffer "*tp-builtins-test-hygiene*"))))
(ert-deftest tp-builtins-test-pop-to-buffer-expansion-hygiene ()
"`tp-pop-to-buffer' expands to a gensym binding, never literal `buffer'."
(let* ((expansion (macroexpand-1 '(tp-pop-to-buffer "b" (ignore))))
(binding-var (caar (nth 1 expansion))))
(should (eq (car expansion) 'let))
(should (symbolp binding-var))
(should-not (eq binding-var 'buffer))))
(ert-deftest tp-builtins-test-display-buffer-reusable ()
"A second invocation erases and refills the (read-only) buffer."
(unwind-protect
(progn
(tp-switch-to-buffer "*tp-builtins-test-reuse*"
(insert "first"))
(tp-switch-to-buffer "*tp-builtins-test-reuse*"
(insert "second"))
(with-current-buffer "*tp-builtins-test-reuse*"
(should (equal (buffer-string) "second"))
(should buffer-read-only)))
(when (get-buffer "*tp-builtins-test-reuse*")
(kill-buffer "*tp-builtins-test-reuse*"))))
(ert-deftest tp-builtins-test-palette-show-smoke ()
"`tp-palette-show' renders the gallery without error."
(tp-builtins-test--with-builtins
(unwind-protect
(progn
(tp-palette-show)
(with-current-buffer "*tp-palette-gallery*"
(should (> (buffer-size) 0))
(should buffer-read-only)))
(when (get-buffer "*tp-palette-gallery*")
(kill-buffer "*tp-palette-gallery*")))))
;;; B47: tp-link resolves its palette color lazily
(ert-deftest tp-builtins-test-link-no-frozen-color ()
"The registered tp-link layer must not contain a baked-in hex color."
(tp-builtins-test--with-builtins
(let ((entry (assoc 'tp-link tp-layer-alist)))
(should entry)
(should-not (string-match-p "#[0-9a-fA-F]" (format "%S" entry))))))
(ert-deftest tp-builtins-test-link-lazy-theme-resolution ()
"tp-link resolves the info color at application time per theme."
(tp-builtins-test--with-builtins
(tp-builtins-test--with-background-mode 'light
(let ((face (get-text-property 0 'face (tp-set "x" 'tp-link t))))
(should (equal (plist-get face :foreground) "#0969da"))
(should (plist-get face :underline))))
(tp-builtins-test--with-background-mode 'dark
(let* ((s (tp-set "x" 'tp-link t))
(face (get-text-property 0 'face s)))
(should (equal (plist-get face :foreground) "#58a6ff"))
(should (plist-get face :underline))
(should (eq (get-text-property 0 'mouse-face s) 'highlight))
(should (eq (get-text-property 0 'pointer s) 'hand))))))
;;; B48: palette redefinition must not go stale
(ert-deftest tp-builtins-test-palette-redefinition-updates-colors ()
"Redefining a palette updates what the color lookups return."
(unwind-protect
(tp-builtins-test--with-background-mode 'light
(define-tp-palette tp-builtins-test-pal
:fg ("#111111" . "#aaaaaa") :bg ("#222222" . "#bbbbbb"))
(should (tp-palette-p 'tp-builtins-test-pal))
(should (equal (tp-palette-fg-color 'tp-builtins-test-pal) "#111111"))
(define-tp-palette tp-builtins-test-pal
:fg ("#333333" . "#cccccc") :bg ("#444444" . "#dddddd"))
(should (equal (tp-palette-fg-color 'tp-builtins-test-pal) "#333333"))
(should (equal (tp-palette-bg-color 'tp-builtins-test-pal) "#444444")))
(setq tp-palette-alist
(assq-delete-all 'tp-builtins-test-pal tp-palette-alist))))
;;; B49: tp-headline accepts integer heights, never emits :height nil
(ert-deftest tp-builtins-test-headline-integer-height ()
"An integer height (absolute, 1/10 pt units) produces a valid face."
(tp-builtins-test--with-builtins
(let ((face (get-text-property 0 'face (tp-set "h" 'tp-headline 120))))
(should (equal (plist-get face :height) 120))
(should (eq (plist-get face :weight) 'bold)))))
(ert-deftest tp-builtins-test-headline-float-height ()
"A float height (scaling factor) keeps its documented behavior."
(tp-builtins-test--with-builtins
(let ((face (get-text-property 0 'face (tp-set "h" 'tp-headline 1.5))))
(should (equal (plist-get face :height) 1.5))
(should (eq (plist-get face :weight) 'bold)))))
(ert-deftest tp-builtins-test-headline-plist-height ()
"A (:height H :bold B) plist is honored."
(tp-builtins-test--with-builtins
(let ((face (get-text-property 0 'face
(tp-set "h" 'tp-headline
'(:height 1.2 :bold nil)))))
(should (equal (plist-get face :height) 1.2))
(should-not (plist-get face :weight)))))
(ert-deftest tp-builtins-test-headline-never-emits-nil-height ()
"A plist without :height must not produce (:height nil)."
(tp-builtins-test--with-builtins
(let ((face (get-text-property 0 'face
(tp-set "h" 'tp-headline '(:bold t)))))
(should-not (plist-member face :height))
(should (eq (plist-get face :weight) 'bold)))))
(ert-deftest tp-builtins-test-headline-invalid-spec-errors ()
"Unsupported tp-headline specs signal an error instead of a no-op."
(tp-builtins-test--with-builtins
(should-error (tp-set "h" 'tp-headline "big"))))
;;; B50: tp-space uses the documented pixel spec
(ert-deftest tp-builtins-test-space-pixel-spec ()
"The shipped tp-space emits (space :width (PIXEL)) as documented."
(tp-builtins-test--with-builtins
;; Other test files redefine tp-space; make sure we exercise the
;; shipped definition.
(load "tp-builtins" nil t)
(should (equal (get-text-property 0 'display (tp-set "emacs" 'tp-space 2))
'(space :width (2))))))
;;; B51: tp-parse-color accepts one-sided cons colors
(ert-deftest tp-builtins-test-parse-color-one-sided-cons ()
"A cons with a nil side means no color for that mode."
(tp-builtins-test--with-background-mode 'light
(should (equal (tp-parse-color '("red" . nil)) "red"))
(should-not (tp-parse-color '(nil . "green"))))
(tp-builtins-test--with-background-mode 'dark
(should-not (tp-parse-color '("red" . nil)))
(should (equal (tp-parse-color '(nil . "green")) "green"))))
(ert-deftest tp-builtins-test-parse-color-existing-forms ()
"Strings, two-sided conses and plists keep their behavior."
(tp-builtins-test--with-background-mode 'light
(should (equal (tp-parse-color "red") "red"))
(should (equal (tp-parse-color '("red" . "green")) "red"))
(should (equal (tp-parse-color '(:light "red" :dark "green")) "red")))
(tp-builtins-test--with-background-mode 'dark
(should (equal (tp-parse-color '("red" . "green")) "green"))
(should (equal (tp-parse-color '(:light "red" :dark "green")) "green")))
(should-not (tp-parse-color nil))
(should-error (tp-parse-color 42)))
(provide 'tp-builtins-tests)
;;; tp-builtins-tests.el ends here

193
tp-builtins.el Normal file
View File

@ -0,0 +1,193 @@
;;; tp-builtins.el --- Built-in layers and display helpers 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:
;; Batteries: the built-in layers (tp-fg, tp-bg, tp-button, tp-link,
;; tp-space, tp-headline, tp-action, ...), the palette gallery command
;; `tp-palette-show', and the read-only display buffer macros.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(require 'tp-layer)
(require 'tp-ops)
(require 'tp-palette)
(defvar tp-display-buffer-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "q" #'quit-window)
map)
"Keymap for `tp-display-buffer-mode'.")
(define-minor-mode tp-display-buffer-mode
"Minor mode enabled in tp read-only display buffers.
It binds \\`q' to `quit-window' in its own buffer-local minor-mode
keymap, leaving the major-mode keymap (which is shared by every
buffer of that major mode) untouched."
:lighter nil
:keymap tp-display-buffer-mode-map)
(eval-and-compile
(defun tp--display-buffer-form (buffer-or-name body display-fn)
"Build the shared expansion of the display-buffer macros.
BUFFER-OR-NAME and BODY are the macro arguments; DISPLAY-FN is
the symbol of the function used to display the populated buffer."
(let ((buffer (gensym "tp-buffer-")))
`(let ((,buffer (get-buffer-create ,buffer-or-name)))
(tp-with-current-buffer ,buffer
(erase-buffer)
,@body
(tp-display-buffer-mode 1)
(read-only-mode 1))
(,display-fn ,buffer)))))
(defmacro tp-pop-to-buffer (buffer-or-name &rest body)
"Show BUFFER-OR-NAME with `pop-to-buffer' after filling it by BODY.
The buffer is created if needed and erased, then BODY runs inside
it with `inhibit-read-only' non-nil. The buffer is finally made
read-only with `tp-display-buffer-mode' enabled, so \\`q' quits
its window."
(declare (indent defun))
(tp--display-buffer-form buffer-or-name body 'pop-to-buffer))
(defmacro tp-switch-to-buffer (buffer-or-name &rest body)
"Show BUFFER-OR-NAME with `switch-to-buffer' after filling it by BODY.
The buffer is created if needed and erased, then BODY runs inside
it with `inhibit-read-only' non-nil. The buffer is finally made
read-only with `tp-display-buffer-mode' enabled, so \\`q' quits
its window."
(declare (indent defun))
(tp--display-buffer-form buffer-or-name body 'switch-to-buffer))
(define-tp tp-palette (palette)
(let* ((pure-palette (tp-palette-pure palette))
(fg-color (tp-palette-fg-color pure-palette))
(bg-color (tp-palette-bg-color pure-palette))
(border-color (tp-palette-border-color pure-palette)))
(pcase palette
((pred tp-palette-p)
`(face (,@(when fg-color (list :foreground fg-color))
,@(when bg-color (list :background bg-color))
,@(when border-color (list :box (list :color border-color))))))
((pred tp-palette-fg-p)
`(face (,@(when fg-color (list :foreground fg-color)))))
((pred tp-palette-bg-p)
`(face (,@(when bg-color (list :background bg-color)))))
((pred tp-palette-fbg-p)
`(face (,@(when fg-color (list :foreground fg-color))
,@(when bg-color (list :background bg-color)))))
((pred tp-palette-border-p)
`(face (,@(when border-color (list :box (list :color border-color))))))
(_ (error "Invalid palette: %S" palette)))))
(defun tp-suffix-symbol (symbol string)
(intern (concat (symbol-name symbol) string)))
;;;###autoload
(defun tp-palette-show ()
(interactive)
(let ((alist (seq-reverse tp-palette-alist)))
(tp-switch-to-buffer "*tp-palette-gallery*"
(insert
"Please set " (tp-set "'tp-palette" 'tp-palette 'code)
" text property with following symbols:\n\n"
(mapconcat
(lambda (item)
(let* ((symbol (car item))
(name (symbol-name symbol)))
(concat (tp-set name 'tp-palette symbol)
" "
(tp-set (concat name "-fg")
'tp-palette
(tp-suffix-symbol symbol "-fg"))
" "
(tp-set (concat name "-bg")
'tp-palette
(tp-suffix-symbol symbol "-bg"))
" "
(tp-set (concat name "-fbg")
'tp-palette
(tp-suffix-symbol symbol "-fbg"))
" "
(tp-set (concat name "-border")
'tp-palette
(tp-suffix-symbol symbol "-border")))))
alist "\n")))))
(define-tp tp-fg (color)
`(face (:foreground ,color)))
(define-tp tp-bg (color)
`(face (:background ,color)))
(define-tp tp-button (type)
(let ((palette (intern
(format "%s%s%s" "button-" (symbol-name type) "-fbg"))))
`( tp-palette ,palette pointer hand
face (:box ( :line-width -1
:style released-button)))))
(define-tp tp-underline (color)
`(face (:underline (:color ,color))))
(define-tp tp-delete (color)
`(face (:strike-through ,color)))
(define-tp tp-link ()
;; No color is resolved here: the body of a zero-arg layer is
;; evaluated once, when this file is loaded, so any color computed
;; here would be frozen forever (wrong after a theme switch, or in a
;; daemon session started before any frame exists). Instead the
;; nested parameterized layer `tp-palette' resolves the info
;; foreground lazily at application time, and `:underline t'
;; underlines with that same foreground color.
'( face (:underline t)
tp-palette info-fg
mouse-face highlight
pointer hand))
(define-tp tp-space (pixel)
`(display (space :width (,pixel))))
(define-tp tp-headline (props)
;; PROPS is either a number - a float scaling factor or an integer
;; absolute height in units of 1/10 pt, both valid face :height
;; values - implying bold, or a (:height H :bold B) plist.
(let (height boldp)
(cond ((numberp props)
(setq height props boldp t))
((tp-palette--plistp props)
(setq height (plist-get props :height)
boldp (plist-get props :bold)))
(t (error "Invalid tp-headline spec: %S" props)))
`(face (,@(when height (list :height height))
,@(when boldp '(:weight bold))))))
(define-tp tp-action (sexp)
;; SEXP is a function or plist
(let (action keys)
(if (functionp sexp)
(progn
(setq action sexp)
(setq keys `(,(kbd "RET") [mouse-1])))
(setq action (plist-get sexp :action))
(setq keys (or (plist-get sexp :keys)
`(,(kbd "RET") [mouse-1]))))
`( keymap ,(let ((keymap (make-sparse-keymap)))
(dolist (key keys)
(define-key keymap key action))
keymap)
rear-nonsticky (keymap))))
(provide 'tp-builtins)
;;; tp-builtins.el ends here

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

@ -0,0 +1,72 @@
;;; tp-core-tests.el --- ERT tests for tp-core.el -*- lexical-binding: t -*-
;;; Commentary:
;; Unit tests for the tp-core foundation module.
;;; Code:
(require 'ert)
(require 'tp-core)
;;; tp--map-intervals
(ert-deftest tp-core-test-map-intervals-string-clips ()
"Intervals extending beyond the range are clipped to it."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 11 'face 'bold str)
(should (equal (tp--map-intervals str 3 7 #'list)
'((3 7 (face bold)))))))
(ert-deftest tp-core-test-map-intervals-string-full ()
"Full-range walk over a string returns each property run."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 5 'face 'bold str)
(should (equal (tp--map-intervals str nil nil #'list)
'((0 5 (face bold)) (5 11 nil))))))
(ert-deftest tp-core-test-map-intervals-single-property ()
"PROPERTY narrows runs to that property and passes its value."
(let ((str (copy-sequence "hello world")))
(put-text-property 0 5 'face 'bold str)
(put-text-property 2 8 'help-echo "tip" str)
(should (equal (tp--map-intervals str nil nil #'list 'face)
'((0 5 bold) (5 11 nil))))))
(ert-deftest tp-core-test-map-intervals-buffer-clips ()
"Buffer walk clips to the requested range with 1-based positions."
(with-temp-buffer
(insert "hello world")
(put-text-property 1 12 'face 'bold)
(should (equal (tp--map-intervals nil 4 8 #'list)
'((4 8 (face bold)))))))
(ert-deftest tp-core-test-map-intervals-buffer-multiple-runs ()
"Multiple runs in a buffer are visited in order, gaps included."
(with-temp-buffer
(insert "hello world")
(put-text-property 1 6 'face 'bold)
(put-text-property 7 12 'face 'italic)
(should (equal (tp--map-intervals nil nil nil #'list 'face)
'((1 6 bold) (6 7 nil) (7 12 italic))))))
(ert-deftest tp-core-test-map-intervals-out-of-range-normalized ()
"Out-of-bounds START/END are clamped, not signaled."
(let ((str (copy-sequence "abc")))
(put-text-property 0 3 'p 1 str)
(should (equal (tp--map-intervals str -5 99 #'list 'p)
'((0 3 1))))))
(ert-deftest tp-core-test-map-intervals-empty-range ()
"An empty range visits nothing."
(let ((str (copy-sequence "abc")))
(should (equal (tp--map-intervals str 1 1 #'list) nil))))
;;; tp-face-properties
(ert-deftest tp-core-test-face-properties ()
"The face-family property list contains the three face properties."
(should (equal tp-face-properties '(face font-lock-face mouse-face))))
(provide 'tp-core-tests)
;;; tp-core-tests.el ends here

781
tp-core.el Normal file
View File

@ -0,0 +1,781 @@
;;; tp-core.el --- Foundation utilities 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:
;; Foundation layer of the tp library. No dependencies on other tp
;; modules. Provides: debug logging, interval/property inspection
;; (`tp-intervals', `tp-plist', `tp-empty-p', `tp-intervals-map'),
;; plist utilities (deep merge, duplicate-key merge, nested access),
;; the face merge engine, pure reactive-symbol ($var) utilities, and
;; small shared helpers.
;;; Code:
(require 'cl-lib)
(require 'dash)
(require 'seq)
(defgroup tp nil
"Group for tp.el text property manipulation."
:prefix "tp-"
:group 'development)
(defvar tp--anonymous-layer-counter 0
"Counter for generating unique anonymous layer names.")
(defcustom tp-debug-mode nil
"When non-nil, enable debug logging for reactive updates.
Debug messages are logged to the *tp-debug* buffer and optionally
displayed in the minibuffer based on `tp-debug-echo' setting."
:type 'boolean
:group 'tp)
(defcustom tp-debug-echo nil
"When non-nil and `tp-debug-mode' is enabled, also echo debug messages.
If nil, debug messages are only logged to the *tp-debug* buffer."
:type 'boolean
:group 'tp)
(defconst tp--builtin-text-properties
'(;; Display and appearance
face font-lock-face mouse-face display invisible intangible
;; Interaction and help
help-echo cursor keymap local-map pointer
;; Stickiness
front-sticky rear-nonsticky
;; Text modification
read-only insert-in-front-hooks insert-behind-hooks
modification-hooks point-entered point-left
;; Font and composition
fontified composition hard cursor-intangible
;; Line properties
line-height line-spacing wrap-prefix line-prefix
;; Field and input
field inhibit-line-move-field-capture
;; Button and widget
button category follow-link action
;; Syntax and parsing
syntax-table
;; Misc
yank-handler auto-composed evaporate face-alias)
"List of built-in Emacs text property names.
These property names are reserved and cannot be used as layer names in `define-tp'.
An error is signaled at macro expansion time (when the `define-tp' form is
evaluated) if a reserved name is used, preventing the layer definition from
being created.")
(defun tp--builtin-text-property-p (name)
"Return non-nil if NAME is a built-in text property name.
NAME should be a symbol."
(memq name tp--builtin-text-properties))
(defconst tp-face-properties '(face font-lock-face mouse-face)
"Text properties whose values follow face merging semantics.
These properties hold face specs (symbols, plists or lists thereof)
and are merged with face-aware logic instead of plain replacement.")
(defun tp-debug-log (format-string &rest args)
"Log a debug message if `tp-debug-mode' is enabled.
FORMAT-STRING and ARGS are passed to `format'."
(when tp-debug-mode
(let ((msg (apply #'format format-string args))
(timestamp (format-time-string "%H:%M:%S.%3N")))
(with-current-buffer (get-buffer-create "*tp-debug*")
(goto-char (point-max))
(insert (format "[%s] %s\n" timestamp msg)))
(when tp-debug-echo
(message "[tp] %s" msg)))))
(defun tp-debug-clear ()
"Clear the *tp-debug* buffer."
(interactive)
(when-let ((buf (get-buffer "*tp-debug*")))
(with-current-buffer buf
(erase-buffer))))
(defun tp-debug-show ()
"Show the *tp-debug* buffer."
(interactive)
(pop-to-buffer (get-buffer-create "*tp-debug*")))
(defun tp--generate-anonymous-layer-name ()
"Generate a unique symbol for anonymous reactive layers."
(setq tp--anonymous-layer-counter (1+ tp--anonymous-layer-counter))
(intern (format "tp-anon-%d" tp--anonymous-layer-counter)))
(defmacro tp-with-current-buffer (buffer-or-name &rest body)
"Execute BODY in BUFFER-OR-NAME with `inhibit-read-only' bound to t."
(declare (indent defun))
`(with-current-buffer ,buffer-or-name
(let ((inhibit-read-only t))
,@body)))
(defun tp-intervals (start end &optional object)
"Return list of property intervals from START to END in OBJECT.
Each element is (START END PROPERTIES). OBJECT defaults to current buffer.
For buffers, returns positions relative to START (0-based offsets).
For strings, returns absolute positions.
Intervals that extend beyond the requested range are clipped to it, so
returned positions never fall outside [START, END)."
(let* ((intervals (object-intervals (or object (current-buffer))))
;; For buffers, object-intervals returns 0-based positions
;; but buffer positions are 1-based, so we need to adjust
(offset (if (stringp object) 0 (1- start)))
;; Filter bounds in 0-based terms for buffers
(filter-start (if (stringp object) start offset))
(filter-end (if (stringp object) end (1- end))))
(mapcar (lambda (tp)
(let* ((tp-start (- (max (nth 0 tp) filter-start) offset))
(tp-end (- (min (nth 1 tp) filter-end) offset))
(tp-props (nth 2 tp)))
(list tp-start tp-end tp-props)))
(seq-filter (lambda (tp)
(and (< (nth 0 tp) filter-end)
(> (nth 1 tp) filter-start)))
intervals))))
(defun tp-empty-p (&optional object)
"Return t if OBJECT has no text properties.
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."
(let (start-pos end-pos obj)
(if (stringp start-or-string)
(setq start-pos 0
end-pos (length start-or-string)
obj start-or-string)
(setq start-pos start-or-string
end-pos end
obj object))
(let ((result nil))
(dolist (interval (tp-intervals start-pos end-pos obj))
(let ((props (nth 2 interval)))
(cl-loop for (key val) on props by #'cddr
do (setq result (plist-put result key val)))))
result)))
(defun tp--deep-merge-plist (base new)
"Deep merge NEW plist into BASE plist.
For nested plists (starting with keyword), recursively merge.
NEW values override BASE values."
(let ((result (copy-sequence base)))
(cl-loop
for (key val) on new by #'cddr
do (let ((base-val (plist-get result key)))
(setq result
(plist-put
result key
(cond
;; Both are plists - recursively merge
((and (listp val) (keywordp (car-safe val))
(listp base-val) (keywordp (car-safe base-val)))
(tp--deep-merge-plist base-val val))
;; Otherwise use new value
(t val))))))
result))
(defun tp--string-has-properties-p (str)
"Return non-nil if string STR has any text properties.
Scans the entire string, not just position 0."
(and (stringp str)
(not (null (object-intervals str)))))
(defun tp--equal-including-string-properties (a b)
"Compare A and B for equality, considering string text properties.
If both A and B are strings, uses `equal-including-properties' to ensure
text properties are considered in the comparison.
Otherwise, uses standard `equal'."
(if (and (stringp a) (stringp b))
(equal-including-properties a b)
(equal a b)))
(defun tp--parse-face-list (face-list)
"Parse a mixed face list into symbols and a plist.
FACE-LIST can be a mix of:
- Face symbols (like bold, italic)
- Face plists (like (:foreground \"red\"))
- Inline plist keys and values (like bold :foreground \"green\")
Returns (SYMBOLS . PLIST) where SYMBOLS is a list of face symbols
and PLIST is the merged plist of all face attributes."
(let ((symbols nil)
(plist nil)
(i 0)
(len (length face-list)))
(while (< i len)
(let ((elem (nth i face-list)))
(cond
;; Nested plist like (:foreground "red")
((and (listp elem) (keywordp (car-safe elem)))
(setq plist (if plist (tp--deep-merge-plist plist elem) elem))
(setq i (1+ i)))
;; Inline keyword - consume key and value
((keywordp elem)
(if (< (1+ i) len)
(let ((key elem)
(val (nth (1+ i) face-list)))
(setq plist (if plist
(plist-put plist key val)
(list key val)))
(setq i (+ i 2)))
;; Trailing bare keyword with no value: malformed input.
;; Ignore it rather than inventing a bogus (KEY nil) pair.
(setq i (1+ i))))
;; Face symbol
((symbolp elem)
(push elem symbols)
(setq i (1+ i)))
;; Something else - skip
(t (setq i (1+ i))))))
(cons (nreverse symbols) plist)))
(defun tp--remove-sub-from-face-value (face-value sub-key)
"Remove SUB-KEY from FACE-VALUE, handling complex face structures.
FACE-VALUE can be:
- A simple plist like (:foreground \"red\" :background \"blue\")
- A symbol like bold
- A mixed list like ((:foreground \"red\") (:strike-through t) bold)
Returns the modified face value with SUB-KEY removed from any plist components.
Returns nil if the result would be empty."
(cond
;; Nil face - nothing to remove
((null face-value) nil)
;; Symbol face - no sub-key to remove
((symbolp face-value) face-value)
;; Simple plist - remove the sub-key directly
((and (listp face-value) (keywordp (car-safe face-value)))
(let ((result nil))
(cl-loop for (k v) on face-value by #'cddr
unless (eq k sub-key)
do (setq result (plist-put result k v)))
result))
;; Mixed list - parse and remove from plist component
((listp face-value)
(let* ((parsed (tp--parse-face-list face-value))
(symbols (car parsed))
(plist (cdr parsed)))
(when plist
;; Remove sub-key from the merged plist
(let ((new-plist nil))
(cl-loop for (k v) on plist by #'cddr
unless (eq k sub-key)
do (setq new-plist (plist-put new-plist k v)))
(setq plist new-plist)))
;; Reconstruct the face value
(cond
((and symbols plist) (append symbols (list plist)))
(symbols (if (= (length symbols) 1) (car symbols) symbols))
(plist plist)
(t nil))))
;; Unknown format - return as-is
(t face-value)))
(defun tp--subtract-face-from-face-value (face-value face-to-remove)
"Remove FACE-TO-REMOVE from FACE-VALUE.
FACE-TO-REMOVE is the face contribution to subtract (from a layer).
FACE-VALUE is the current combined face value.
Returns the modified face value with the layer's face contribution removed."
(cond
;; Nothing to remove from
((null face-value) nil)
;; If face-to-remove is nil, return as-is
((null face-to-remove) face-value)
;; If they're equal, remove entirely
((equal face-value face-to-remove) nil)
;; face-to-remove is a plist - remove those keys from face-value
((and (listp face-to-remove) (keywordp (car-safe face-to-remove)))
(let ((keys-to-remove (cl-loop for (k _v) on face-to-remove by #'cddr
collect k)))
;; Remove each key
(dolist (key keys-to-remove)
(setq face-value (tp--remove-sub-from-face-value face-value key)))
face-value))
;; face-to-remove is a symbol - remove it from face-value
((symbolp face-to-remove)
(cond
((eq face-value face-to-remove) nil)
((and (listp face-value) (not (keywordp (car-safe face-value))))
(let ((result (remove face-to-remove face-value)))
(if (= (length result) 1) (car result) result)))
(t face-value)))
;; face-to-remove is a list - remove each element
((listp face-to-remove)
(dolist (elem face-to-remove)
(setq face-value (tp--subtract-face-from-face-value face-value elem)))
face-value)
;; Unknown - return as-is
(t face-value)))
(defun tp--merge-string-props-into-plist (str props)
"Merge text properties from string STR into PROPS plist.
Properties from PROPS take precedence over those in STR.
Returns the merged plist where new props override embedded props.
For simplicity, only considers properties at position 0 of STR."
(if (not (tp--string-has-properties-p str))
props
(let ((str-props (text-properties-at 0 str))
(result (copy-sequence props)))
;; Merge each property from the string into result
;; Props values take precedence over embedded string values
(cl-loop for (key val) on str-props by #'cddr
do (let ((existing (plist-get result key)))
(if existing
;; Props already has this key - merge with props taking precedence
(setq result
(plist-put result key
(cond
;; Face properties need special merging
;; Pass embedded val as face1 (base), existing as face2 (override)
((memq key tp-face-properties)
(tp--merge-face-values val existing))
;; Other properties - props value takes precedence
(t existing))))
;; Props doesn't have this key - add from string
(setq result (plist-put result key val)))))
result)))
(defun tp--merge-face-values (face1 face2)
"Merge two face values into one.
FACE1 is the earlier value, FACE2 is the later value.
For face plists (like (:foreground \"red\")), merge with later overriding.
For symbol faces, create a list with FACE2 taking precedence.
Returns the merged face value.
Role: this is the merge engine for face values that arrive together in
a SINGLE call's property spec - `tp--merge-duplicate-keys' reduces
repeated face/font-lock-face/mouse-face keys through it, and
`tp--merge-string-props-into-plist' uses it to fold a string's embedded
face into caller props. Argument order is (EARLIER LATER); LATER wins.
Note: `tp--prepend-face' is a sibling engine used by `tp-add' to merge
an INCOMING face value into one already present on the text. Its
argument order is swapped ((NEW EXISTING)), and the two engines have
drifted for mixed lists: `tp--prepend-face' parses a mixed
symbol/plist list and merges plist components, whereas this function
conses a plist override onto a non-plist list without parsing. Do not
substitute one for the other without checking those cases."
(cond
;; No earlier face - just use later face
((null face1) face2)
;; No later face - just use earlier face
((null face2) face1)
;; Both are plists - merge with later overriding earlier
((and (listp face1) (keywordp (car-safe face1))
(listp face2) (keywordp (car-safe face2)))
(tp--deep-merge-plist face1 face2))
;; Later is a plist, earlier is a symbol or list of faces
((and (listp face2) (keywordp (car-safe face2)))
(cond
((symbolp face1)
(list face2 face1))
((listp face1)
(cons face2 face1))
(t face2)))
;; Earlier is a plist, later is a symbol
((and (listp face1) (keywordp (car-safe face1))
(symbolp face2))
(list face2 face1))
;; Later is a symbol - prepend to earlier
((symbolp face2)
(cond
((symbolp face1)
(if (eq face1 face2)
face2
(list face2 face1)))
((listp face1)
(if (member face2 face1)
(cons face2 (remove face2 face1)) ; Move to front
(cons face2 face1)))
(t face2)))
;; Later is a list of faces - prepend to earlier
((listp face2)
(cond
((symbolp face1)
(if (member face1 face2)
face2
(append face2 (list face1))))
;; face1 is a plist - need to merge any plist in face2 with face1
((and (listp face1) (keywordp (car-safe face1)))
;; Use tp--parse-face-list to handle mixed formats like (bold :foreground "green")
(let* ((parsed (tp--parse-face-list face2))
(symbols (car parsed))
(plist (cdr parsed)))
;; Merge face2's plist with face1, then prepend symbols
(let ((merged-plist (if plist (tp--deep-merge-plist face1 plist) face1)))
(if symbols
(append symbols (list merged-plist))
merged-plist))))
;; Both are lists - parse both, merge plists, combine symbols
((listp face1)
(let* ((parsed1 (tp--parse-face-list face1))
(symbols1 (car parsed1))
(plist1 (cdr parsed1))
(parsed2 (tp--parse-face-list face2))
(symbols2 (car parsed2))
(plist2 (cdr parsed2))
;; Merge plists with face2's plist taking precedence
(merged-plist (cond
((and plist1 plist2) (tp--deep-merge-plist plist1 plist2))
(plist2 plist2)
(plist1 plist1)
(t nil)))
;; Combine symbols: face2 symbols first, then face1 symbols not in face2
(merged-symbols (append symbols2
(cl-remove-if (lambda (s) (member s symbols2)) symbols1))))
;; Build result: symbols first, then merged plist if any
(if merged-plist
(append merged-symbols (list merged-plist))
merged-symbols)))
(t face2)))
(t face2)))
(defun tp--merge-duplicate-keys (plist)
"Merge duplicate keys in PLIST into a single key-value pair.
For `face' and `font-lock-face' properties, values are merged so that
later values take precedence over earlier ones for the same sub-properties.
For other properties, later values override earlier ones.
This function is designed for single-call property setting where multiple
properties of the same type can be specified and should be merged.
Example:
(tp--merge-duplicate-keys \\='(face bold face (:foreground \"red\")))
=> (face ((:foreground \"red\") bold))
(tp--merge-duplicate-keys \\='(face (:background \"blue\") face (:foreground \"red\")))
=> (face (:background \"blue\" :foreground \"red\"))
(tp--merge-duplicate-keys \\='(prop1 a prop2 b prop1 c))
=> (prop1 c prop2 b)"
(let ((key-values (make-hash-table :test 'eq))
(key-order nil))
;; Collect all values for each key in order
(cl-loop for (key val) on plist by #'cddr
do (progn
(unless (gethash key key-values)
(push key key-order))
(puthash key
(cons val (gethash key key-values))
key-values)))
;; Reverse key-order to get original order
(setq key-order (nreverse key-order))
;; Build result plist by merging values for each key
(let ((result nil))
(dolist (key key-order)
(let ((values (nreverse (gethash key key-values)))) ; Reverse to get original order
(if (= (length values) 1)
;; Single value - use as-is
(setq result (append result (list key (car values))))
;; Multiple values - merge them
(let ((merged-val
(cond
;; Face properties - use special face merging
((memq key tp-face-properties)
(cl-reduce #'tp--merge-face-values values))
;; Other properties - later overrides earlier
(t (car (last values))))))
(setq result (append result (list key merged-val)))))))
result)))
(defun tp--get-nested (value path)
"Get nested value from VALUE following PATH (list of keys).
Supports plists, alists, and list-of-keys extraction."
(if (null path)
value
(let* ((key (car path))
(rest (cdr path))
(is-plist-like (and (listp value)
(or (keywordp (car value))
(and (symbolp (car value))
(cdr value)
(keywordp (cadr value))))))
(next-value
(cond
;; Key is a list - extract multiple keys
((and (listp key) (not (null key)))
(when is-plist-like
(let ((result nil)
(plist-part (if (keywordp (car value)) value (cdr value))))
(dolist (k key)
(let ((v (plist-get plist-part k)))
(when v (setq result (plist-put result k v)))))
result)))
;; Value is plist-like
(is-plist-like
(plist-get (if (keywordp (car value)) value (cdr value)) key))
;; Value is alist
((and (listp value) (consp (car value)))
(cdr (assoc key value)))
;; Other list types
((listp value)
(or (plist-get value key)
(cdr (assoc key value))
(cl-loop for spec in value
when (and (listp spec) (eq (car spec) key))
return (if (= (length (cdr spec)) 1) (cadr spec) (cdr spec))
when (and (listp spec) (keywordp (car spec)))
thereis (plist-get spec key))))
(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.
Examples:
(tp--prepend-face \\='shadow \\='bold) => (shadow bold)
(tp--prepend-face \\='shadow \\='(bold italic)) => (shadow bold italic)
(tp--prepend-face \\='(:foreground \"red\") \\='(:background \"blue\"))
=> (:background \"blue\" :foreground \"red\") ; merged plist
If NEW-FACE is a plist (like (:foreground \"red\")), deeply merge it.
If NEW-FACE is a symbol or list of faces, prepend it to create a face list.
For mixed lists containing both symbols and plists, plists are merged correctly.
Duplicate faces are not added.
Role: this is the merge engine `tp-add' uses to fold an INCOMING face
value into the face value already present on the text, for every
property in `tp-face-properties'. Argument order is (NEW EXISTING);
NEW wins.
Note: `tp--merge-face-values' is a sibling engine (argument order
swapped: (EARLIER LATER)) used when duplicate face keys appear within
a single call's property spec. The two have drifted for mixed
symbol/plist lists - this function parses such lists and merges their
plist components, `tp--merge-face-values' conses a plist override onto
a non-plist list without parsing. Do not substitute one for the other
without checking those cases."
(cond
;; No existing face - just use new face
((null existing-face) new-face)
;; New face is a plist - deep merge with existing
((and (listp new-face) (keywordp (car-safe new-face)))
(cond
((and (listp existing-face) (keywordp (car-safe existing-face)))
(tp--deep-merge-plist existing-face new-face))
;; Existing is a symbol or list of faces - wrap new plist and prepend
((symbolp existing-face)
(list new-face existing-face))
((listp existing-face)
;; Parse existing to extract any plists and merge them
(let* ((parsed (tp--parse-face-list existing-face))
(existing-symbols (car parsed))
(existing-plist (cdr parsed)))
(if existing-plist
;; Merge new-face plist with existing plist, prepend symbols
(let ((merged-plist (tp--deep-merge-plist existing-plist new-face)))
(if existing-symbols
(append existing-symbols (list merged-plist))
merged-plist))
(cons new-face existing-face))))
(t new-face)))
;; New face is a symbol - prepend to existing
((symbolp new-face)
(cond
((symbolp existing-face)
(if (eq new-face existing-face)
new-face
(list new-face existing-face)))
((listp existing-face)
(if (member new-face existing-face)
existing-face
(cons new-face existing-face)))
(t new-face)))
;; New face is a list of faces - parse and merge with existing
((listp new-face)
(cond
((symbolp existing-face)
(if (member existing-face new-face)
new-face
(append new-face (list existing-face))))
((listp existing-face)
;; Parse both to extract symbols and plists, then merge appropriately
(let* ((parsed-new (tp--parse-face-list new-face))
(new-symbols (car parsed-new))
(new-plist (cdr parsed-new))
(parsed-existing (tp--parse-face-list existing-face))
(existing-symbols (car parsed-existing))
(existing-plist (cdr parsed-existing))
;; Merge plists with new taking precedence
(merged-plist (cond
((and existing-plist new-plist)
(tp--deep-merge-plist existing-plist new-plist))
(new-plist new-plist)
(existing-plist existing-plist)
(t nil)))
;; Combine symbols: new symbols first, then existing symbols not in new
(merged-symbols (append new-symbols
(cl-remove-if (lambda (s) (member s new-symbols))
existing-symbols))))
;; Build result: symbols first, then merged plist if any
(if merged-plist
(append merged-symbols (list merged-plist))
merged-symbols)))
(t new-face)))
(t new-face)))
(defun tp--map-intervals (object start end function &optional property)
"Iterate property intervals of OBJECT between START and END, clipped.
OBJECT is a string, a buffer, or nil for the current buffer.
FUNCTION is called with (ISTART IEND VALUE) for each interval, where
ISTART/IEND are clipped to the [START, END) range and expressed in
OBJECT's native coordinates (0-based for strings, 1-based for
buffers). START and END may be nil, meaning the object's bounds.
When PROPERTY is nil, intervals are maximal runs with an identical
full property list and VALUE is that plist. When PROPERTY is
non-nil, intervals are maximal runs of `eq' values of that single
property and VALUE is the property's value (which may be nil).
Unlike `tp-intervals', intervals that extend beyond the requested
range are clipped to it, so FUNCTION never sees positions outside
\[START, END). Returns the list of FUNCTION's return values, in
order."
(let* ((is-string (stringp object))
(buf (unless is-string (or object (current-buffer)))))
(if is-string
(let* ((min-pos 0)
(max-pos (length object))
(from (max (or start min-pos) min-pos))
(to (min (or end max-pos) max-pos))
(pos from)
(results nil))
(while (< pos to)
(let ((next (if property
(or (next-single-property-change
pos property object to)
to)
(or (next-property-change pos object to) to)))
(val (if property
(get-text-property pos property object)
(text-properties-at pos object))))
(push (funcall function pos next val) results)
(setq pos next)))
(nreverse results))
(with-current-buffer buf
(let* ((from (max (or start (point-min)) (point-min)))
(to (min (or end (point-max)) (point-max)))
(pos from)
(results nil))
(while (< pos to)
(let ((next (if property
(or (next-single-property-change pos property nil to)
to)
(or (next-property-change pos nil to) to)))
(val (if property
(get-text-property pos property)
(text-properties-at pos))))
(push (funcall function pos next val) results)
(setq pos next)))
(nreverse results))))))
(defun tp-intervals-map (function start end &optional object)
"Apply FUNCTION to all intervals between START and END in OBJECT.
FUNCTION receives (i-start i-end top-props below-props-lst)."
(remove
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 (-elem-index 'tp-layers interval-props)))
(-remove-at-indices (list idx (1+ idx)) interval-props)
interval-props))
(below-props-lst (plist-get interval-props 'tp-layers)))
(funcall function
interval-start interval-end
top-props below-props-lst)))
(tp-intervals start end object))))
(provide 'tp-core)
;;; tp-core.el ends here

554
tp-doctest.el Normal file
View File

@ -0,0 +1,554 @@
;;; tp-doctest.el --- executable README examples -*- lexical-binding: t -*-
;; Copyright (C) 2024-2026 Geekinney
;; Author: Geekinney (kinneyzhang666@gmail.com)
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;;; Commentary:
;; Executable documentation tests: each assertion reproduces an example
;; from README.md / README_CN.md (the code blocks are identical across
;; the two files) and compares the result against the exact output the
;; docs claim. Run with `make doctest'; the batch process exits
;; non-zero if any assertion fails. When changing a README example,
;; update the matching assertion here in the same commit.
;;; Code:
(require 'tp)
(tp-layer-reset)
(defvar fails 0)
(defvar total 0)
(defmacro chk (label expected &rest body)
`(let* ((exp ,expected)
(got (condition-case err (progn ,@body) (error (list :ERROR err)))))
(setq total (1+ total))
(if (equal got exp)
(princ (format "PASS %s\n" ,label))
(setq fails (1+ fails))
(princ (format "FAIL %s\n expected: %S\n got: %S\n" ,label exp got)))))
(defmacro chk-str (label expected &rest body)
"Compare prin1 form (covers propertized strings)."
`(chk ,label ,expected (prin1-to-string (progn ,@body))))
;; ---- Quick Start ----
(chk-str "QS-set" "#(\"hello\" 0 5 (face bold))" (tp-set "hello" 'face 'bold))
(chk "QS-layer" 'spotlight
(progn
(define-tp spotlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 6 'spotlight)
(tp-layer-top 1 6))))
(defvar accent-color "red")
(chk "QS-reactive" '(:foreground "blue")
(progn
(define-tp accent ()
:props '(face (:foreground $accent-color)))
(with-temp-buffer
(insert "Hello")
(tp-push-layer 1 6 'accent)
(setq accent-color "blue")
(tp-at 1 'face))))
;; ---- Features ----
(chk "F-getstyle" '((0 5 wave))
(let ((str (copy-sequence "Hello World")))
(tp-set 0 5 '(face (:underline (:color "green" :style wave))) str)
(tp-get str 'face :underline :style)))
(chk "F-getmulti" '((0 5 (:color "green" :style wave)))
(let ((str (copy-sequence "Hello World")))
(tp-set 0 5 '(face (:underline (:color "green" :style wave))) str)
(tp-get str 'face :underline '(:color :style))))
(chk "F-dupface" '((:foreground "red") (:background "green") bold)
(tp-at 0 'face (tp-set "emacs"
'face 'bold
'face '(:background "green")
'face '(:foreground "red"))))
(chk "F-override" '(:foreground "yellow")
(tp-at 0 'face (tp-set "emacs"
'face '(:foreground "red")
'face '(:foreground "yellow"))))
(chk "F-search" '((0 5 t) (12 17 t))
(let ((my-string (copy-sequence "Hello World Hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-search my-string 'marker)))
(chk "F-searchmap" "HELLO world HELLO"
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-search-map #'upcase 'marker nil my-string)
(substring-no-properties my-string)))
(chk "F-teaser-fullname" '(help-echo "John Doe" face (:foreground "purple") tp-name full-name-layer)
(progn
(define-tp full-name-layer ()
:props '(help-echo $full-name face (:foreground $name-color))
:data '((first-name . "John") (last-name . "Doe") (name-color . "purple"))
:compute '((full-name (lambda () (concat first-name " " last-name))))
:watch '((first-name (lambda (new old layer)
(message "Name changed from %s to %s" old new)))))
(tp-layer-props 'full-name-layer)))
;; ---- tp-set my-style ----
(chk-str "S-mystyle" "#(\" \" 0 1 (face (:foreground \"blue\") tp-name my-style))"
(progn
(define-tp my-style ()
:props '(face (:foreground $my-color))
:data '((my-color . "blue")))
(tp-set " " 'my-style)))
;; ---- tp-member ----
(chk "M-member-str" '((face nil) nil)
(let ((str (copy-sequence "Hello")))
(tp-set 0 5 '(face nil) str)
(list (tp-member 0 'face str)
(tp-member 0 'display str))))
(chk "M-member-buf" '(face bold)
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 '(face bold))
(tp-member 1 'face)))
;; ---- tp-remove nested ----
(chk "R-remove-nested" '(:color "blue")
(let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue")))))
(let ((result (tp-remove original 'face :underline '(:style))))
(tp-at 0 '(face :underline) result))))
;; ---- tp-forward / tp-backward ----
(chk "N-fwd-t" 7
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char 1)
(let ((match (tp-forward 'marker t)))
(when match (prop-match-beginning match)))))
(chk "N-fwd-nil" '(1 7)
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char 1)
(let ((match (tp-forward 'marker)))
(list (prop-match-beginning match) (prop-match-end match)))))
(chk "N-bwd-t" '(7 12)
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char (point-max))
(let ((match (tp-backward 'marker t)))
(list (prop-match-beginning match) (prop-match-end match)))))
(chk "N-fwd-heading" 'heading
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(type heading))
(goto-char 1)
(let ((match (tp-forward 'type 'heading)))
(when match (prop-match-value match)))))
(chk "N-fwd-string" '((0 5 t) (12 17 t))
(let ((my-string (copy-sequence "Hello World Hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-forward 'marker nil my-string 2)))
;; ---- tp-forward-do / tp-search-map examples ----
(chk "DO-fdo" "hello world HELLO"
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-forward-do #'upcase 'marker nil my-string 2)
(substring-no-properties my-string)))
(chk "DO-bdo" "HELLO world hello"
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-backward-do #'upcase 'marker nil my-string 2)
(substring-no-properties my-string)))
(chk "DO-fdo-pos" '("hello world HELLO" (12 17))
(let ((my-string (copy-sequence "hello world hello"))
(match-info nil))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-forward-do
(lambda (text start end)
(setq match-info (list start end))
(upcase text))
'marker nil my-string 2)
(list (substring-no-properties my-string) match-info)))
(chk "SM-idx" '("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11)))
(let ((my-string (copy-sequence "aaa bbb ccc"))
(positions nil))
(tp-set 0 3 '(marker t) my-string)
(tp-set 4 7 '(marker t) my-string)
(tp-set 8 11 '(marker t) my-string)
(tp-search-map
(lambda (text start end idx)
(push (list idx start end) positions)
(upcase text))
'marker nil my-string)
(list (substring-no-properties my-string) (nreverse positions))))
;; ---- Layer definitions ----
(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)))
(chk-str "L-paramgroup"
"#(\"emacs\" 0 5 (face (:foreground \"orange\") tp-name tp-test-l1 tp-layers ((face (:foreground \"red\") tp-name tp-test-l2) (face (:background \"green\") tp-name tp-test-l3))))"
(progn
(tp-layer-reset)
(define-tp tp-test-l1 (color)
`(face (:foreground ,color)))
(define-tp tp-test-l2 (color)
`(face (:foreground ,color)))
(define-tp tp-test-l3 ()
'(face (:background "green")))
(define-tps tp-test-group1 (color)
`(tp-test-l1 ,color)
'(tp-test-l2 "red")
'tp-test-l3)
(tp-set "emacs" 'tp-test-group1 "orange")))
(chk "L-props" '((face bold help-echo "tip")
(face bold help-echo "tip" tp-name my-layer))
(progn
(tp-layer-reset)
(define-tp my-layer ()
'(face bold help-echo "tip"))
(list (tp-layer-props 'my-layer)
(tp-layer-props 'my-layer t))))
(chk "L-groupprops" 2
(progn
(tp-layer-reset)
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(define-tps my-group ()
'layer1 'layer2)
(length (tp-group-props 'my-group))))
(chk "L-undeflayer" nil
(progn
(tp-layer-reset)
(define-tp temp-layer () '(face bold))
(tp-undefine-layer 'temp-layer)
(tp-layer-props 'temp-layer)))
(chk "L-undefgroup" nil
(progn
(tp-layer-reset)
(define-tp l1 () '(face bold))
(define-tps my-group ()
'l1)
(tp-undefine-group 'my-group)
(assoc 'my-group tp-layer-groups)))
(chk "L-reset" '(nil nil)
(progn
(define-tp test-layer () '(face bold))
(tp-layer-reset)
(list tp-layer-alist tp-layer-groups)))
(defvar my-reactive-color "red")
(chk "L-reactivereset" '(face (:foreground "red"))
(progn
(tp-layer-reset)
(define-tp reactive-layer ()
:props '(face (:foreground $my-reactive-color)))
(tp-reactive-reset)
(tp-layer-props 'reactive-layer)))
;; ---- tp-put-layer / tp-push-layer ----
(chk "P-base" 'base
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 'base 0)
(tp-at 1 'tp-name))))
(chk "P-idx1" 2
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 'base 0)
(tp-put-layer 1 10 'highlight 1)
(tp-layer-count 1 10))))
(chk "P-bottom" 'base
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp info () '(face (:foreground "blue")))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 'base 0)
(tp-put-layer 1 10 'info -1)
(tp-layer-top 1 10))))
(chk "P-inline" '(bold "tip")
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 '(face bold help-echo "tip") 0)
(list (tp-at 1 'face) (tp-at 1 'help-echo))))
(chk "P-names" '(bold (layer-a layer-b))
(progn
(tp-layer-reset)
(define-tp layer-a () '(face bold))
(define-tp layer-b () '(face italic))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 '(layer-a layer-b) 0)
(list (tp-at 1 'face) (tp-layer-list 1 10)))))
(chk "P-param" '(:foreground "red")
(progn
(tp-layer-reset)
(define-tp tp-color (color)
`(face (:foreground ,color)))
(with-temp-buffer
(insert "Hello World")
(tp-put-layer 1 10 '(tp-color "red") 0)
(tp-at 1 'face))))
(chk "P-stack" '(:face (:background "yellow") :top highlight :layers (highlight base) :hidden 1)
(progn
(tp-layer-reset)
(define-tp base () '(face default))
(define-tp highlight () '(face (:background "yellow")))
(with-temp-buffer
(insert "Hello World")
(tp-push-layer 1 10 'base)
(tp-push-layer 1 10 'highlight)
(list :face (tp-at 1 'face)
:top (tp-layer-top 1 10)
:layers (tp-layer-list 1 10)
:hidden (length (tp-at 1 'tp-layers))))))
;; ---- Utilities ----
(chk "U-intervals" '((0 5 (face bold)) (5 6 nil) (6 11 (face italic)))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic))
(tp-intervals 1 12)))
(chk "U-intervalsmap" '((0 5 bold) (5 6 nil) (6 11 italic))
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic))
(tp-intervals-map
(lambda (start end props belows)
(ignore belows)
(list start end (plist-get props 'face)))
1 12)))
(chk "U-plist" '(help-echo "Tip" face italic)
(with-temp-buffer
(insert "Hello World")
(tp-set 1 6 '(face bold help-echo "Tip"))
(tp-set 7 12 '(face italic))
(tp-plist 1 12)))
(chk "U-emptyp" '(t nil)
(let* ((str "text")
(new (tp-set str 'face 'bold)))
(list (tp-empty-p str) (tp-empty-p new))))
(chk "U-emptyp2" t (tp-empty-p "plain text"))
(chk-str "U-popbuffer" "#(\"Important\" 0 9 (face (:foreground \"red\" :weight bold)))"
(progn
(tp-pop-to-buffer "*tp-demo*"
(insert (tp-set "Important" 'face '(:foreground "red" :weight bold))
" message\n"))
(with-current-buffer "*tp-demo*"
(buffer-substring 1 10))))
(chk "U-parsecolor1" "red" (tp-parse-color "red"))
(chk "U-parsecolor2" t
(and (member (tp-parse-color '("white" . "black")) '("white" "black")) t))
;; ---- Practical examples ----
(chk "X-taskstatus" 3
(progn
(tp-layer-reset)
(define-tp status-todo () '(face (:foreground "gray")))
(define-tp status-progress () '(face (:foreground "yellow")))
(define-tp status-done () '(face (:foreground "green")))
(define-tps task-status () 'status-todo 'status-progress 'status-done)
(length (tp-group-props 'task-status))))
(chk "X-temphl" '(face (:background "yellow"))
(progn
(tp-layer-reset)
(define-tp temp-highlight ()
'(face (:background "yellow")))
(tp-layer-props 'temp-highlight)))
(chk "X-synhl" 'code-error
(progn
(tp-layer-reset)
(define-tp code-base ()
'(face font-lock-keyword-face))
(define-tp code-error ()
'(face (:underline (:color "red" :style wave))
help-echo "Syntax error"))
(define-tp code-debug ()
'(face (:background "dark blue")))
(with-temp-buffer
(insert (make-string 100 ?x))
(tp-push-layer 1 100 'code-base)
(tp-push-layer 50 60 'code-error)
(tp-layer-top 50 60))))
;; ---- Reactive chapter ----
(defvar status-color nil)
(chk "RC-watch" '("Layer monitored-layer: color changed from nil to red"
"Layer monitored-layer: color changed from red to green")
(let ((msgs nil))
(tp-layer-reset)
(cl-letf* (((symbol-function 'message)
(lambda (fmt &rest args)
(when fmt (push (apply #'format fmt args) msgs))
nil)))
(define-tp monitored-layer ()
:props '(face (:foreground $status-color))
:watch '((status-color
(lambda (new-val old-val layer-name)
(message "Layer %s: color changed from %s to %s"
layer-name old-val new-val)))))
(setq status-color "red")
(setq status-color "green"))
(nreverse msgs)))
(chk "RC-groups" '(face (:foreground "green") tp-name status-indicators-success)
(progn
(tp-layer-reset)
(define-tps status-indicators ()
'("success" :props (face (:foreground $success-color))
:data ((success-color . "green")))
'("warning" :props (face (:foreground $warning-color))
:data ((warning-color . "orange")))
'("error" :props (face (:foreground $error-color))
:data ((error-color . "red"))))
(tp-layer-props 'status-indicators-success)))
(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) ----
(defvar theme-fg "white")
(defvar theme-bg "black")
(defvar theme-accent "cyan")
(chk "RC-theme" '(:before ((:foreground "cyan" :weight bold)
(:foreground "white" :background "black"))
:after ((:foreground "blue" :weight bold)
(:foreground "black" :background "white")))
(progn
(tp-layer-reset)
(setq theme-fg "white" theme-bg "black" theme-accent "cyan")
(define-tp code-text ()
:props '(face (:foreground $theme-fg :background $theme-bg)))
(define-tp code-keyword ()
:props '(face (:foreground $theme-accent :weight bold)))
(defun switch-to-light-theme ()
(interactive)
(setq theme-fg "black")
(setq theme-bg "white")
(setq theme-accent "blue"))
(defun switch-to-dark-theme ()
(interactive)
(setq theme-fg "white")
(setq theme-bg "black")
(setq theme-accent "cyan"))
(with-temp-buffer
(insert "(defun greet () (let (x) x))")
(tp-set (point-min) (point-max) 'code-text)
(tp-match-set '("defun" "defvar" "let" "if" "when") 'code-keyword)
(let ((before (list (tp-at 2 'face) (tp-at 10 'face))))
(switch-to-light-theme)
(list :before before
:after (list (tp-at 2 'face) (tp-at 10 'face)))))))
;; ---- Regexp and string-form examples ----
(tp-layer-reset)
(chk "X-buffer-return" '(1 . 10)
(let ((my-buffer (generate-new-buffer "*test*")))
(with-current-buffer my-buffer (insert "Hello World"))
(prog1 (tp-set 1 10 '(face italic) my-buffer)
(kill-buffer my-buffer))))
(chk-str "X-regexp-case-fold" "#(\"Hello WORLD\" 0 5 (face bold) 6 11 (face bold))"
(tp-regexp-set "[A-Z]+" '(face bold) "Hello WORLD"))
(chk-str "X-regexp-multi" "#(\"abc 123 XYZ\" 0 3 (face bold) 4 7 (face bold) 8 11 (face bold))"
(tp-regexp-set '("[0-9]+" "[A-Z]+") '(face bold) "abc 123 XYZ"))
(chk "X-regexp-reset-new-string" '((face italic) (help-echo "original"))
(let ((str (copy-sequence "abc 123 def")))
(tp-set 4 7 '(help-echo "original") str)
(let ((result (tp-regexp-reset "[0-9]+" '(face italic) str)))
(list (tp-at 4 result) (tp-at 4 str)))))
(chk "X-regexp-add-new-string" '((face italic help-echo "number") (help-echo "number"))
(let ((str (copy-sequence "abc 123 def")))
(tp-set 4 7 '(help-echo "number") str)
(let ((result (tp-regexp-add "[0-9]+" '(face italic) str)))
(list (tp-at 4 result) (tp-at 4 str)))))
(chk "X-match-per-pattern-order" '((7 . 12) (1 . 6) (14 . 19))
(with-temp-buffer
(insert "Hello world, Hello again")
(tp-match-set '("world" "Hello") '(face bold))))
(chk "X-do-shortfall-all-or-nothing" '(1 "hello world")
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str)
(list (tp-forward-do #'upcase 'marker nil str 3)
(substring-no-properties str))))
(princ (format "\nTOTAL: %d FAILS: %d\n" total fails))
(when (> fails 0) (kill-emacs 1))
;;; tp-doctest.el ends here

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

@ -0,0 +1,342 @@
;;; tp-layer-tests.el --- ERT regression tests for tp-layer.el -*- lexical-binding: t -*-
;;; Commentary:
;; Regression tests for confirmed bugs fixed in the layer-definition
;; module (tp-layer.el). Each section is tagged with the canonical
;; bug id it guards against.
;;; Code:
(require 'ert)
(require 'tp)
(defmacro tp-layer-tests--with-clean (&rest body)
"Run BODY with a clean layer/reactive state, resetting afterwards."
(declare (indent 0))
`(unwind-protect
(progn (tp-layer-reset) ,@body)
(tp-layer-reset)))
;; Dynamic variables used by reactive tests ($foo refers to variable foo).
(defvar tp-layer-test-b15-color nil)
(defvar tp-layer-test-b23-color nil)
(defvar tp-layer-test-b26-color nil)
;;; B20: documented parameterized define-tps format must yield props
(ert-deftest tp-layer-test-param-group-docstring-format ()
"The define-tps docstring Format 2 example returns real props."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-status (color)
`((face (:foreground ,color)))
'(face (:weight bold)))
(should (tp-group-parameterized-p 'tp-layer-test-status))
(should (equal (tp-group-props-with-arg 'tp-layer-test-status "red")
'((face (:foreground "red"))
(face (:weight bold)))))))
(ert-deftest tp-layer-test-param-group-resolves-in-tp-set-path ()
"tp--resolve-props builds a layered structure from a parameterized group."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-status (color)
`((face (:foreground ,color)))
'(face (:weight bold)))
(let ((props (tp--resolve-props '(tp-layer-test-status "red"))))
(should (equal (plist-get props 'face) '(:foreground "red")))
(should (equal (plist-get props 'tp-layers)
'((face (:weight bold))))))))
(ert-deftest tp-layer-test-param-group-layer-reference-specs ()
"Parameterized groups still accept layer-name and (LAYER ARG) specs."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-bold () '(face bold))
(define-tp tp-layer-test-fg (c) `(face (:foreground ,c)))
(define-tps tp-layer-test-mixed (color)
'tp-layer-test-bold
`(tp-layer-test-fg ,color))
(should (equal (tp-group-props-with-arg 'tp-layer-test-mixed "blue")
'((face bold)
(face (:foreground "blue")))))))
(ert-deftest tp-layer-test-param-group-named-element ()
"Parameterized groups accept named (\"NAME\" :props PLIST) elements."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-named (color)
`(("fg" :props (face (:foreground ,color)))))
(should (equal (tp-group-props-with-arg 'tp-layer-test-named "red")
'((face (:foreground "red")))))))
;;; B21: cyclic layer references signal a clear error, not stack overflow
(ert-deftest tp-layer-test-cycle-self-reference ()
"A layer referencing itself signals an error naming the cycle."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-cyc '(tp-layer-test-cyc t face bold))
(let ((err (should-error (tp-layer-props 'tp-layer-test-cyc))))
(should (string-match-p "cyclic layer reference"
(error-message-string err)))
(should (string-match-p "tp-layer-test-cyc -> tp-layer-test-cyc"
(error-message-string err))))))
(ert-deftest tp-layer-test-cycle-mutual-reference ()
"Two layers referencing each other signal an error naming both."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-ca '(tp-layer-test-cb t face bold))
(tp--set-layer-props 'tp-layer-test-cb '(tp-layer-test-ca t face italic))
(let ((err (should-error (tp-layer-props 'tp-layer-test-ca))))
(should (string-match-p
"tp-layer-test-ca -> tp-layer-test-cb -> tp-layer-test-ca"
(error-message-string err))))))
(ert-deftest tp-layer-test-cycle-diamond-is-not-a-cycle ()
"Re-using the same layer along different branches is not a cycle."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-base () '(face bold))
(tp--set-layer-props 'tp-layer-test-left '(tp-layer-test-base t help-echo "l"))
(tp--set-layer-props 'tp-layer-test-right '(tp-layer-test-base t mouse-face highlight))
(tp--set-layer-props 'tp-layer-test-top
'(tp-layer-test-left t tp-layer-test-right t))
(let ((props (tp-layer-props 'tp-layer-test-top)))
(should (equal (plist-get props 'help-echo) "l"))
(should (eq (plist-get props 'mouse-face) 'highlight)))))
;;; B22: extra body forms in define-tp simple format are an error
(ert-deftest tp-layer-test-extra-body-forms-error ()
"define-tp with two simple body forms errors instead of dropping one."
(should-error
(eval '(define-tp tp-layer-test-extra ()
'(face bold)
'(display "x"))
t)))
(ert-deftest tp-layer-test-single-body-form-still-works ()
"define-tp with exactly one simple body form still defines the layer."
(tp-layer-tests--with-clean
(eval '(define-tp tp-layer-test-single () '(face bold)) t)
(should (equal (tp-layer-props 'tp-layer-test-single) '(face bold)))))
(ert-deftest tp-layer-test-keyword-format-unaffected-by-arity-check ()
"The reactive keyword format still accepts multiple keyword pairs."
(tp-layer-tests--with-clean
(eval '(define-tp tp-layer-test-kw ()
:props '(face bold)
:transform #'upcase)
t)
(should (equal (plist-get (tp-layer-props 'tp-layer-test-kw) 'face) 'bold))
(should (eq (cdr (assoc 'tp-layer-test-kw tp-layer-transforms)) #'upcase))))
;;; B23: $-symbols in parameterized bodies resolve instead of leaking
(ert-deftest tp-layer-test-param-layer-resolves-reactive-symbols ()
"$-syms in a parameterized body resolve to current variable values."
(tp-layer-tests--with-clean
(setq tp-layer-test-b23-color "green")
(define-tp tp-layer-test-preact (x)
`(face (:foreground $tp-layer-test-b23-color) help-echo ,x))
(should (equal (tp-layer-props-with-arg 'tp-layer-test-preact "hi")
'(face (:foreground "green") help-echo "hi")))
;; And through the tp-set resolution pipeline as well.
(should (equal (tp--resolve-props '(tp-layer-test-preact "hi"))
'(face (:foreground "green") help-echo "hi")))))
(ert-deftest tp-layer-test-param-layer-reactive-syms-not-registered ()
"Resolved $-syms in parameterized bodies create no reactive deps."
(tp-layer-tests--with-clean
(setq tp-layer-test-b23-color "green")
(define-tp tp-layer-test-preact (x)
`(face (:foreground $tp-layer-test-b23-color) help-echo ,x))
(tp-layer-props-with-arg 'tp-layer-test-preact "hi")
(should-not (tp--layer-has-reactive-deps-p 'tp-layer-test-preact))))
;;; B24: accessors return copies, not internal storage
(ert-deftest tp-layer-test-props-mutation-does-not-corrupt-static-layer ()
"Mutating the plist returned for a define-tp layer leaves it intact."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-st () '(face bold))
(let ((props (tp-layer-props 'tp-layer-test-st)))
(setcar (cdr props) 'MUTATED))
(should (equal (tp-layer-props 'tp-layer-test-st) '(face bold)))))
(ert-deftest tp-layer-test-props-mutation-does-not-corrupt-old-format ()
"Mutating the plist returned for an old-format layer leaves it intact."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-old '(face bold))
(let ((props (tp-layer-props 'tp-layer-test-old)))
(setcar (cdr props) 'MUTATED))
(should (equal (tp-layer-props 'tp-layer-test-old) '(face bold)))))
(ert-deftest tp-layer-test-props-deep-mutation-does-not-corrupt ()
"Mutating nested structure of the returned plist leaves storage intact."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-deep '(face (:weight bold)))
(let ((props (tp-layer-props 'tp-layer-test-deep)))
(setcar (plist-get props 'face) 'MUTATED))
(should (equal (tp-layer-props 'tp-layer-test-deep)
'(face (:weight bold))))))
(ert-deftest tp-layer-test-group-props-mutation-does-not-corrupt ()
"Mutating plists returned by tp-group-props leaves layers intact."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-gm () '(face bold))
(define-tps tp-layer-test-gmg () 'tp-layer-test-gm)
(let ((props-list (tp-group-props 'tp-layer-test-gmg)))
(setcar (cdar props-list) 'MUTATED))
(should (equal (tp-group-props 'tp-layer-test-gmg) '((face bold))))))
;;; B25: :transform in define-tps group elements is registered
(ert-deftest tp-layer-test-group-element-transform-registered ()
"A format-4 group element's :transform lands in tp-layer-transforms."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-tg ()
'("a" :props (face (:foreground $tp-layer-test-b26-color))
:data ((tp-layer-test-b26-color . "red"))
:transform upcase))
(should (eq (cdr (assoc 'tp-layer-test-tg-a tp-layer-transforms))
'upcase))))
(ert-deftest tp-layer-test-group-element-transform-removed-on-redefine ()
"Redefining a group element without :transform unregisters the old one."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-tg ()
'("a" :props (face bold) :transform upcase))
(should (assoc 'tp-layer-test-tg-a tp-layer-transforms))
(define-tps tp-layer-test-tg ()
'("a" . (face bold)))
(should-not (assoc 'tp-layer-test-tg-a tp-layer-transforms))))
;;; B26: group redefinition / undefinition cleans up generated layers
(ert-deftest tp-layer-test-group-redefine-removes-orphans ()
"Shrinking a group on redefinition undefines the dropped layers."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-rg ()
'(face bold) '(face italic) '(face underline))
(should (assoc 'tp-layer-test-rg-1 tp-layer-alist))
(should (assoc 'tp-layer-test-rg-2 tp-layer-alist))
(define-tps tp-layer-test-rg ()
'(face bold))
(should (assoc 'tp-layer-test-rg-0 tp-layer-alist))
(should-not (assoc 'tp-layer-test-rg-1 tp-layer-alist))
(should-not (assoc 'tp-layer-test-rg-2 tp-layer-alist))
(should (equal (tp-group-props 'tp-layer-test-rg) '((face bold))))))
(ert-deftest tp-layer-test-undefine-group-removes-generated-layers ()
"tp-undefine-group also undefines layers generated by the group."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-ug ()
'(face bold)
'("named" . (face italic)))
(tp-undefine-group 'tp-layer-test-ug)
(should-not (assoc 'tp-layer-test-ug tp-layer-groups))
(should-not (assoc 'tp-layer-test-ug-0 tp-layer-alist))
(should-not (assoc 'tp-layer-test-ug-named tp-layer-alist))))
(ert-deftest tp-layer-test-undefine-group-keeps-referenced-layers ()
"Layers merely referenced by a group survive its undefinition."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-keep () '(face bold))
(define-tps tp-layer-test-ug2 ()
'tp-layer-test-keep
'(face italic))
(tp-undefine-group 'tp-layer-test-ug2)
(should (assoc 'tp-layer-test-keep tp-layer-alist))
(should-not (assoc 'tp-layer-test-ug2-0 tp-layer-alist))))
(ert-deftest tp-layer-test-undefine-group-cleans-reactive-deps ()
"Undefining a group unregisters reactive deps of generated layers."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-ug3 ()
'("r" :props (face (:foreground $tp-layer-test-b26-color))
:data ((tp-layer-test-b26-color . "red"))))
(should (tp--layer-has-reactive-deps-p 'tp-layer-test-ug3-r))
(tp-undefine-group 'tp-layer-test-ug3)
(should-not (tp--layer-has-reactive-deps-p 'tp-layer-test-ug3-r))
(should-not (assoc 'tp-layer-test-ug3-r tp-layer-alist))))
(ert-deftest tp-layer-test-group-redefine-to-parameterized-cleans-up ()
"Redefining a plain group as parameterized undefines its old layers."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-pg ()
'(face bold))
(should (assoc 'tp-layer-test-pg-0 tp-layer-alist))
(define-tps tp-layer-test-pg (color)
`((face (:foreground ,color))))
(should-not (assoc 'tp-layer-test-pg-0 tp-layer-alist))
(should (tp-group-parameterized-p 'tp-layer-test-pg))))
;;; B27: unknown keywords in group elements are an error, not a misparse
(ert-deftest tp-layer-test-group-element-unknown-keyword-errors ()
"An unknown keyword in a format-4 group element signals an error."
(tp-layer-tests--with-clean
(let ((err (should-error
(eval '(define-tps tp-layer-test-bad ()
'("a" :props (face bold)
:bogus (:props (face italic))))
t))))
(should (string-match-p "Unknown keyword"
(error-message-string err))))))
;;; B15: anonymous reactive layers are interned, not minted per call
(ert-deftest tp-layer-test-anonymous-layer-interned ()
"Equal reactive plists reuse a single anonymous layer entry."
(tp-layer-tests--with-clean
(setq tp-layer-test-b15-color "red")
(let* ((s1 (tp-set (copy-sequence "hi")
'(face (:foreground $tp-layer-test-b15-color))))
(s2 (tp-set (copy-sequence "hi")
'(face (:foreground $tp-layer-test-b15-color))))
(n1 (get-text-property 0 'tp-name s1))
(n2 (get-text-property 0 'tp-name s2)))
(should n1)
(should (eq n1 n2))
;; Exactly one anonymous registry entry for the shared spec.
(should (= (length tp-layer-alist) 1)))))
(ert-deftest tp-layer-test-anonymous-layer-distinct-specs-distinct ()
"Different reactive plists still get different anonymous layers."
(tp-layer-tests--with-clean
(setq tp-layer-test-b15-color "red")
(let* ((s1 (tp-set (copy-sequence "hi")
'(face (:foreground $tp-layer-test-b15-color))))
(s2 (tp-set (copy-sequence "hi")
'(face (:background $tp-layer-test-b15-color))))
(n1 (get-text-property 0 'tp-name s1))
(n2 (get-text-property 0 'tp-name s2)))
(should n1)
(should n2)
(should-not (eq n1 n2)))))
(ert-deftest tp-layer-test-anonymous-layer-reuse-keeps-reactivity ()
"Reactive updates still reach buffer text using a reused anonymous layer."
(tp-layer-tests--with-clean
(with-temp-buffer
(setq tp-layer-test-b15-color "red")
(insert "Hello World")
(tp-set 1 3 '(face (:foreground $tp-layer-test-b15-color)))
(tp-set 7 9 '(face (:foreground $tp-layer-test-b15-color)))
(should (eq (get-text-property 1 'tp-name)
(get-text-property 7 'tp-name)))
(setq tp-layer-test-b15-color "blue")
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"blue"))
(should (equal (plist-get (get-text-property 7 'face) :foreground)
"blue")))))
(ert-deftest tp-layer-test-anonymous-registry-cleared-on-reset ()
"tp-layer-reset clears the anonymous-layer intern registry."
(tp-layer-tests--with-clean
(setq tp-layer-test-b15-color "red")
(tp-set (copy-sequence "hi")
'(face (:foreground $tp-layer-test-b15-color)))
(should tp--anonymous-layer-registry)
(tp-layer-reset)
(should-not tp--anonymous-layer-registry)))
(provide 'tp-layer-tests)
;;; tp-layer-tests.el ends here

1295
tp-layer.el Normal file
View File

File diff suppressed because it is too large Load Diff

282
tp-ops-tests.el Normal file
View File

@ -0,0 +1,282 @@
;;; tp-ops-tests.el --- ERT regression tests for tp-ops.el -*- lexical-binding: t -*-
;;; Commentary:
;; Regression tests for confirmed bugs fixed in the ops-core module
;; (tp-ops.el, with supporting fixes in tp-core.el). Each section is
;; tagged with the canonical bug id it guards against.
;;; Code:
(require 'ert)
(require 'tp)
;;; B1: tp-remove string form must not drop the 3rd+ properties
(ert-deftest tp-ops-test-remove-string-three-props ()
"Removing three properties from a string removes all three."
(let* ((str (propertize "hi" 'face 'bold 'help-echo "x" 'mouse-face 'highlight))
(result (tp-remove str 'face 'help-echo 'mouse-face)))
(should (null (get-text-property 0 'face result)))
(should (null (get-text-property 0 'help-echo result)))
(should (null (get-text-property 0 'mouse-face result)))))
(ert-deftest tp-ops-test-remove-string-four-props ()
"Removing four properties removes all four; nothing rides along."
(let* ((str (propertize "hi" 'face 'bold 'help-echo "x"
'mouse-face 'highlight 'keymap 'km))
(result (tp-remove str 'face 'help-echo 'mouse-face 'keymap)))
(should (null (text-properties-at 0 result)))))
(ert-deftest tp-ops-test-remove-string-third-prop-kept-elsewhere ()
"Properties not listed stay when 3+ properties are removed."
(let* ((str (propertize "hi" 'face 'bold 'help-echo "x"
'mouse-face 'highlight 'keymap 'km))
(result (tp-remove str 'face 'help-echo 'mouse-face)))
(should (eq (get-text-property 0 'keymap result) 'km))))
;;; B2: string-form removal operates per interval
(ert-deftest tp-ops-test-remove-string-prop-preserves-other-intervals ()
"Removing a property keeps each interval's own remaining props."
(let* ((s (concat (propertize "ab" 'face 'bold)
(propertize "cd" 'face 'italic 'help-echo "x")))
(result (tp-remove s 'help-echo)))
(should (eq (get-text-property 0 'face result) 'bold))
(should (eq (get-text-property 2 'face result) 'italic))
(should (null (get-text-property 2 'help-echo result)))))
(ert-deftest tp-ops-test-remove-string-sub-key-per-interval ()
"Sub-key removal does not smear one interval's face over another."
(let* ((s (concat (propertize "ab" 'face '(:weight bold :underline t))
(propertize "cd" 'face 'italic)))
(result (tp-remove s 'face :underline)))
(let ((face0 (get-text-property 0 'face result)))
(should (eq (plist-get face0 :weight) 'bold))
(should (null (plist-get face0 :underline))))
(should (eq (get-text-property 2 'face result) 'italic))))
(ert-deftest tp-ops-test-remove-string-nested-sub-key-per-interval ()
"Nested sub-key removal keeps other intervals' face values intact."
(let* ((s (concat (propertize "ab" 'face '(:underline (:style wave :position t)))
(propertize "cd" 'face 'italic)))
(result (tp-remove s 'face :underline '(:style))))
(let* ((face0 (get-text-property 0 'face result))
(underline (plist-get face0 :underline)))
(should (plist-get underline :position))
(should (null (plist-get underline :style))))
(should (eq (get-text-property 2 'face result) 'italic))))
(ert-deftest tp-ops-test-remove-string-prop-interval-boundaries-kept ()
"Interval boundaries survive removal of an unrelated property."
(let* ((s (concat (propertize "ab" 'face 'bold)
"cd"
(propertize "ef" 'face 'underline 'help-echo "z")))
(result (tp-remove s 'help-echo)))
(should (eq (get-text-property 0 'face result) 'bold))
(should (null (get-text-property 2 'face result)))
(should (eq (get-text-property 4 'face result) 'underline))
(should (null (get-text-property 4 'help-echo result)))))
;;; B3: tp-clear defaults bounds from OBJECT
(ert-deftest tp-ops-test-clear-string-defaults ()
"tp-clear with a string OBJECT clears the whole string by default."
(with-temp-buffer ; empty buffer: old code no-oped
(let ((s (propertize "hey" 'face 'bold 'help-echo "x")))
(tp-clear nil nil s)
(should (null (text-properties-at 0 s)))
(should (tp-empty-p s)))))
(ert-deftest tp-ops-test-clear-string-defaults-in-longer-buffer ()
"tp-clear on a short string works even when current buffer is longer."
(with-temp-buffer
(insert (make-string 100 ?x))
(let ((s (propertize "ab" 'face 'bold)))
(tp-clear nil nil s) ; old code: args-out-of-range
(should (tp-empty-p s)))))
(ert-deftest tp-ops-test-clear-buffer-defaults-still-work ()
"tp-clear with no args still clears the whole current buffer."
(with-temp-buffer
(insert "Hello")
(put-text-property 1 6 'face 'bold)
(tp-clear)
(should (null (text-properties-at 1)))))
(ert-deftest tp-ops-test-clear-buffer-object-defaults ()
"tp-clear defaults bounds from a buffer OBJECT, not the current buffer."
(let ((buf (generate-new-buffer " tp-ops-test-clear")))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(put-text-property 1 6 'face 'bold))
(with-temp-buffer ; empty current buffer
(tp-clear nil nil buf))
(with-current-buffer buf
(should (null (text-properties-at 1)))))
(kill-buffer buf))))
;;; B4: (tp-get STRING START END ...) range form
(ert-deftest tp-ops-test-get-string-numeric-range ()
"String object with a numeric range returns the intervals in range."
(let ((str (propertize "hey" 'face 'bold)))
(should (equal (tp-get str 0 2) '((0 2 (face bold)))))))
(ert-deftest tp-ops-test-get-string-numeric-range-with-property ()
"String range form accepts a property like the buffer region form."
(let ((str (concat (propertize "ab" 'face 'bold)
(propertize "cd" 'face 'italic))))
(should (equal (tp-get str 0 4 'face)
'((0 2 bold) (2 4 italic))))
(should (equal (tp-get str 2 4 'face) '((2 4 italic))))))
(ert-deftest tp-ops-test-get-string-numeric-range-with-sub-path ()
"String range form supports nested sub-paths."
(let ((str (propertize "hey" 'face '(:foreground "red" :weight bold))))
(should (equal (tp-get str 0 3 'face :foreground)
'((0 3 "red"))))))
(ert-deftest tp-ops-test-get-string-numeric-start-without-end-errors ()
"A numeric START without a numeric END signals a clear error."
(should-error (tp-get (propertize "hey" 'face 'bold) 0)))
;;; B5: tp--parse-face-list trailing bare keyword
(ert-deftest tp-ops-test-parse-face-list-trailing-keyword ()
"A trailing bare keyword does not produce a bogus (KEY nil) pair."
(should (equal (tp--parse-face-list '(bold :foreground))
'((bold)))))
(ert-deftest tp-ops-test-parse-face-list-inline-keyword-still-works ()
"Inline keyword-value pairs are still consumed normally."
(should (equal (tp--parse-face-list '(bold :foreground "green"))
'((bold) :foreground "green"))))
;;; B6: region form with flat prop/val signals immediately
(ert-deftest tp-ops-test-set-region-flat-args-error ()
"Region form with flat PROP/VAL args signals an immediate error."
(with-temp-buffer
(insert "hello")
(should-error (tp-set 1 4 'face 'bold))
;; Nothing was applied
(should (null (get-text-property 1 'face)))))
(ert-deftest tp-ops-test-add-and-reset-region-flat-args-error ()
"tp-add and tp-reset region forms reject flat PROP/VAL args too."
(with-temp-buffer
(insert "hello")
(should-error (tp-add 1 4 'face 'bold))
(should-error (tp-reset 1 4 'face 'bold))))
(ert-deftest tp-ops-test-set-region-with-object-still-works ()
"Region form with a plist and trailing OBJECT is unaffected."
(let ((s (copy-sequence "hello")))
(tp-set 0 3 '(face bold) s)
(should (eq (get-text-property 0 'face s) 'bold)))
(with-temp-buffer
(insert "hello")
(tp-set 1 4 '(face bold))
(should (eq (get-text-property 1 'face) 'bold))))
;;; B7: tp-add face-family prepend semantics for all tp-face-properties
(ert-deftest tp-ops-test-add-font-lock-face-prepends-string ()
"tp-add prepends font-lock-face like face (string form)."
(let* ((s (propertize "hey" 'font-lock-face 'bold))
(result (tp-add s 'font-lock-face 'italic)))
(should (equal (get-text-property 0 'font-lock-face result)
'(italic bold)))))
(ert-deftest tp-ops-test-add-mouse-face-prepends-string ()
"tp-add prepends mouse-face like face (string form)."
(let* ((s (propertize "hey" 'mouse-face 'highlight))
(result (tp-add s 'mouse-face 'region)))
(should (equal (get-text-property 0 'mouse-face result)
'(region highlight)))))
(ert-deftest tp-ops-test-add-font-lock-face-prepends-buffer ()
"tp-add prepends font-lock-face like face (buffer region form)."
(with-temp-buffer
(insert "hey")
(put-text-property 1 4 'font-lock-face 'bold)
(tp-add 1 4 '(font-lock-face italic))
(should (equal (get-text-property 1 'font-lock-face) '(italic bold)))))
(ert-deftest tp-ops-test-add-font-lock-face-prepends-string-region ()
"tp-add prepends font-lock-face in the string region form."
(let ((s (propertize "hey" 'font-lock-face 'bold)))
(tp-add 0 3 '(font-lock-face italic) s)
(should (equal (get-text-property 0 'font-lock-face s) '(italic bold)))))
(ert-deftest tp-ops-test-add-font-lock-face-plist-merge ()
"tp-add deep-merges font-lock-face plists like face plists."
(let* ((s (propertize "hey" 'font-lock-face '(:foreground "red")))
(result (tp-add s 'font-lock-face '(:background "blue"))))
(let ((flf (get-text-property 0 'font-lock-face result)))
(should (equal (plist-get flf :foreground) "red"))
(should (equal (plist-get flf :background) "blue")))))
(ert-deftest tp-ops-test-add-non-face-property-still-replaces ()
"Non-face properties keep plain replacement semantics in tp-add."
(let* ((s (propertize "hey" 'help-echo "old"))
(result (tp-add s 'help-echo "new")))
(should (equal (get-text-property 0 'help-echo result) "new"))))
;;; B8: tp-intervals clips to the requested range
(ert-deftest tp-ops-test-intervals-clipped-buffer ()
"Buffer intervals are clipped: offsets stay within [0, END-START)."
(with-temp-buffer
(insert "abcdef")
(put-text-property 1 5 'face 'bold)
(let ((intervals (tp-intervals 3 6)))
(dolist (iv intervals)
(should (>= (nth 0 iv) 0))
(should (<= (nth 1 iv) 3))
(should (< (nth 0 iv) (nth 1 iv))))
(should (equal intervals '((0 2 (face bold)) (2 3 nil)))))))
(ert-deftest tp-ops-test-intervals-clipped-string ()
"String intervals are clipped to [START, END)."
(let ((s (copy-sequence "abcdef")))
(put-text-property 0 6 'face 'bold s)
(let ((intervals (tp-intervals 2 4 s)))
(dolist (iv intervals)
(should (>= (nth 0 iv) 2))
(should (<= (nth 1 iv) 4)))
(should (equal intervals '((2 4 (face bold))))))))
;;; tp-member
(ert-deftest tp-ops-test-member-present ()
"tp-member returns (PROPERTY VALUE) when the property is present."
(let ((str (copy-sequence "hello")))
(tp-set 0 5 '(face bold) str)
(should (equal (tp-member 0 'face str) '(face bold)))))
(ert-deftest tp-ops-test-member-present-nil-value ()
"tp-member distinguishes a nil value from an absent property."
(let ((str (copy-sequence "hello")))
(tp-set 0 5 '(face nil) str)
(should (equal (tp-member 0 'face str) '(face nil)))))
(ert-deftest tp-ops-test-member-absent ()
"tp-member returns nil for an absent property."
(let ((str (copy-sequence "hello")))
(tp-set 0 5 '(help-echo "tip") str)
(should (equal (tp-member 0 'face str) nil))))
(ert-deftest tp-ops-test-member-buffer ()
"tp-member works on buffer positions."
(with-temp-buffer
(insert "hello")
(put-text-property 1 6 'my-prop nil)
(should (equal (tp-member 1 'my-prop) '(my-prop nil)))
(should (equal (tp-member 1 'other) nil))))
(provide 'tp-ops-tests)
;;; tp-ops-tests.el ends here

916
tp-ops.el Normal file
View File

@ -0,0 +1,916 @@
;;; tp-ops.el --- Core text property 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:
;; The public property primitives: `tp-set', `tp-reset', `tp-add',
;; `tp-get', `tp-at', `tp-remove', `tp-clear', built on the shared
;; argument parser. Layer names in property specs are resolved through
;; tp-layer.el. The reactive `tp-text' property is handled through
;; `tp--tp-text-handler-function', installed by tp-render.el.
;;; Code:
(require 'cl-lib)
(require 'dash)
(require 'tp-core)
(require 'tp-layer)
(defvar tp--tp-text-handler-function nil
"Function that handles the reactive `tp-text' property, or nil.
Installed by tp-render.el. Called with (START END PROPS OBJECT
PRESERVE-PROPS MERGE-MODE) and must return (PROPS NEW-END NEW-OBJECT).
When nil, `tp-text' is treated as an ordinary text property.")
(defun tp--handle-tp-text (start end props object preserve-props merge-mode)
"Dispatch `tp-text' handling for PROPS between START and END in OBJECT.
PRESERVE-PROPS and MERGE-MODE are forwarded to the installed handler.
Returns (PROPS NEW-END NEW-OBJECT); a pass-through when no handler is
installed (see `tp--tp-text-handler-function')."
(if tp--tp-text-handler-function
(funcall tp--tp-text-handler-function
start end props object preserve-props merge-mode)
(list props end object)))
(defun tp--parse-args (start-or-string end-or-prop props-or-val rest)
"Parse flexible function arguments and return (OBJECT START END PROPS).
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)
(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)))
(list object start finish props)))
(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-set (start-or-string &optional end-or-prop props-or-val &rest rest)
"Set text properties on string or buffer region.
Supports four calling conventions:
1. (tp-set START END PROPS) - current buffer
2. (tp-set START END PROPS BUFFER/STRING) - specific object
3. (tp-set STRING PROP VAL ...) - entire string
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)))
(pcase-let ((`(,object ,start ,finish ,props)
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
;; Handle tp-text property specially - :override means props override embedded props
(pcase-let ((`(,new-props ,new-finish ,new-object)
(tp--handle-tp-text start finish props object t :override)))
(setq props new-props finish new-finish object new-object)
(when (and (stringp object) (plist-member props 'tp-text))
(setq start 0)))
(cond
;; 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))))
(cons start finish))))))
(defun tp-reset (start-or-string &optional end-or-prop props-or-val &rest rest)
"Completely replace all text properties with PROPS.
Like `tp-set' but replaces ALL existing properties.
For tp-text, embedded text properties are preserved (props override if there's a conflict).
**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)))
(pcase-let ((`(,object ,start ,finish ,props)
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
;; Handle tp-text property - :reset means only use props, ignore embedded props
(pcase-let ((`(,new-props ,new-finish ,new-object)
(tp--handle-tp-text start finish props object nil :reset)))
(setq props new-props finish new-finish object new-object)
(when (and (stringp object) (plist-member props 'tp-text))
(setq start 0)))
(cond
;; 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)
(cons start finish))))))
(defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest)
"Add or update text properties with deep merging.
Unlike `tp-set', deeply merges nested properties.
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.
**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.
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)))
(pcase-let ((`(,object ,start ,finish ,props)
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
;; Handle tp-text property - :merge means embedded props are merged with props
(let ((has-tp-text (plist-member props 'tp-text)))
(pcase-let ((`(,new-props ,new-finish ,new-object)
(tp--handle-tp-text start finish props object t :merge)))
(setq props new-props finish new-finish object new-object)
(when (and (stringp object) has-tp-text)
(setq start 0))))
(cond
;; Entire string form: create a new propertized string (non-destructive)
((and (stringp object) entire-string-form)
(if (plist-member props 'tp-text)
;; For tp-text: tp--handle-tp-text-property has already merged embedded
;; properties with props (in :merge mode above). The new-object is a
;; fresh string with tp-text content, and new-props contains all merged
;; properties. We use :reset mode here to simply apply these final
;; merged properties to the new string, without re-merging with any
;; (non-existent) existing properties on the new string.
(tp--apply-props-to-string object start finish props :reset)
;; Otherwise use :add mode for deep merging with any existing properties
(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 (let* ((current-val (plist-get current-props key))
(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))))
(put-text-property pos next-pos key new-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 (let* ((current-val (plist-get current-props key))
(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))))
(put-text-property pos next-pos key new-val object)))
(setq pos next-pos))))
(cons start finish))))))
(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."
(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))
(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)))))
(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"))))
(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
(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
((or (bufferp property-or-object) (stringp property-or-object))
(setq obj property-or-object))
;; property-or-object is a symbol - it's a property
((symbolp property-or-object)
(setq property property-or-object
obj object))
;; property-or-object is a list - it's a property path
((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
(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))))
(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)))))
(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
(cond
;; Plist - remove the sub-property
((and (listp current-value) (keywordp (car current-value)))
(let ((result (copy-sequence current-value)))
(cl-remf result sub-property)
(if result result nil)))
;; Other types - leave unchanged
(t current-value))))
(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-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 a dummy arg (t) since we only need key names
(let* ((layer-props
(cond
((tp-layer-parameterized-p property)
(tp-layer-props-with-arg property t nil)) ; arg=t, include-tp-name=nil
((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)))))
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))
;; Use the helper to handle complex face values
(new-value (when prop-value
(tp--remove-sub-from-face-value prop-value sub-key)))
(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))
(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))))
;;;###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)."
(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)))
(provide 'tp-ops)
;;; tp-ops.el ends here

62
tp-palette.el
View File

@ -17,15 +17,30 @@
;;; Code:
(defvar tp-palette-alist nil)
(require 'subr-x) ; string-trim-right
(defalias 'tp-palette--plistp
(if (fboundp 'plistp)
#'plistp
(lambda (object)
(let ((len (proper-list-p object)))
(and len (zerop (% len 2)) t))))
"Return non-nil if OBJECT is a property list.
Compatibility shim: `plistp' was only added in Emacs 29.1, while
the library supports Emacs 28.1.")
(defvar tp-palette-alist nil
"Alist of (NAME . PLIST) palette definitions.
This is the single source of truth for palette lookups.")
(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
accepted by `tp-parse-color' (usually a (LIGHT . DARK) cons).
The palette is stored in `tp-palette-alist'; re-evaluating a
definition updates the stored palette in place."
(declare (indent defun))
(let ((var (intern (concat "tp-palette-" (symbol-name name)))))
`(progn
(setf (alist-get ',name tp-palette-alist)
'(,@plist))
(defvar ,var '(,@plist)))))
`(setf (alist-get ',name tp-palette-alist) '(,@plist)))
(define-tp-palette button-primary
:fg ("#ffffff" . "#ffffff") :bg ("#007bff" . "#007bff"))
@ -236,19 +251,25 @@
(eq (frame-parameter nil 'background-mode) 'light))
(defun tp-parse-color (color)
"e.g.1 (tp-parse-color \"red\")
e.g.2 (tp-parse-color '(\"red\" . \"green\"))
e.g.3 (tp-parse-color '(:light \"red\" :dark \"green\"))"
"Resolve COLOR to a color string for the current theme.
COLOR may be:
- a color string, returned as is: \"red\"
- a (LIGHT . DARK) cons: (\"red\" . \"green\"); either side may be
nil, meaning no color for that mode
- a (:light LIGHT :dark DARK) plist: (:light \"red\" :dark \"green\")
Return nil when COLOR is nil, or when the side selected by the
current theme is nil. When the theme cannot be determined, fall
back to the light color."
(cond ((stringp color) color)
((and (consp color)
(stringp (car color))
(stringp (cdr color)))
(or (stringp (car color)) (null (car color)))
(or (stringp (cdr color)) (null (cdr color))))
(cond
((tp-theme-light-p) (car color))
((tp-theme-dark-p) (cdr color))
;; Default to light color when background-mode is unknown
(t (car color))))
((and (plistp color)
((and (tp-palette--plistp color)
(or (plist-member color :light)
(plist-member color :dark)))
(cond
@ -260,16 +281,13 @@ e.g.3 (tp-parse-color '(:light \"red\" :dark \"green\"))"
(t (error "Invalid format of color %S" color))))
(defun tp-palette--get-color (symbol key)
"Get color value for KEY from palette SYMBOL.
SYMBOL should be a symbol bound to a palette plist.
KEY should be one of :fg, :bg, or :border.
Returns nil if SYMBOL is unbound or doesn't contain KEY."
(setq symbol (intern (concat "tp-palette-"
(symbol-name symbol))))
(when (and (symbolp symbol) (boundp symbol))
(let ((plist (symbol-value symbol)))
(when (plistp plist)
(tp-parse-color (plist-get plist key))))))
"Get color value for KEY from the palette named SYMBOL.
SYMBOL is looked up in `tp-palette-alist'. KEY should be one of
:fg, :bg, or :border. Return nil if SYMBOL names no registered
palette or its definition doesn't contain KEY."
(let ((plist (alist-get symbol tp-palette-alist)))
(when (tp-palette--plistp plist)
(tp-parse-color (plist-get plist key)))))
(defun tp-palette-fg-color (symbol)
"Get the foreground color from palette SYMBOL.

370
tp-reactive.el Normal file
View File

@ -0,0 +1,370 @@
;;; tp-reactive.el --- Reactive state storage and registration 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:
;; Reactive core of tp: storage for variable dependencies, watchers,
;; computed properties and data variables; registration/unregistration;
;; the variable-watcher shell and the batching queue. The actual
;; re-rendering of buffers lives in tp-render.el, which installs
;; itself via `tp--reactive-update-function' / `tp--reactive-flush-function'.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(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-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--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.")
(defconst tp--compute-error (make-symbol "tp--compute-error")
"Sentinel distinguishing a failed compute from a legitimate nil result.
Compute functions may legitimately return nil (e.g. a boolean feeding
`invisible'), so error paths return this uninterned sentinel instead
of nil.")
(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))
(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.")
(defvar tp--reactive-flush-function nil
"Function flushing one pending batched update entry.
Installed by tp-render.el. Called with (LAYER-NAME WHERE
TP-TEXT-AFFECTED).")
(defun tp--reactive-variable-watcher (symbol newval operation where)
"Watcher function called when a reactive variable changes.
SYMBOL is the variable that changed.
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 (message "tp: watcher error for %s watching %s: %s"
layer-name watch-sym err))))))))
(defun tp--flush-batch-updates ()
"Flush all pending batch updates.
This processes all updates collected during a `tp-with-batch-updates' form."
(tp-debug-log "Flushing %d pending batch updates" (length tp--batch-update-pending))
(let ((processed-layers nil))
;; Process each pending update, avoiding duplicate layer updates
(dolist (pending (nreverse tp--batch-update-pending))
(let ((layer-name (car pending))
(where (caddr pending))
(tp-text-affected (cadddr pending)))
(unless (memq layer-name processed-layers)
(push layer-name processed-layers)
(tp-debug-log " Batch updating layer %s (tp-text: %s)"
layer-name (if tp-text-affected "yes" "no"))
(when tp--reactive-flush-function
(funcall tp--reactive-flush-function
layer-name where tp-text-affected))))))
(setq tp--batch-update-pending nil))
(defmacro tp-with-batch-updates (&rest body)
"Execute BODY with reactive updates batched.
Multiple variable changes within BODY are collected and applied
together at the end, avoiding redundant buffer modifications.
This is useful when changing multiple reactive variables simultaneously:
(tp-with-batch-updates
(setq my-color \"red\")
(setq my-size 14)
(setq my-text \"Hello\"))
Without batching, each `setq' would trigger a separate buffer update.
With batching, all updates are consolidated and applied once at the end."
(declare (indent 0) (debug t))
`(let ((tp--batch-update-active t)
(tp--batch-update-pending nil))
(tp-debug-log "Starting batch updates")
(unwind-protect
(progn ,@body)
(tp-debug-log "Ending batch updates")
(tp--flush-batch-updates))))
(defun tp--register-layer-watchers (layer-name watchers)
"Register WATCHERS for LAYER-NAME.
WATCHERS is a list of (VAR-SYMBOL CALLBACK) pairs."
(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 and is
applied; only computes that signal an error are skipped (see
`tp--compute-error')."
(dolist (comp compute)
(let* ((var-sym (car comp))
(compute-fn (cadr comp))
(val (condition-case err
(funcall compute-fn)
(error
(message "tp: initial compute error for %s: %s" var-sym err)
tp--compute-error))))
(unless (eq val tp--compute-error)
(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))))))
(defun tp-reactive-reset ()
"Reset all reactive text property watchers and dependencies."
(interactive)
;; 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-layer-computed nil)
(setq tp-layer-data nil))
(provide 'tp-reactive)
;;; tp-reactive.el ends here

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

@ -0,0 +1,364 @@
;;; 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)
(defmacro tp-rt-with-cleanup (layers vars &rest body)
"Run BODY, then undefine LAYERS and reset VARS to nil (teardown)."
(declare (indent 2))
`(unwind-protect
(progn ,@body)
,@(mapcar (lambda (l) `(tp-undefine-layer ',l)) layers)
,@(mapcar (lambda (v) `(setq ,v nil)) vars)))
;;; B9: sub-region tp-text on a string must splice, not replace the whole string
(ert-deftest tp-render-test-tp-text-string-region-keeps-rest ()
"Region-form tp-text on a string keeps the text outside the region."
(let ((result (tp-set 0 1 '(tp-text "X") (copy-sequence "abc"))))
(should (equal result "Xbc"))
(should (equal (get-text-property 0 'tp-text result) "X"))
;; The preserved suffix must not receive the layer's props
(should (null (get-text-property 1 'tp-text result)))
(should (null (get-text-property 2 'tp-text result)))))
(ert-deftest tp-render-test-tp-text-string-mid-region-splices ()
"A mid-string tp-text region splices prefix + replacement + suffix."
(let ((result (tp-set 1 2 '(face bold tp-text "XY") (copy-sequence "abc"))))
(should (equal result "aXYc"))
;; Props only on the replaced span [1, 3)
(should (null (get-text-property 0 'face result)))
(should (eq (get-text-property 1 'face result) 'bold))
(should (eq (get-text-property 2 'face result) 'bold))
(should (null (get-text-property 3 'face result)))))
(ert-deftest tp-render-test-tp-text-string-region-preserves-outside-props ()
"Splicing keeps the original string's properties outside the region."
(let* ((source (propertize "abc" 'face 'italic 'my-prop 1))
(result (tp-set 1 2 '(tp-text "X") source)))
(should (equal result "aXc"))
;; Prefix and suffix keep their original props
(should (eq (get-text-property 0 'face result) 'italic))
(should (eq (get-text-property 2 'face result) 'italic))
;; Replaced span preserves non-conflicting props (tp-set preserves)
(should (eq (get-text-property 1 'my-prop result) 1))))
(ert-deftest tp-render-test-tp-text-whole-string-still-replaces ()
"Whole-string form still returns just the replacement (legacy semantics)."
(let ((result (tp-set "2" 'face '(:background "green") 'tp-text "6")))
(should (equal result "6"))
(should (equal (get-text-property 0 'face result) '(:background "green")))
(should (equal (get-text-property 0 'tp-text result) "6"))))
;;; B10: computed-variable path must not clobber sibling static attributes
(ert-deftest tp-render-test-computed-update-keeps-static-siblings ()
"A computed update deep-merges, keeping static nested attributes."
(tp-rt-with-cleanup (tp-rt-b10-layer) (tp-rt-b10-data tp-rt-b10-full)
(setq tp-rt-b10-data "red")
(define-tp tp-rt-b10-layer ()
:props '(face (:foreground $tp-rt-b10-full :background "green"))
:data '(tp-rt-b10-data)
:compute '((tp-rt-b10-full (lambda () (concat "col-" tp-rt-b10-data)))))
(setq tp-rt-b10-data "blue")
(let ((face (plist-get (cdr (assoc 'tp-rt-b10-layer tp-layer-alist)) 'face)))
(should (equal (plist-get face :foreground) "col-blue"))
;; The sibling static attribute must survive the update
(should (equal (plist-get face :background) "green")))))
;;; B11: reactive refresh replaces the layer's own keys instead of accumulating
(ert-deftest tp-render-test-reactive-refresh-replaces-face ()
"Changing a symbol-valued face variable replaces the face, not stacks it."
(tp-rt-with-cleanup (tp-rt-b11-layer) (tp-rt-b11-face)
(setq tp-rt-b11-face 'bold)
(define-tp tp-rt-b11-layer () '(face $tp-rt-b11-face))
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 'tp-rt-b11-layer)
(should (eq (get-text-property 1 'face) 'bold))
(setq tp-rt-b11-face 'italic)
;; Must be italic alone, not (italic bold)
(should (eq (get-text-property 1 'face) 'italic)))))
(ert-deftest tp-render-test-reactive-refresh-keeps-unrelated-props ()
"Reactive refresh leaves property keys the layer does not own alone."
(tp-rt-with-cleanup (tp-rt-b11b-layer) (tp-rt-b11b-color)
(setq tp-rt-b11b-color "red")
(define-tp tp-rt-b11b-layer () '(face (:foreground $tp-rt-b11b-color)))
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 'tp-rt-b11b-layer)
(put-text-property 1 6 'help-echo "keep me")
(setq tp-rt-b11b-color "green")
(should (equal (plist-get (get-text-property 1 'face) :foreground) "green"))
(should (equal (get-text-property 1 'help-echo) "keep me")))))
;;; B12: setq-local must not leak into the global layer definition
(ert-deftest tp-render-test-setq-local-does-not-touch-global-def ()
"A buffer-local change re-renders the buffer but keeps the global def."
(tp-rt-with-cleanup (tp-rt-b12-layer) ()
(setq-default tp-rt-b12-color "red")
(define-tp tp-rt-b12-layer () '(face (:foreground $tp-rt-b12-color)))
(let ((buf-a (generate-new-buffer " tp-rt-b12-a"))
(buf-b (generate-new-buffer " tp-rt-b12-b")))
(unwind-protect
(progn
(with-current-buffer buf-a
(insert "Hello")
(tp-set 1 6 'tp-rt-b12-layer))
(with-current-buffer buf-b
(insert "Hello")
(tp-set 1 6 'tp-rt-b12-layer))
(with-current-buffer buf-a
(setq-local tp-rt-b12-color "purple"))
;; Buffer A is re-rendered with its local value
(with-current-buffer buf-a
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"purple")))
;; The GLOBAL definition must not absorb the local value
(should (equal (plist-get
(plist-get (cdr (assoc 'tp-rt-b12-layer tp-layer-alist))
'face)
:foreground)
"red"))
(should (equal (default-value 'tp-rt-b12-color) "red"))
;; Other buffers keep rendering the global value
(with-current-buffer buf-b
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"red"))))
(kill-buffer buf-a)
(kill-buffer buf-b)
(setq-default tp-rt-b12-color nil)))))
;;; B13: reactive tp-text replacement preserves unrelated properties
(ert-deftest tp-render-test-reactive-text-update-preserves-other-props ()
"Replacing reactive text keeps properties other layers put on the region."
(tp-rt-with-cleanup (tp-rt-b13-layer) (tp-rt-b13-text)
(setq tp-rt-b13-text "aaa")
(define-tp tp-rt-b13-layer () '(face bold tp-text $tp-rt-b13-text))
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 'tp-rt-b13-layer)
(put-text-property 1 3 'my-other-prop 42)
(setq tp-rt-b13-text "bbb")
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"bbb"))
;; The unrelated property survives the text replacement
(should (eq (get-text-property 1 'my-other-prop) 42))
;; The layer's own props are still applied
(should (eq (get-text-property 1 'face) 'bold)))))
(ert-deftest tp-render-test-reactive-text-same-text-preserves-other-props ()
"A same-text properties-only update keeps unrelated properties too."
(tp-rt-with-cleanup (tp-rt-b13b-layer) (tp-rt-b13b-text)
(setq tp-rt-b13b-text "emacs")
(define-tp tp-rt-b13b-layer () '(tp-text $tp-rt-b13b-text))
(with-temp-buffer
(insert "emacs")
(tp-set 1 6 'tp-rt-b13b-layer)
(put-text-property 1 6 'my-other-prop 'yes)
;; Same text, new embedded properties
(setq tp-rt-b13b-text (propertize "emacs" 'face 'bold))
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 1 'my-other-prop) 'yes)))))
;;; B14: computed values of nil must propagate
(ert-deftest tp-render-test-computed-nil-propagates-on-update ()
"A compute function returning nil updates the variable and the layer."
(tp-rt-with-cleanup (tp-rt-b14-layer) (tp-rt-b14-flag tp-rt-b14-inv)
(setq tp-rt-b14-flag t)
(define-tp tp-rt-b14-layer ()
:props '(invisible $tp-rt-b14-inv)
:data '(tp-rt-b14-flag)
:compute '((tp-rt-b14-inv (lambda () tp-rt-b14-flag))))
(should (eq tp-rt-b14-inv t))
(setq tp-rt-b14-flag nil)
;; nil is a legitimate computed value, not an error sentinel
(should (eq tp-rt-b14-inv nil))
(should (eq (plist-get (cdr (assoc 'tp-rt-b14-layer tp-layer-alist))
'invisible)
nil))))
(ert-deftest tp-render-test-computed-nil-applies-initially ()
"An initial computed value of nil overwrites a stale non-nil value."
(tp-rt-with-cleanup (tp-rt-b14b-layer) (tp-rt-b14b-init)
(setq tp-rt-b14b-init 'stale)
(define-tp tp-rt-b14b-layer ()
:props '(invisible $tp-rt-b14b-init)
:compute '((tp-rt-b14b-init (lambda () nil))))
(should (eq tp-rt-b14b-init nil))))
;;; B16: no watcher recursion from nested variable writes
(ert-deftest tp-render-test-compute-runs-once-per-change ()
"One data change runs each compute function exactly once (no recursion)."
(tp-rt-with-cleanup (tp-rt-b16-layer) (tp-rt-b16-data tp-rt-b16-comp)
(setq tp-rt-b16-data "a" tp-rt-b16-count 0)
(define-tp tp-rt-b16-layer ()
:props '(help-echo $tp-rt-b16-comp)
:data '(tp-rt-b16-data)
:compute '((tp-rt-b16-comp
(lambda ()
(setq tp-rt-b16-count (1+ tp-rt-b16-count))
(concat tp-rt-b16-data "!")))))
(with-temp-buffer
(insert "Hello")
(tp-set 1 6 'tp-rt-b16-layer)
(setq tp-rt-b16-count 0)
(setq tp-rt-b16-data "b")
;; The nested (set comp ...) must queue its re-render, not re-enter
;; the compute machinery.
(should (= tp-rt-b16-count 1))
;; The nested change's re-render still lands in the buffer
(should (equal tp-rt-b16-comp "b!"))
(should (equal (get-text-property 1 'help-echo) "b!")))))
;;; B17: batched entries must union WHERE and the tp-text-affected flag
(ert-deftest tp-render-test-batch-tp-text-flag-is-sticky ()
"A tp-text change deferred after a non-tp-text change still replaces text."
(tp-rt-with-cleanup (tp-rt-b17-layer) (tp-rt-b17-color tp-rt-b17-text)
(setq tp-rt-b17-color "red" tp-rt-b17-text "one")
(define-tp tp-rt-b17-layer ()
'(face (:foreground $tp-rt-b17-color) tp-text $tp-rt-b17-text))
(with-temp-buffer
(insert "one")
(tp-set 1 4 'tp-rt-b17-layer)
(tp-with-batch-updates
(setq tp-rt-b17-color "blue") ; first change: no tp-text
(setq tp-rt-b17-text "two")) ; second change: tp-text affected
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"two"))
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"blue")))))
(ert-deftest tp-render-test-batch-where-widens-to-all-buffers ()
"A global change after a buffer-local one must reach other buffers."
(tp-rt-with-cleanup (tp-rt-b17b-layer) ()
(setq-default tp-rt-b17b-color "red")
(setq-default tp-rt-b17b-echo "old")
(define-tp tp-rt-b17b-layer ()
'(face (:foreground $tp-rt-b17b-color) help-echo $tp-rt-b17b-echo))
(let ((buf-a (generate-new-buffer " tp-rt-b17b-a"))
(buf-b (generate-new-buffer " tp-rt-b17b-b")))
(unwind-protect
(progn
(with-current-buffer buf-a
(insert "Hello") (tp-set 1 6 'tp-rt-b17b-layer))
(with-current-buffer buf-b
(insert "Hello") (tp-set 1 6 'tp-rt-b17b-layer))
(with-current-buffer buf-a
(tp-with-batch-updates
(setq-local tp-rt-b17b-color "blue") ; WHERE = buf-a
(setq tp-rt-b17b-echo "new"))) ; WHERE = global
;; The global change must not be trapped in buf-a's WHERE
(with-current-buffer buf-b
(should (equal (get-text-property 1 'help-echo) "new"))
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"red")))
;; buf-a gets both, with its local color honored
(with-current-buffer buf-a
(should (equal (get-text-property 1 'help-echo) "new"))
(should (equal (plist-get (get-text-property 1 'face) :foreground)
"blue"))))
(kill-buffer buf-a)
(kill-buffer buf-b)
(setq-default tp-rt-b17b-color nil)
(setq-default tp-rt-b17b-echo nil)))))
;;; B18: multi-interval reactive strings keep per-interval styling
(ert-deftest tp-render-test-reactive-text-keeps-per-interval-props ()
"A propertized reactive string renders each interval's own props."
(tp-rt-with-cleanup (tp-rt-b18-layer) (tp-rt-b18-text)
(setq tp-rt-b18-text "init")
(define-tp tp-rt-b18-layer () '(tp-text $tp-rt-b18-text))
(with-temp-buffer
(insert "init")
(tp-set 1 5 'tp-rt-b18-layer)
(setq tp-rt-b18-text (concat (propertize "AB" 'face 'bold)
(propertize "CD" 'face 'italic)))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"ABCD"))
;; Position-0 props must not smear over the whole region
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 2 'face) 'bold))
(should (eq (get-text-property 3 'face) 'italic))
(should (eq (get-text-property 4 'face) 'italic)))))
;;; B19: :transform applies on the initial nil-tp-text render too
(ert-deftest tp-render-test-transform-applies-on-initial-render ()
"First render of a nil tp-text layer shows the transformed text."
(tp-rt-with-cleanup (tp-rt-b19-layer) (tp-rt-b19-amount)
(setq tp-rt-b19-amount nil)
(define-tp tp-rt-b19-layer ()
:props '(face bold tp-text $tp-rt-b19-amount)
:transform (lambda (s) (concat "$" s)))
(with-temp-buffer
(insert "5.00")
(tp-set 1 5 'tp-rt-b19-layer)
;; Initial rendering must match later reactive renderings
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"$5.00"))
;; The model (variable and tp-text prop) keeps the raw value
(should (equal tp-rt-b19-amount "5.00"))
(should (equal (get-text-property 1 'tp-text) "5.00"))
(should (eq (get-text-property 1 'face) 'bold))
;; And a later update stays consistent
(setq tp-rt-b19-amount "6.00")
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"$6.00")))))
(ert-deftest tp-render-test-transform-applies-on-initial-string-render ()
"String form of a nil tp-text layer also shows the transformed text."
(tp-rt-with-cleanup (tp-rt-b19s-layer) (tp-rt-b19s-amount)
(setq tp-rt-b19s-amount nil)
(define-tp tp-rt-b19s-layer ()
:props '(face bold tp-text $tp-rt-b19s-amount)
:transform (lambda (s) (concat "$" s)))
(let ((result (tp-set "5.00" 'tp-rt-b19s-layer)))
(should (equal result "$5.00"))
;; Model keeps the raw value
(should (equal tp-rt-b19s-amount "5.00"))
(should (equal (get-text-property 0 'tp-text result) "5.00"))
(should (eq (get-text-property 0 'face result) 'bold)))))
(provide 'tp-render-tests)
;;; tp-render-tests.el ends here

501
tp-render.el Normal file
View File

@ -0,0 +1,501 @@
;;; 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
;; installs itself into tp-reactive.el (update/flush hooks) and
;; tp-ops.el (`tp-text' handler).
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(require 'tp-reactive)
(require 'tp-layer)
(require 'tp-ops)
(require 'tp-search)
(defun tp--layer-reactive-props (layer-name)
"Collect LAYER-NAME's unresolved reactive props from `tp-reactive-deps'.
Each dependency entry stores only the portions of the layer's props
that reference one variable; this merges the fragments back into a
single plist with the `$var' markers intact. Returns nil when the
layer has no reactive props (data-only dependencies store nil)."
(let ((all nil))
(dolist (dep tp-reactive-deps)
(let ((layer-entry (assoc layer-name (cdr dep))))
(when (and layer-entry (cdr layer-entry))
(setq all (if all
(tp--deep-merge-plist all (cdr layer-entry))
(copy-sequence (cdr layer-entry)))))))
all))
(defun tp--layer-render-props (layer-name override-alist)
"Return LAYER-NAME's props for re-rendering in the current buffer.
Starts from the stored layer definition and deep-merges the layer's
reactive props re-resolved against the current variable values, so
buffer-local values are honored when the target buffer is current.
OVERRIDE-ALIST maps variables to not-yet-visible new values (the
variable watcher runs before the variable is actually set) and takes
precedence over `symbol-value'. Returns nil when the layer has no
usable definition."
(let ((base (tp-layer-props layer-name t))) ; include tp-name for tracking
(when base
(let ((reactive (tp--layer-reactive-props layer-name)))
(if reactive
(tp--deep-merge-plist
base (tp--resolve-reactive-symbols reactive override-alist))
base)))))
(defun tp--update-layer-computed (layer-name override-alist)
"Update computed reactive variables for LAYER-NAME with OVERRIDE-ALIST.
Evaluates compute functions and updates the reactive variable values.
A compute function returning nil is a legitimate result and is
propagated; only computes that signal an error are skipped (see
`tp--compute-error').
Returns an updated override-alist with the new computed values."
(when-let ((computed (cdr (assoc layer-name tp-layer-computed))))
(dolist (comp computed)
(let* ((var-sym (car comp))
(compute-fn (cdr comp))
;; Temporarily bind variables to their new values from override-alist
;; before calling the compute function
(computed-val
(condition-case err
(cl-progv
(mapcar #'car override-alist)
(mapcar #'cdr override-alist)
(funcall compute-fn))
(error
(message "tp: compute error for %s.%s: %s"
layer-name var-sym err)
tp--compute-error))))
(unless (eq computed-val tp--compute-error)
;; Update the global variable
(set var-sym computed-val)
;; Add to override-alist for property resolution
(push (cons var-sym computed-val) override-alist)
;; Also update the layer properties if the computed var is used in props
(let ((current-props (cdr (assoc layer-name tp-layer-alist))))
(when current-props
(when-let ((all-reactive-props (tp--layer-reactive-props layer-name)))
(let ((resolved-props (tp--resolve-reactive-symbols
all-reactive-props override-alist)))
(when resolved-props
;; Deep-merge the resolved props into the current layer
;; props so sibling static attributes nested in plists
;; (e.g. a :background next to a reactive :foreground)
;; survive the update.
(tp--set-layer-props
layer-name
(tp--deep-merge-plist current-props resolved-props)))))))))))
override-alist)
(defun tp--update-layer-regions (layer-name &optional where override-alist)
"Update text regions that have LAYER-NAME applied.
Re-applies the layer's current properties to every region tagged with
the layer's `tp-name'. The layer's OWN property keys are replaced
with their current values (so refresh is idempotent: a face variable
changing from bold to italic yields italic, not (italic bold)), while
properties contributed by other sources are left untouched.
WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update all buffers that have the text property.
OVERRIDE-ALIST maps reactive variables to their new values when the
watcher fires before the variables are set; layer props are
re-resolved against it in each target buffer, so buffer-local
variable values are honored."
(let ((update-buffer
(lambda ()
(let ((props (tp--layer-render-props layer-name override-alist)))
(when props
(save-excursion
;; Callback for tp-search-map: replaces the layer's own
;; property keys on the matched region. Returns nil to
;; prevent tp-search-map from replacing the text.
(tp-search-map
(lambda (_text start end)
(cl-loop for (key val) on props by #'cddr
do (put-text-property start end key val))
nil)
'tp-name layer-name)))))))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(funcall update-buffer))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(funcall update-buffer)))))))
(defun tp--find-tp-text-reactive-var (layer-name)
"Find the reactive variable symbol used for tp-text in LAYER-NAME.
Returns the variable symbol (e.g., tp-test-counter) if tp-text uses a
reactive variable (e.g., $tp-test-counter), or nil if not found.
Searches through `tp-reactive-deps' to find the original reactive props."
(catch 'found
(dolist (dep tp-reactive-deps)
(let* ((var-sym (car dep))
(layer-entry (assoc layer-name (cdr dep))))
(when layer-entry
(let ((reactive-props (cdr layer-entry)))
;; Check if tp-text in reactive-props uses this variable
(when (plist-member reactive-props 'tp-text)
(let ((tp-text-val (plist-get reactive-props 'tp-text)))
;; Check if tp-text-val is a reactive symbol for this variable
(when (and (tp--reactive-symbol-p tp-text-val)
(eq (tp--reactive-var-symbol tp-text-val) var-sym))
(throw 'found var-sym))))))))
nil))
(defun tp--tp-text-transform (layer-name text)
"Return TEXT transformed by LAYER-NAME's `:transform', or TEXT.
Transform errors are reported and TEXT is returned unchanged; a
non-string transform result is ignored as well."
(let ((transform-fn (when layer-name
(cdr (assoc layer-name tp-layer-transforms)))))
(if (not transform-fn)
text
(condition-case err
(let ((result (funcall transform-fn text)))
(tp-debug-log " Transform %s: %S -> %S" layer-name text result)
(if (stringp result) result text))
(error
(message "tp: transform error for %s: %s" layer-name err)
text)))))
(defun tp--merge-embedded-props (embedded props)
"Merge the EMBEDDED string props plist under PROPS; PROPS win.
Like `tp--merge-string-props-into-plist' but takes the embedded plist
directly instead of sampling position 0 of a string, so callers can
merge per property interval. Face-family values (see
`tp-face-properties') are merged with PROPS taking precedence; other
conflicting keys keep the PROPS value; keys only in EMBEDDED are
added."
(let ((result (copy-sequence props)))
(cl-loop for (key val) on embedded by #'cddr
do (let ((existing (plist-get result key)))
(setq result
(plist-put result key
(if existing
(if (memq key tp-face-properties)
(tp--merge-face-values val existing)
existing)
val)))))
result))
(defun tp--apply-reactive-text-props (source props offset &optional target)
"Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET.
SOURCE is the (possibly propertized) replacement string; TARGET is a
string, or nil for the current buffer. For every embedded-property
interval of SOURCE the interval's props are merged under PROPS (see
`tp--merge-embedded-props') and the result is applied to the
corresponding span of TARGET shifted by OFFSET. This keeps
per-interval styling of propertized reactive strings intact instead
of smearing position-0 props across the whole region."
(tp--map-intervals
source nil nil
(lambda (istart iend str-props)
(let ((merged (if str-props
(tp--merge-embedded-props str-props props)
props)))
(cl-loop for (key val) on merged by #'cddr
do (put-text-property (+ offset istart) (+ offset iend)
key val target))))))
(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 all buffers that have the text property (setq case).
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))
(save-excursion
(tp--replace-reactive-text-in-buffer
layer-name new-text props)))))))))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(funcall update-buffer))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(funcall update-buffer)))))))
(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.
Text properties embedded in NEW-TEXT are merged with PROPS per
embedded interval, so a multi-interval propertized reactive string
keeps its per-character styling. Existing text properties whose keys
are set neither by PROPS nor by NEW-TEXT's embedded props are
preserved, so one layer's text update does not erase other layers'
contributions on the same region."
(goto-char (point-min))
(let ((match (text-property-search-forward 'tp-name layer-name t))
(plain-text (substring-no-properties new-text)))
(while match
(let* ((m-start (prop-match-beginning match))
(m-end (prop-match-end match))
(old-text (buffer-substring-no-properties m-start m-end)))
(unless (equal old-text plain-text)
;; Text content differs: replace it, carrying over the existing
;; properties whose keys this layer does not set.
(let ((existing-props (text-properties-at m-start)))
(delete-region m-start m-end)
(goto-char m-start)
(insert plain-text)
(let ((new-end (+ m-start (length plain-text))))
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member props key)
(put-text-property m-start new-end key val))))))
;; Apply the layer's props, merged per embedded interval of NEW-TEXT.
;; Keys are replaced (not accumulated); unrelated keys are untouched.
(tp--apply-reactive-text-props new-text props m-start))
;; Search for next match
(setq match (text-property-search-forward 'tp-name layer-name t)))))
(defun tp--tp-text-replace (start end final-text result-props object preserve-props)
"Replace [START, END) of OBJECT with FINAL-TEXT, handling props.
Implements the text replacement of `tp--handle-tp-text-property' and
returns its (PROPS NEW-END NEW-OBJECT) result.
For a string OBJECT a NEW string is built as prefix + FINAL-TEXT +
suffix, so text outside the region survives. RESULT-PROPS (merged
per embedded interval of FINAL-TEXT) are applied to the replaced span
here, because callers can only apply props from index 0, which would
smear them over the preserved prefix; the returned NEW-END is 0 so
the caller's own application over [0, NEW-END) is a no-op.
For buffers the region text is replaced in place and the returned
NEW-END is the end of the inserted text; the caller applies
RESULT-PROPS itself.
When PRESERVE-PROPS is non-nil, properties present at START whose
keys RESULT-PROPS does not set are re-applied over the replacement."
(if (stringp object)
(let* ((plain (substring-no-properties final-text))
;; Splice: keep the string outside [start, end) intact.
(new-string (concat (substring object 0 start)
plain
(substring object end)))
(new-end (+ start (length plain)))
(existing-props (when preserve-props
(text-properties-at start object))))
;; Preserve non-conflicting existing props of the replaced region
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member result-props key)
(put-text-property start new-end key val new-string)))
;; Apply the merged props per embedded interval of FINAL-TEXT
(tp--apply-reactive-text-props final-text result-props start new-string)
(list result-props 0 new-string))
;; Buffer object
(with-current-buffer (or object (current-buffer))
(let ((old-text (buffer-substring-no-properties start end)))
(if (equal old-text (substring-no-properties final-text))
;; Same text content, no replacement needed
(list result-props end object)
;; Need to replace text
(let ((existing-props (when preserve-props
(text-properties-at start)))
(inhibit-read-only t))
(save-excursion
(delete-region start end)
(goto-char start)
;; Insert without properties - the caller applies RESULT-PROPS
(insert (substring-no-properties final-text)))
(let ((new-end (+ start (length final-text))))
;; Re-apply existing properties to new text region if preserving
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member result-props key)
(put-text-property start new-end key val object)))
(list result-props new-end object))))))))
(defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode)
"Handle tp-text property in PROPS for region from START to END in OBJECT.
If tp-text is nil, initialize it to the current text in the region;
when the layer has a `:transform', the displayed text is the
transformed value (matching later reactive updates) while the model -
the reactive variable and the `tp-text' property - keeps the raw text.
If tp-text is a string different from current text, replace the text.
When PRESERVE-PROPS is non-nil, existing text properties are preserved
on the replaced text (used by tp-set and tp-add).
MERGE-MODE is retained for backward compatibility but no longer affects behavior.
All modes now preserve embedded text properties from tp-text, with props taking
precedence over embedded props when there's a conflict.
Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props,
NEW-END is the new end position after any text replacement, and
NEW-OBJECT is the new string object (only different for strings whose
text was replaced; see `tp--tp-text-replace' for the string-object
convention of a 0 NEW-END with pre-applied properties)."
(ignore merge-mode)
(if (not (plist-member props 'tp-text))
;; tp-text not in props - return unchanged
(list props end object)
(let ((tp-text-val (plist-get props 'tp-text))
(layer-name (plist-get props 'tp-name)))
(cond
;; tp-text is nil - initialize it to the current text
((null tp-text-val)
(let ((current-text
(if (stringp object)
(substring-no-properties object start end)
(with-current-buffer (or object (current-buffer))
(buffer-substring-no-properties start end)))))
;; If tp-text uses a reactive variable, update that variable to match
;; This ensures the reactive variable and buffer text stay in sync
(when layer-name
(when-let ((reactive-var (tp--find-tp-text-reactive-var layer-name)))
;; Update the reactive variable with the current text
;; Note: Using global `set` here because the layer definition is global.
;; When the variable is changed, the reactive watcher will update all
;; buffers that have this layer applied.
(set reactive-var current-text)
;; Also update the layer definition so future accesses see the new value
(let ((layer-props (cdr (assoc layer-name tp-layer-alist))))
(when layer-props
(tp--set-layer-props layer-name
(plist-put layer-props 'tp-text current-text))))))
(setq props (plist-put props 'tp-text current-text))
;; Apply the layer's :transform to the DISPLAYED text on this first
;; render too, so the initial rendering matches later reactive
;; updates. The model value stays the raw text.
(let ((display-text (tp--tp-text-transform layer-name current-text)))
(if (equal display-text current-text)
(list props end object)
(tp--tp-text-replace
start end display-text
(tp--merge-string-props-into-plist display-text props)
object preserve-props)))))
;; tp-text has a string value - replace the text in the region
((stringp tp-text-val)
;; Apply transform if layer has one registered
(let* ((final-text (tp--tp-text-transform layer-name tp-text-val))
;; Embedded text properties from tp-text are preserved in all
;; cases. The props passed to this function take precedence
;; over embedded props when there's a conflict (e.g. both have
;; a `face' property).
(result-props
(tp--merge-string-props-into-plist final-text props)))
(tp--tp-text-replace start end final-text result-props
object preserve-props)))
;; Other types - return unchanged
(t (list props end object))))))
(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)
(let ((tp--reactive-updating t))
;; Update computed properties for this layer
(let ((updated-override
(tp--update-layer-computed layer-name override-alist)))
;; Update only the reactive properties in the layer definition.
;; Buffer-local changes must not leak into the global definition;
;; the buffer re-render below resolves against the buffer-local
;; values instead.
(when (and reactive-props (not (bufferp where)))
(let ((resolved-props (tp--resolve-reactive-symbols
reactive-props updated-override))
(current-props (cdr (assoc layer-name tp-layer-alist))))
(when current-props
;; Deep merge the resolved reactive props into the current
;; layer props to preserve nested plist values (like face)
(tp--set-layer-props
layer-name
(tp--deep-merge-plist current-props resolved-props)))))
;; Update text regions with this layer (or defer if batching)
(if tp--batch-update-active
;; Batching: defer the buffer update
(progn
(tp-debug-log " Deferring buffer update for %s (batch mode)"
layer-name)
(tp--queue-batch-update layer-name symbol where
tp-text-affected))
;; Normal: update immediately
(tp-debug-log " Updating layer %s (tp-text affected: %s)"
layer-name (if tp-text-affected "yes" "no"))
(if tp-text-affected
(tp--update-reactive-text layer-name where updated-override)
(tp--update-layer-regions layer-name where updated-override)))))
;; Re-renders queued by nested variable writes during this update are
;; flushed now that the outermost update has finished.
(unless tp--batch-update-active
(when tp--batch-update-pending
(tp--flush-batch-updates))))))
(defun tp--reactive-flush-entry (layer-name where tp-text-affected)
"Re-render LAYER-NAME's regions in WHERE (or all buffers when nil).
TP-TEXT-AFFECTED non-nil means the layer's `tp-text' changed and the
text itself must be replaced. Runs after the changed variables have
actually been set, so layer props re-resolve against current
\(buffer-local aware) values. Installed as
`tp--reactive-flush-function'."
(if tp-text-affected
(tp--update-reactive-text layer-name where)
(tp--update-layer-regions layer-name where)))
;; Install the engine into the lower modules.
(setq tp--reactive-update-function #'tp--reactive-apply-update)
(setq tp--reactive-flush-function #'tp--reactive-flush-entry)
(setq tp--tp-text-handler-function #'tp--handle-tp-text-property)
(setq tp--layer-refresh-function #'tp--update-layer-regions)
(provide 'tp-render)
;;; tp-render.el ends here

376
tp-search-tests.el Normal file
View File

@ -0,0 +1,376 @@
;;; tp-search-tests.el --- ERT regression tests for tp-search.el -*- lexical-binding: t -*-
;;; Commentary:
;; Regression tests for confirmed bugs fixed in the search module
;; (tp-search.el). Each section is tagged with the canonical bug id
;; it guards against.
;;; Code:
(require 'ert)
(require 'tp)
;;; B37: backward searches must use `equal' matching like tp-forward
(ert-deftest tp-search-test-backward-value-matches-forward ()
"tp-backward with a non-nil VALUE finds the same region tp-forward finds.
The old code passed no predicate to `text-property-search-backward',
whose default matches values NOT `equal' to VALUE (inverted)."
(with-temp-buffer
(insert "aaa bbb aaa ")
(put-text-property 1 4 'k 'x)
(put-text-property 5 8 'k 'y)
(put-text-property 9 12 'k 'x)
(goto-char (point-min))
(let ((fwd (tp-forward 'k 'y)))
(should fwd)
(should (equal (list (prop-match-beginning fwd)
(prop-match-end fwd)
(prop-match-value fwd))
'(5 8 y))))
(goto-char (point-max))
(let ((bwd (tp-backward 'k 'y)))
(should bwd)
(should (equal (list (prop-match-beginning bwd)
(prop-match-end bwd)
(prop-match-value bwd))
'(5 8 y))))))
(ert-deftest tp-search-test-backward-value-adjacent-regions ()
"tp-backward finds a matching region among adjacent (gap-free) runs."
(with-temp-buffer
(insert "aaabbbccc")
(put-text-property 1 4 'k 'x)
(put-text-property 4 7 'k 'y)
(put-text-property 7 10 'k 'x)
(goto-char (point-max))
(let ((m (tp-backward 'k 'y)))
(should m)
(should (= (prop-match-beginning m) 4))
(should (= (prop-match-end m) 7))
(should (eq (prop-match-value m) 'y)))))
(ert-deftest tp-search-test-backward-value-n-walks-regions ()
"tp-backward with N=2 walks two matching regions backward."
(with-temp-buffer
(insert "aaa bbb aaa ")
(put-text-property 1 4 'k 'x)
(put-text-property 5 8 'k 'x)
(put-text-property 9 12 'k 'x)
(goto-char (point-max))
(let ((m (tp-backward 'k 'x nil 2)))
(should m)
(should (= (prop-match-beginning m) 5)))))
(ert-deftest tp-search-test-backward-value-no-match-returns-nil ()
"tp-backward returns nil when no region has an `equal' value."
(with-temp-buffer
(insert "aaa bbb")
(put-text-property 1 4 'k 'x)
(goto-char (point-max))
(should (null (tp-backward 'k 'missing)))))
(ert-deftest tp-search-test-backward-do-value-buffer ()
"tp-backward-do with a non-nil VALUE rewrites the matching region."
(with-temp-buffer
(insert "aaa bbb aaa ")
(put-text-property 1 4 'k 'x)
(put-text-property 5 8 'k 'y)
(put-text-property 9 12 'k 'x)
(let ((count (tp-backward-do #'upcase 'k 'y)))
(should (= count 1))
(should (equal (buffer-substring-no-properties 1 13)
"aaa BBB aaa ")))))
;;; B38: zero-width patterns must not loop forever in buffer branches
(ert-deftest tp-search-test-match-empty-pattern-buffer-terminates ()
"tp-match-set with an empty literal pattern terminates on buffers."
(with-temp-buffer
(insert "abc")
(let ((regions (tp-match-set "" '(face bold))))
;; Zero-width matches are recorded at each position, like the
;; string branch records them.
(should (equal regions '((1 . 1) (2 . 2) (3 . 3) (4 . 4)))))))
(ert-deftest tp-search-test-regexp-zero-width-buffer-terminates ()
"tp-regexp-set with a regexp matching empty terminates on buffers."
(with-temp-buffer
(insert "axbxc")
(let ((regions (tp-regexp-set "x*" '(face bold))))
(should regions)
;; The actual x's still got their property.
(should (eq (get-text-property 2 'face) 'bold))
(should (eq (get-text-property 4 'face) 'bold)))))
(ert-deftest tp-search-test-match-empty-pattern-string-clean ()
"tp-match-set with an empty pattern on a string no-ops cleanly.
The old string branch signaled args-out-of-range after scanning past
the end of the string."
(let ((result (tp-match-set "" '(face bold) "abc")))
(should (equal result "abc"))))
(ert-deftest tp-search-test-regexp-zero-width-string-clean ()
"tp-regexp-set with a zero-width-capable regexp works on strings."
(let ((result (tp-regexp-set "x*" '(face bold) "axb")))
(should (equal (substring-no-properties result) "axb"))
(should (eq (get-text-property 1 'face result) 'bold))))
;;; B39: length-changing replacements error on strings, work in buffers
(ert-deftest tp-search-test-forward-do-longer-replacement-errors ()
"A replacement longer than the match signals a clear error on strings.
Strings cannot change length in place; the old code silently truncated
(or signaled args-out-of-range past the string end). The string is
left unchanged."
(let ((str (copy-sequence "hello world")))
(tp-set 6 11 '(marker t) str)
(should-error (tp-forward-do (lambda (txt) (concat (upcase txt) "XYZ"))
'marker nil str))
(should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-forward-do-longer-in-bounds-errors ()
"A longer in-bounds replacement errors instead of clobbering.
Old code silently wrote 10 chars, yielding \"hellohellod\"."
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str)
(should-error (tp-forward-do (lambda (txt) (concat txt txt))
'marker nil str))
(should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-backward-do-longer-replacement-errors ()
"tp-backward-do rejects length-changing replacements on strings."
(let ((str (copy-sequence "hello world")))
(tp-set 6 11 '(marker t) str)
(should-error (tp-backward-do (lambda (txt) (concat (upcase txt) "12345"))
'marker nil str))
(should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-search-map-longer-replacement-errors ()
"tp-search-map rejects length-changing replacements on strings."
(let ((str (copy-sequence "hello world")))
(tp-set 6 11 '(marker t) str)
(should-error (tp-search-map (lambda (txt) (concat (upcase txt) "!!!"))
'marker nil str))
(should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-forward-do-shorter-replacement-errors ()
"A shorter replacement errors instead of leaving residue (\"ABllo\")."
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str)
(should-error (tp-forward-do (lambda (_txt) "AB") 'marker nil str))
(should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-search-map-same-length-string-ok ()
"Same-length replacements still mutate the string in place."
(let ((str (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
(should (= (tp-search-map #'upcase 'marker nil str) 2))
(should (equal (substring-no-properties str) "HELLO world HELLO"))))
;;; B43: -do shortfall is all-or-nothing on strings and buffers alike
(ert-deftest tp-search-test-forward-do-shortfall-string ()
"Requesting the Nth match when fewer exist applies nothing (string).
The count of available matches is still returned."
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str)
(should (= (tp-forward-do #'upcase 'marker nil str 3) 1))
(should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-forward-do-shortfall-buffer ()
"Requesting the Nth match when fewer exist applies nothing (buffer)."
(with-temp-buffer
(insert "hello world")
(put-text-property 1 6 'marker t)
(should (= (tp-forward-do #'upcase 'marker t nil 3) 1))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"hello world"))))
(ert-deftest tp-search-test-backward-do-shortfall-string ()
"tp-backward-do shortfall applies nothing on strings."
(let ((str (copy-sequence "hello world")))
(tp-set 6 11 '(marker t) str)
(should (= (tp-backward-do #'upcase 'marker nil str 2) 1))
(should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-forward-do-exact-count-applies ()
"With exactly TIMES matches, FUNCTION is applied to the TIMES-th."
(let ((str (copy-sequence "aaa bbb aaa")))
(tp-set 0 3 '(marker t) str)
(tp-set 8 11 '(marker t) str)
(should (= (tp-forward-do #'upcase 'marker nil str 2) 2))
(should (equal (substring-no-properties str) "aaa bbb AAA"))))
(ert-deftest tp-search-test-forward-do-buffer-longer-replacement-grows ()
"Buffers may grow on longer replacements (delete-region + insert).
Uses an explicit VALUE: the buffer paths of the -do functions match
with predicate t, where VALUE nil matches property-absent runs."
(with-temp-buffer
(insert "hello world")
(put-text-property 1 6 'marker t)
(tp-forward-do (lambda (txt) (concat txt txt)) 'marker t)
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"hellohello world"))))
;;; B40: tp-search-map must operate on OBJECT, not the current buffer
(ert-deftest tp-search-test-search-map-non-current-buffer ()
"tp-search-map with a buffer OBJECT mutates that buffer only."
(let ((target (generate-new-buffer " tp-search-test-target")))
(unwind-protect
(progn
(with-current-buffer target
(insert "aaa bbb")
(put-text-property 1 4 'marker t))
(with-temp-buffer
(insert "current buffer text")
(let ((count (tp-search-map #'upcase 'marker nil target)))
(should (= count 1)))
;; Current buffer untouched.
(should (equal (buffer-string) "current buffer text")))
;; Target buffer modified.
(should (equal (with-current-buffer target
(buffer-substring-no-properties (point-min)
(point-max)))
"AAA bbb")))
(kill-buffer target))))
(ert-deftest tp-search-test-search-do-non-current-buffer-bounds ()
"tp--search-do computes default bounds in OBJECT, not the current buffer."
(let ((target (generate-new-buffer " tp-search-test-target2")))
(unwind-protect
(progn
(with-current-buffer target
(insert "aaa bbb ccc")
(put-text-property 9 12 'marker t))
(with-temp-buffer
;; Current buffer is much shorter than the target.
(insert "x")
(let ((seen nil))
(tp--search-do (lambda (match _obj) (push match seen))
'marker nil target)
(should (equal seen '((9 12 t)))))))
(kill-buffer target))))
;;; B41: length-changing replacements over multiple matches
(ert-deftest tp-search-test-search-map-growing-replacements ()
"Growing replacements do not corrupt later match positions."
(with-temp-buffer
(insert "aaa bbb ccc")
(put-text-property 1 4 'marker t)
(put-text-property 5 8 'marker t)
(put-text-property 9 12 'marker t)
(let ((count (tp-search-map (lambda (_txt) "XXXXXX") 'marker nil nil)))
(should (= count 3))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"XXXXXX XXXXXX XXXXXX")))))
(ert-deftest tp-search-test-search-map-shrinking-replacements ()
"Shrinking replacements do not corrupt later match positions."
(with-temp-buffer
(insert "aaa bbb ccc")
(put-text-property 1 4 'marker t)
(put-text-property 5 8 'marker t)
(put-text-property 9 12 'marker t)
(tp-search-map (lambda (_txt) "-") 'marker nil nil)
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"- - -"))))
(ert-deftest tp-search-test-search-map-mixed-length-positions ()
"Callbacks see up-to-date positions after earlier length changes."
(with-temp-buffer
(insert "aaa bbb ccc")
(put-text-property 1 4 'marker t)
(put-text-property 5 8 'marker t)
(put-text-property 9 12 'marker t)
(let ((texts nil))
(tp-search-map (lambda (txt _start _end idx)
(push txt texts)
(format "<%d>%s" idx txt))
'marker nil nil)
;; Each callback received the intact matched text, not garbage
;; from stale positions.
(should (equal (nreverse texts) '("aaa" "bbb" "ccc")))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"<0>aaa <1>bbb <2>ccc")))))
;;; B42: tp-match-add / tp-regexp-add preserve existing faces in buffers
(ert-deftest tp-search-test-match-add-buffer-preserves-face ()
"tp-match-add on a buffer merges faces instead of replacing them."
(with-temp-buffer
(insert "hello")
(put-text-property 1 6 'face 'italic)
(tp-match-add "hello" '(face bold))
(should (equal (get-text-property 1 'face) '(bold italic)))))
(ert-deftest tp-search-test-match-add-face-string-buffer-parity ()
"tp-match-add merges faces identically for strings and buffers."
(let* ((str (propertize "hello" 'face 'italic))
(str-face (get-text-property 0 'face
(tp-match-add "hello" '(face bold) str)))
(buf-face (with-temp-buffer
(insert "hello")
(put-text-property 1 6 'face 'italic)
(tp-match-add "hello" '(face bold))
(get-text-property 1 'face))))
(should (equal str-face buf-face))
(should (equal buf-face '(bold italic)))))
(ert-deftest tp-search-test-regexp-add-buffer-preserves-face ()
"tp-regexp-add on a buffer merges faces instead of replacing them."
(with-temp-buffer
(insert "abc 123")
(put-text-property 5 8 'face 'underline)
(tp-regexp-add "[0-9]+" '(face bold))
(should (equal (get-text-property 5 'face) '(bold underline)))))
(ert-deftest tp-search-test-match-add-buffer-non-face-deep-merge ()
"tp-match-add still deep-merges non-face plist properties in buffers."
(with-temp-buffer
(insert "hello")
(put-text-property 1 6 'data '(:a 1))
(tp-match-add "hello" '(data (:b 2)))
(let ((val (get-text-property 1 'data)))
(should (equal (plist-get val :a) 1))
(should (equal (plist-get val :b) 2)))))
;;; B44: property removal through tp-search-map on strings
(ert-deftest tp-search-test-search-map-removes-props-on-string ()
"A callback returning a stripped string removes properties."
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t face bold) str)
(tp-search-map (lambda (txt) (substring-no-properties txt))
'marker nil str)
(should (null (text-properties-at 0 str)))
(should (equal (substring-no-properties str) "hello world"))))
(ert-deftest tp-search-test-search-map-removes-single-prop-on-string ()
"A callback removing one property keeps the others."
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t face bold) str)
(tp-search-map (lambda (txt)
(remove-text-properties 0 (length txt) '(face nil) txt)
txt)
'marker nil str)
(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)
(ert-deftest tp-search-test-search-map-nil-return-no-replacement ()
"A callback returning nil leaves text and properties untouched."
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t face bold) str)
(let ((count (tp-search-map (lambda (_txt) nil) 'marker nil str)))
(should (= count 1))
(should (equal (substring-no-properties str) "hello world"))
(should (eq (get-text-property 0 'face str) 'bold)))))
(provide 'tp-search-tests)
;;; tp-search-tests.el ends here

818
tp-search.el Normal file
View File

@ -0,0 +1,818 @@
;;; tp-search.el --- Pattern matching and property search 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:
;; Pattern-driven property application (`tp-match-*', `tp-regexp-*')
;; and property-run search/navigation (`tp-search', `tp-search-map',
;; `tp-forward', `tp-backward', `tp-forward-do', `tp-backward-do').
;;; Code:
(require 'cl-lib)
(require 'text-property-search)
(require 'tp-core)
(require 'tp-layer)
(require 'tp-ops)
(defun tp--pattern-apply-single (pattern properties apply-fn object literal)
"Apply APPLY-FN to matches of single PATTERN in OBJECT.
When LITERAL is non-nil, PATTERN is matched literally; otherwise it
is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for
each match.
For strings, returns a NEW string with properties applied
\(non-destructive).
For buffers, modifies in-place and returns list of regions.
Zero-width matches (an empty literal pattern, or a regexp that can
match the empty string) are recorded and the scan advances one
position past them, so the search always terminates."
(let ((regexp (if literal (regexp-quote pattern) pattern)))
(cond
;; String object
((stringp object)
;; First, collect all match positions from the original string
(let ((matches nil)
(pos 0)
(limit (length object)))
(while (and (<= pos limit) (string-match regexp object pos))
(let ((beg (match-beginning 0))
(end (match-end 0)))
(push (cons beg end) matches)
(setq pos (if (= beg end) (1+ beg) end))))
;; Apply function to each match in order (reverse to get correct order)
;; Make a copy to ensure original string is not modified
(let ((result (copy-sequence object)))
(dolist (match (nreverse matches))
(when properties
(setq result (funcall apply-fn
(car match) (cdr match)
properties result))))
result)))
;; Buffer or nil (current buffer)
(t
(let ((buf (or object (current-buffer))))
(tp-with-current-buffer buf
(save-excursion
(goto-char (point-min))
(let (regions (keep-going t))
(while (and keep-going (re-search-forward regexp nil t))
(let ((beg (match-beginning 0))
(end (match-end 0)))
(when properties
(funcall apply-fn beg end properties buf))
(push (cons beg end) regions)
;; Guard against zero-width matches looping forever
(when (= beg end)
(if (eobp)
(setq keep-going nil)
(forward-char 1)))))
(nreverse regions)))))))))
(defun tp--pattern-apply (pattern properties apply-fn object literal)
"Apply APPLY-FN to matches of PATTERN (one pattern or a list).
When LITERAL is non-nil, patterns are matched literally; otherwise
they are regexps. APPLY-FN is called with (START END PROPS OBJECT)
for each match.
For strings, returns a NEW string with properties applied
\(non-destructive).
For buffers, returns list of regions."
(let ((patterns (if (listp pattern) pattern (list pattern))))
(cond
;; String object
((stringp object)
(let ((result object))
(dolist (p patterns)
(setq result (tp--pattern-apply-single p properties apply-fn
result literal)))
result))
;; Buffer or nil (current buffer)
(t
(let ((all-regions nil))
(dolist (p patterns)
(let ((regions (tp--pattern-apply-single p properties apply-fn
object literal)))
(setq all-regions (append all-regions regions))))
all-regions)))))
(defun tp--match-apply-single (pattern properties apply-fn object)
"Apply APPLY-FN to literal matches of single PATTERN in OBJECT.
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))
(defun tp--match-apply (pattern properties apply-fn &optional object)
"Internal function to apply APPLY-FN to matches of PATTERN.
PATTERN can be a string or a list of strings (multiple patterns).
When PATTERN is a list, each element is a pattern to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(tp--pattern-apply pattern properties apply-fn object t))
(defun tp--regexp-apply-single (pattern properties apply-fn object)
"Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(tp--pattern-apply-single pattern properties apply-fn object nil))
(defun tp--regexp-apply (pattern properties apply-fn &optional object)
"Internal function to apply APPLY-FN to regexp matches of PATTERN.
PATTERN can be a string (single regexp) or a list of strings (multiple regexps).
When PATTERN is a list, each element is a regexp to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
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))
(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
(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)
"Set properties on all occurrences of PATTERN.
(tp-match-set PATTERN PLIST &optional OBJECT)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
Each pattern will be matched and have properties applied.
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
Returns:
- For strings: the modified string
- For buffers: list of (START . END) pairs for all matches."
(tp--match-apply pattern (tp--ensure-props plist) #'tp-set object))
(defun tp-match-reset (pattern plist &optional object)
"Reset (completely replace) properties on all occurrences of PATTERN.
(tp-match-reset PATTERN PLIST &optional OBJECT)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
Unlike `tp-match-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of regions."
(tp--match-apply pattern (tp--ensure-props plist)
#'tp--reset-apply
object))
(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)
obj))
(defun tp-match-add (pattern plist &optional object)
"Add/update properties on all occurrences of PATTERN.
(tp-match-add PATTERN PLIST &optional OBJECT)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
Unlike `tp-match-set', this deeply merges nested properties."
(tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object))
(defun tp-regexp-set (pattern plist &optional object)
"Set properties on all matches of PATTERN (regexp).
(tp-regexp-set PATTERN PLIST &optional OBJECT)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
Each pattern will be matched and have properties applied.
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
Returns:
- For strings: the modified string
- For buffers: list of (START . END) pairs for all matches."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object))
(defun tp-regexp-reset (pattern plist &optional object)
"Reset (completely replace) properties on all regexp matches of PATTERN.
(tp-regexp-reset PATTERN PLIST &optional OBJECT)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
Unlike `tp-regexp-set', this completely replaces all existing properties.
For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of regions."
(tp--regexp-apply pattern (tp--ensure-props plist)
#'tp--reset-apply
object))
(defun tp-regexp-add (pattern plist &optional object)
"Add/update properties on all regexp matches of PATTERN.
(tp-regexp-add PATTERN PLIST &optional OBJECT)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
Unlike `tp-regexp-set', this deeply merges nested properties."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object))
(defun tp-search-forward (property &optional value predicate not-current)
"Search forward for text with PROPERTY.
Wraps `text-property-search-forward'."
(text-property-search-forward property value predicate not-current))
(defun tp-search-backward (property &optional value predicate not-current)
"Search backward for text with PROPERTY.
Wraps `text-property-search-backward'."
(text-property-search-backward property value predicate not-current))
(defun tp--property-search-backward (property value)
"Search backward for the previous region where PROPERTY `equal's VALUE.
This is the backward mirror of (text-property-search-forward PROPERTY
VALUE t): a region matches when its PROPERTY value is `equal' to
VALUE. It deliberately does not call
`text-property-search-backward' with predicate t, because that
primitive's non-default-predicate branch skips every other property
run when non-matching runs intervene (observed through Emacs 30.2),
silently missing valid matches.
If a matching region is found, move point to its beginning and
return a `prop-match' object whose end is clipped to the starting
point (matching the primitive's behavior when point starts inside a
matching region). Otherwise return nil and leave point alone."
(if (bobp)
nil
(let ((origin (point))
(found nil))
;; Walk PROPERTY runs before point; remember the last matching one.
;; tp--map-intervals clips the run containing ORIGIN to end there.
(tp--map-intervals
(current-buffer) (point-min) origin
(lambda (ibeg iend val)
(when (equal value val)
(setq found (list ibeg iend val)))
nil)
property)
(when found
(goto-char (car found))
(make-prop-match :beginning (car found)
:end (cadr found)
:value (caddr found))))))
(defun tp-forward (property &optional value object n)
"Search forward N times for text with PROPERTY.
Returns prop-match for buffers or list of (START END VALUE) for strings."
(let ((count (or n 1)))
(cond
;; String object - use tp-search
((stringp object)
(let ((matches (tp-search object property value)))
(seq-take matches count)))
;; Buffer or nil
(t
(let ((result nil)
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
(setq result (tp-search-forward property value t))))
result)))))
(defun tp-backward (property &optional value object n)
"Search backward N times for text with PROPERTY.
N is the number of searches, defaulting to 1.
VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer.
For buffers, returns the prop-match object from the last successful search.
For strings, returns a list of (START END VALUE) for the last N matches
in reverse order (from end to start).
Uses `tp-search-backward' for buffers and `tp-search' for strings."
(let ((count (or n 1)))
(cond
;; String object - use tp-search and reverse
((stringp object)
(let ((matches (nreverse (tp-search object property value))))
(seq-take matches count)))
;; Buffer or nil
(t
(let ((result nil)
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
;; `equal' matching, mirroring the predicate t that
;; `tp-forward' passes. The previous code used the default
;; nil predicate, which matches values NOT `equal' to VALUE
;; and so inverted the match when VALUE was non-nil.
(setq result (tp--property-search-backward property value))))
result)))))
(defun tp--forward-do (function property &optional value object times start end)
"Internal: search forward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT.
TIMES is the number of searches, defaulting to 1.
VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end.
FUNCTION is called only when the TIMES-th match exists; if fewer
matches are available, nothing is applied.
Returns the number of matches found (at most TIMES)."
(let ((count (or times 1)))
(cond
;; String object
((stringp object)
(let* ((start-pos (or start 0))
(end-pos (or end (length object)))
(all-matches (tp-search object property value))
(filtered-matches (seq-filter (lambda (m)
(and (>= (car m) start-pos)
(<= (cadr m) end-pos)))
all-matches))
(matches (seq-take filtered-matches count)))
;; All-or-nothing, mirroring the buffer path: FUNCTION targets
;; the TIMES-th match specifically, so when fewer matches exist
;; acting on a different one would hit the wrong target.
(when (= (length matches) count)
(funcall function (car (last matches)) object))
(length matches)))
;; Buffer or nil
(t
(let* ((buf (or object (current-buffer)))
(matches 0))
(tp-with-current-buffer buf
(let ((search-start (or start (point-min)))
(search-end (or end (point-max))))
(save-excursion
(goto-char search-start)
(dotimes (i count)
(when-let ((match (tp-search-forward property value t)))
(when (<= (prop-match-end match) search-end)
(when (= i (1- count))
(funcall function match buf))
(cl-incf matches)))))))
matches)))))
(defun tp--replace-match-text (function arity match obj &optional idx)
"Replace the text of MATCH in OBJ with the result of calling FUNCTION.
MATCH is either a (START END VALUE) list (string matches) or a
prop-match struct (buffer matches). ARITY is the precomputed
\(func-arity FUNCTION); depending on it, FUNCTION is called with
\(TEXT), (TEXT START), (TEXT START END) or - when IDX is non-nil and
FUNCTION accepts a 4th argument - (TEXT START END IDX).
If FUNCTION returns a string, it replaces the matched text:
- For string OBJ the replacement happens in place; since strings have
fixed length, a longer replacement is truncated to the match length
and a shorter one only replaces that portion. The replacement's
text properties (including their absence) are copied onto the
replaced portion.
- For buffer OBJ the match is replaced via `delete-region' + `insert'
\(the buffer may grow or shrink).
Any non-string return value leaves OBJ untouched."
(let* ((m-start (if (listp match) (car match) (prop-match-beginning match)))
(m-end (if (listp match) (cadr match) (prop-match-end match)))
(text (if (stringp obj)
(substring obj m-start m-end)
(buffer-substring m-start m-end)))
(max-arity (cdr arity))
(can-accept-start (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 2))))
(can-accept-end (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 3))))
(can-accept-idx (and idx
(or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 4)))))
(new-text (cond
(can-accept-idx (funcall function text m-start m-end idx))
(can-accept-end (funcall function text m-start m-end))
(can-accept-start (funcall function text m-start))
(t (funcall function text)))))
(when (stringp new-text)
(if (stringp obj)
;; For strings: copy text content and properties separately.
;; A string cannot change length in place, so a replacement
;; of a different length would silently corrupt the text
;; (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; \
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)
;; Copy properties from new-text to obj. Ranges with nil
;; properties are copied too, so FUNCTION can REMOVE
;; properties by returning a stripped string.
(let ((pos 0))
(while (< pos len)
(let* ((props (text-properties-at pos new-text))
(next-change (or (next-property-change pos new-text)
len)))
(set-text-properties (+ m-start pos)
(+ m-start (min next-change len))
props
obj)
(setq pos next-change)))))
;; For buffers, delete and insert
(unless (equal new-text text)
(save-excursion
(delete-region m-start m-end)
(goto-char m-start)
(insert new-text)))))))
(defun tp-forward-do (function property &optional value object times start end)
"Search forward for text with PROPERTY and apply FUNCTION to the last match.
FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
START and END are the positions of the match. The return value of FUNCTION
replaces the matched text in the string or buffer.
PROPERTY is the text property to search for.
VALUE is the optional value to match; nil means search for PROPERTY without
matching value.
OBJECT can be a buffer or string; nil defaults to current buffer.
TIMES is the number of searches, defaulting to 1. The function searches
TIMES times but only applies FUNCTION to the last (Nth) match found.
START and END define the search range; defaults are object start and end.
Returns the number of successful matches.
Note: For string objects, the replacement text must have the same length
as the original matched text, since strings have fixed length in Emacs.
If the replacement is shorter, only that portion will be replaced.
If the replacement is longer, it will be truncated.
Example:
;; Upcase only the last (2nd) match
(setq my-string (copy-sequence \"hello world hello\"))
(tp-set 0 5 \\='(marker t) my-string)
(tp-set 12 17 \\='(marker t) my-string)
(tp-forward-do #\\='upcase \\='marker nil my-string 2)
;; => \"hello world HELLO\" - only the 2nd match is upcased
;; Use start and end positions in function
(tp-forward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt))
\\='marker nil my-string 2)
;; Search within a range
(tp-forward-do #\\='upcase \\='marker nil my-string 1 0 10)"
(let ((arity (func-arity function)))
(tp--forward-do
(lambda (match obj)
(tp--replace-match-text function arity match obj))
property value object times start end)))
(defun tp--backward-do (function property &optional value object times start end)
"Internal: search backward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT.
TIMES is the number of searches, defaulting to 1.
VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end.
FUNCTION is called only when the TIMES-th match exists; if fewer
matches are available, nothing is applied.
Returns the number of matches found (at most TIMES)."
(let ((count (or times 1)))
(cond
;; String object - reverse the matches
((stringp object)
(let* ((start-pos (or start 0))
(end-pos (or end (length object)))
(all-matches (tp-search object property value))
(filtered-matches
(seq-filter (lambda (m)
(and (>= (car m) start-pos)
(<= (cadr m) end-pos)))
all-matches))
(matches (seq-take (nreverse filtered-matches) count)))
;; All-or-nothing; see tp--forward-do.
(when (= (length matches) count)
(funcall function (car (last matches)) object))
(length matches)))
;; Buffer or nil
(t
(let* ((buf (or object (current-buffer)))
(matches 0))
(tp-with-current-buffer buf
(let ((search-start (or start (point-min)))
(search-end (or end (point-max))))
(save-excursion
(goto-char search-end)
(dotimes (i count)
;; `equal' matching, same as tp--forward-do's predicate t.
(when-let ((match (tp--property-search-backward property value)))
(when (>= (prop-match-beginning match) search-start)
(when (= i (1- count))
(funcall function match buf))
(cl-incf matches)))))))
matches)))))
(defun tp-backward-do (function property &optional value object times start end)
"Search backward for text with PROPERTY and apply FUNCTION to the last match.
FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
START and END are the positions of the match. The return value of FUNCTION
replaces the matched text in the string or buffer.
PROPERTY is the text property to search for.
VALUE is the optional value to match; nil means search for PROPERTY without
matching value.
OBJECT can be a buffer or string; nil defaults to current buffer.
TIMES is the number of searches, defaulting to 1. The function searches
TIMES times but only applies FUNCTION to the last (Nth) match found.
START and END define the search range; defaults are object start and end.
Returns the number of successful matches.
Note: For string objects, the replacement text must have the same length
as the original matched text, since strings have fixed length in Emacs.
If the replacement is shorter, only that portion will be replaced.
If the replacement is longer, it will be truncated.
Example:
;; Upcase only the last (2nd) match
(setq my-string (copy-sequence \"hello world hello\"))
(tp-set 0 5 \\='(marker t) my-string)
(tp-set 12 17 \\='(marker t) my-string)
(tp-backward-do #\\='upcase \\='marker nil my-string 2)
;; => \"HELLO world hello\" - only the 2nd (last) match is upcased
;; Use start and end positions in function
(tp-backward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt))
\\='marker nil my-string 2)
;; Search within a range
(tp-backward-do #\\='upcase \\='marker nil my-string 1 0 10)"
(let ((arity (func-arity function)))
(tp--backward-do
(lambda (match obj)
(tp--replace-match-text function arity match obj))
property value object times start end)))
(defun tp-search (start-or-string
&optional end-or-property property-or-value value object)
"Search for all text with PROPERTY in a buffer/string range or entire string.
This function supports two calling conventions:
1. Buffer/string region:
(tp-search START END PROPERTY &optional VALUE OBJECT)
2. Entire string:
(tp-search STRING PROPERTY &optional VALUE)
Returns a list of (START END VALUE) lists for all matching regions.
Each element contains the start position, end position, and property value."
(cond
;; Entire string form: (tp-search string property &optional value)
((stringp start-or-string)
(let* ((str start-or-string)
(property end-or-property)
(value property-or-value)
(results nil)
(pos 0)
(len (length str)))
(while (< pos len)
(let* ((props (text-properties-at pos str))
(has-prop (plist-member props property))
(prop-val (plist-get props property)))
(if (and has-prop
(or (null value)
(equal prop-val value)))
;; Find the extent of this property
(let ((next-change
(or (next-single-property-change
pos property str len)
len)))
(push (list pos next-change prop-val) results)
(setq pos next-change))
;; No match, move to next change
(setq pos (or (next-single-property-change
pos property str len)
len)))))
(nreverse results)))
;; Buffer/string region form: (tp-search start end property &optional value object)
((numberp start-or-string)
(let* ((start start-or-string)
(end end-or-property)
(property property-or-value)
(value value)
(obj (or object (current-buffer)))
(results nil)
(pos start))
(if (stringp obj)
;; String object
(while (< pos end)
(let* ((props (text-properties-at pos obj))
(has-prop (plist-member props property))
(prop-val (plist-get props property)))
(if (and has-prop
(or (null value)
(equal prop-val value)))
(let ((next-change
(or (next-single-property-change
pos property obj end)
end)))
(push (list pos next-change prop-val) results)
(setq pos next-change))
(setq pos (or (next-single-property-change
pos property obj end)
end)))))
;; Buffer object
(tp-with-current-buffer obj
(while (< pos end)
(let* ((props (text-properties-at pos))
(has-prop (plist-member props property))
(prop-val (plist-get props property)))
(if (and has-prop
(or (null value)
(equal prop-val value)))
(let ((next-change
(or (next-single-property-change
pos property nil end)
end)))
(push (list pos next-change prop-val) results)
(setq pos next-change))
(setq pos (or (next-single-property-change
pos property nil end)
end)))))))
(nreverse results)))
(t (error "Invalid first argument: %S" start-or-string))))
(defun tp--search-do (function property &optional value object start end)
"Internal: Execute FUNCTION on all matches of PROPERTY.
Signature: (tp--search-do FUNCTION PROPERTY &optional VALUE OBJECT START END)
FUNCTION receives two arguments: the match, as a (START END VALUE)
list, and OBJECT.
PROPERTY is the text property to search for.
VALUE is the optional value to match; nil means search for PROPERTY
without matching value.
OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end.
Returns the number of matches processed.
For buffers, FUNCTION is called with OBJECT as the current buffer, and
the match positions handed to FUNCTION are tracked with markers, so
FUNCTION may safely change the length of earlier matches (e.g. replace
their text): later matches still receive their up-to-date positions."
(let ((obj (or object (current-buffer))))
(if (stringp obj)
(let* ((all-matches (tp-search obj property value))
(s (or start 0))
(e (or end (length obj)))
(filtered-matches
(seq-filter (lambda (m)
(and (>= (car m) s)
(<= (cadr m) e)))
all-matches)))
(dolist (match filtered-matches)
(funcall function match obj))
(length filtered-matches))
;; Buffer: do all the work with OBJ current, and track match
;; positions with markers so length-changing edits made by
;; FUNCTION on earlier matches don't invalidate later positions.
(tp-with-current-buffer obj
(let* ((s (or start (point-min)))
(e (or end (point-max)))
(matches (tp-search s e property value obj))
(marked (mapcar (lambda (m)
;; Begin markers advance on insertion at
;; their position so adjacent runs stay
;; correct after a replacement.
(list (copy-marker (car m) t)
(copy-marker (cadr m))
(caddr m)))
matches)))
(unwind-protect
(dolist (m marked)
(funcall function
(list (marker-position (car m))
(marker-position (cadr m))
(caddr m))
obj))
(dolist (m marked)
(set-marker (car m) nil)
(set-marker (cadr m) nil)))
(length marked))))))
(defun tp-search-map (function property &optional value object start end)
"Apply FUNCTION to all matches of PROPERTY in OBJECT.
Signature: (tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END)
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 can either:
- Return a new/modified string to replace the matched text
- Modify the text properties of the argument and return it
- Return nil to skip replacement
PROPERTY is the text property to search for.
VALUE is the optional value to match; nil means search for PROPERTY without
matching value.
OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end.
Returns the number of matches processed.
Note: For string objects, replacement text must have the same length
as the original matched text, since strings have fixed length in Emacs.
If the replacement is shorter, only that portion will be replaced.
If the replacement is longer, it will be truncated.
Example:
;; Upcase all matched text
(tp-search-map #\\='upcase \\='marker nil my-string)
;; Add properties to matched text
(tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold)) \\='marker nil str)
;; Use start, end, and index
(tp-search-map (lambda (txt start end idx)
(format \"[%d:%d-%d]%s\" idx start end txt))
\\='marker nil str)
;; Search within a range
(tp-search-map #\\='upcase \\='marker nil my-string 0 10)"
(let ((idx 0)
(arity (func-arity function)))
(tp--search-do
(lambda (match obj)
(tp--replace-match-text function arity match obj idx)
(setq idx (1+ idx)))
property value object start end)))
(provide 'tp-search)
;;; tp-search.el ends here

383
tp-stack-tests.el Normal file
View File

@ -0,0 +1,383 @@
;;; 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 unrelated properties do not change what put-layer writes."
(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 (text-properties-at 1)))
(with-temp-buffer
(insert "abcdefghij")
(put-text-property 8 10 'help-echo "far")
(tp-push-layer 1 4 'layer1)
(setq props-distant (text-properties-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: no garbage (tp-layers nil) on single-layer stacks
(ert-deftest tp-stack-test-single-layer-no-tp-layers-prop ()
"Pushing one layer does not leave a (tp-layers nil) property behind."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 1 6 'layer1)
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers))
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-delete-to-single-layer-no-tp-layers-prop ()
"Deleting down to one layer drops the tp-layers property entirely."
(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-not (tp-stack-tests--has-prop-p 1 'tp-layers))
(should (eq (get-text-property 1 'tp-name) 'layer1))))
(ert-deftest tp-stack-test-pop-to-single-layer-no-tp-layers-prop ()
"Popping down to one layer drops the tp-layers property entirely."
(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-not (plist-member (text-properties-at 0 str) 'tp-layers))
(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))))
(provide 'tp-stack-tests)
;;; tp-stack-tests.el ends here

709
tp-stack.el Normal file
View File

@ -0,0 +1,709 @@
;;; 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/rotate/pin/switch/merge/flatten, stack queries,
;; and bulk layer property manipulation.
;;; Code:
(require 'cl-lib)
(require 'dash)
(require 'tp-core)
(require 'tp-layer)
(require 'tp-ops)
;;; 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)
(append (list 0 (length start-or-string) start-or-string)
(seq-take rest n)))
((numberp start-or-string)
(append (list start-or-string (car rest) (nth (1+ n) rest))
(seq-take (cdr rest) n)))
(t (error "Invalid layer arguments: %S" (cons start-or-string rest)))))
(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).
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)
(let* ((idx (-elem-index 'tp-layers props))
(top (if idx
(-remove-at-indices (list idx (1+ idx)) props)
props))
(belows (plist-get props 'tp-layers)))
(funcall function i-start i-end
(tp--layer-stack-to-list top belows)))))))
(defun tp--stack-build-props (layer-list)
"Build text properties from LAYER-LIST (top layer first).
Like `tp--build-layer-props', but the `tp-layers' entry is only added
when there are below-layers, so single-layer stacks do not carry a
garbage (tp-layers nil) property. Consumers must therefore tolerate
an absent `tp-layers' property (both `plist-get' and
`tp--stack-map-region' do)."
(cond
((null layer-list) nil)
((null (cdr layer-list)) (copy-sequence (car layer-list)))
(t (append (car layer-list)
(list 'tp-layers (cdr layer-list))))))
;;; 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 props)))))
(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."
(car (tp--stack-map-region
start end object
(lambda (_abs-start _abs-end stack)
(plist-get (car stack) 'tp-name)))))
;;; 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 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)
"Set layer(s) at a specific index position.
Calling conventions:
1. Buffer/string region:
(tp-put-layer START END LAYER IDX OBJECT)
2. Entire string:
(tp-put-layer STRING LAYER IDX)
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."
(pcase-let ((`(,start ,end ,obj ,layer-spec ,idx)
(tp--parse-layer-args
start-or-string
(list end-or-layer layer-or-idx idx-or-object object) 2)))
(setq idx (or idx 0))
(let ((layers-to-add (tp--put-layer-specs layer-spec)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((actual-idx (if (< idx 0)
(max 0 (+ (length stack) 1 idx))
(min idx (length stack))))
(new-stack (append (seq-take stack actual-idx)
layers-to-add
(seq-drop stack actual-idx))))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)))))
(or obj (cons start end))))
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object)
"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)
2. Entire string:
(tp-push-layer STRING LAYER)"
(pcase-let ((`(,start ,end ,obj ,layer)
(tp--parse-layer-args
start-or-string
(list end-or-layer layer-or-object object) 1)))
(tp-put-layer start end layer 0 obj)))
(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."
(pcase-let ((`(,start ,end ,obj ,layer-id)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-object object) 1)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack layer-id)))
(set-text-properties
abs-start abs-end
(tp--stack-build-props (-remove-at (car found) stack))
obj))))
nil))
(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)"
(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."
(pcase-let ((`(,start ,end ,obj ,from-id ,to-idx)
(tp--parse-layer-args
start-or-string
(list end-or-from from-or-to to-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(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).
Uses `tp--raise-layer-in-stack' internally, which is built on
`tp--move-layer-in-stack'."
(pcase-let ((`(,start ,end ,obj ,layer-id ,n)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-n n-or-object object) 2)))
(setq n (or n 1))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(defun tp-rotate-layer (start-or-string &optional end-or-object object)
"Rotate layers, moving top layer to bottom.
Calling conventions:
1. Buffer/string region:
(tp-rotate-layer START END OBJECT)
2. Entire string:
(tp-rotate-layer STRING)
Uses `tp-move-layer' internally to move layer at index 0 to index -1."
(pcase-let ((`(,start ,end ,obj)
(tp--parse-layer-args
start-or-string (list end-or-object object) 0)))
(tp-move-layer start end 0 -1 obj)))
(defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object)
"Pin a layer to the top (make it visible).
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)
Uses `tp-move-layer' internally to move the specified layer to index 0 (top)."
(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."
(pcase-let ((`(,start ,end ,obj ,id1 ,id2)
(tp--parse-layer-args
start-or-string
(list end-or-id1 id1-or-id2 id2-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(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)."
(cl-reduce (lambda (acc layer)
(cl-loop for (key val) on (cdr layer) by #'cddr
unless (eq key 'tp-name)
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."
(pcase-let ((`(,start ,end ,obj ,new-name ,layer-ids)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-ids ids-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((layers-to-merge
(cl-loop for id in layer-ids
for found = (tp--get-layer-by-idx-or-name stack id)
when found collect found))
;; Sort by index (descending) to remove from end first
(sorted-layers (sort (copy-sequence layers-to-merge)
(lambda (a b) (> (car a) (car b))))))
(when layers-to-merge
;; Merge properties (earlier in list takes precedence)
(let ((merged-props (tp--merge-layer-props
layers-to-merge (list 'tp-name new-name)))
(new-stack stack))
;; Remove old layers from stack
(dolist (idx (mapcar #'car sorted-layers))
(setq new-stack (-remove-at idx new-stack)))
;; Add merged layer at top
(setq new-stack (cons merged-props new-stack))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))))
nil))
(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."
(pcase-let ((`(,start ,end ,obj ,name)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-object object) 1)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when stack
(let ((merged-props (tp--merge-layer-props
(cl-loop for layer in stack
for i from 0
collect (cons i layer))
(when name (list 'tp-name name)))))
(set-text-properties abs-start abs-end merged-props obj)))))
nil))
(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.
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)))))
(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.
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

52
tp-tests.el
View File

@ -1,11 +1,11 @@
;;; tp-ert-tests.el --- ERT tests for tp.el -*- lexical-binding: t -*-
;;; tp-tests.el --- ERT tests for tp.el -*- lexical-binding: t -*-
;; Copyright (C) 2024
;; Copyright (C) 2024-2026
;;; Commentary:
;; Comprehensive test suite for tp.el using ERT (Emacs Lisp Regression Testing).
;; Run with: emacs --batch -l tp.el -l tp-ert-tests.el -f ert-run-tests-batch-and-exit
;; Run with: emacs --batch -L . -l tp.el -l tp-tests.el -f ert-run-tests-batch-and-exit
;;; Code:
@ -23,13 +23,16 @@
;;; ============================================================
(defmacro tp-test-with-temp-buffer (&rest body)
"Execute BODY in a temporary buffer with tp.el loaded."
"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))
`(with-temp-buffer
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(tp-reactive-reset)
,@body))
`(unwind-protect
(with-temp-buffer
(tp-layer-reset)
,@body)
(tp-layer-reset)))
;;; ============================================================
;;; Basic Text Property Functions Tests
@ -677,9 +680,16 @@
(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)))
;; VALUE nil equal-matches the property-absent region, mirroring
;; tp-forward (see tp-test-forward).
(goto-char 12)
(let ((match (tp-backward 'face)))
(should match)
(should (= (prop-match-beginning match) 1)))))
(should (= (prop-match-beginning match) 6)))))
(ert-deftest tp-test-backward-on-string ()
"Test tp-backward works on string objects."
@ -708,7 +718,10 @@
(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."
"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)
@ -717,8 +730,8 @@
(should (= count 1)) ; Only one match in range 6-17
;; First match should NOT be upcased
(should (equal (substring str 0 5) "hello"))
;; Second match should be upcased
(should (equal (substring str 12 17) "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."
@ -766,16 +779,17 @@
(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."
"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 nil str 2 0 10)))
(should (= count 1)) ; Only one match in range 0-10
;; First match should be upcased
(should (equal (substring str 0 5) "HELLO"))
;; Second match should NOT be upcased
;; 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 ()
@ -4109,5 +4123,5 @@ can be tracked and removed."
;; tp-delete property should be removed
(should (null (get-text-property 0 'tp-delete result)))))
(provide 'tp-ert-tests)
;;; tp-ert-tests.el ends here
(provide 'tp-tests)
;;; tp-tests.el ends here

4880
tp.el
View File

File diff suppressed because it is too large Load Diff