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

Complete text-property facade and managed lifecycle

Browse Source 
Add canonical query semantics, managed metadata and transactions, overlay-aware lookup, reproducible benchmarks, and synchronized API documentation.
This commit is contained in:
Kinneyzhang 2026-07-28 22:42:55 +08:00
parent a65d79921a
commit 972b6d4e4c
36 changed files with 6041 additions and 830 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
CHANGELOG.md
View File

@ -2,6 +2,83 @@
All notable changes to the tp library are documented here.
## Unreleased
### Added
- Internal Stage 2 canonical façade records and dataflow:
`tp--native-range`, `tp--presence`, `tp--request`, `tp--match`,
and `tp--result`. Public entry points and historical return shapes
remain compatible.
- Stage 3 text-only native façade in `tp-query.el`:
`tp-lookup-result`, `tp-lookup`, `tp-property-change`,
`tp-property-any`, `tp-property-not-all`, and
`tp-with-mutation-policy`.
- Stage 4 managed lifecycle APIs: `tp-attach-managed-layers`,
`tp-detach-managed-layers`, `tp-managed-layer-diagnostics`,
`tp-managed-buffer-diagnostics`, `tp-managed-diagnostics`, and
`tp-layer-transaction`.
- Stage 5 overlay-aware lookup modes for `tp-lookup`: `:char` and
`:char-source` report Emacs character-property values and the
winning overlay identity when an overlay wins.
- `docs/API-SEMANTICS.md` centralizes the current object/coordinate,
mutation, presence/nil, search-result, layer-ownership, `tp-text`,
error, and hidden-stack conflict contracts.
- `tp-any-value`, a unique public sentinel for property-search wildcard
matching when later positional arguments also need to be supplied.
- `tp-unresolved-layer` and `tp-layer-conflict` error types.
- `tp-reactive-observer-errors`, a newest-first structured record of
isolated watcher callback failures.
### Fixed
- Initial `tp-text` rendering now preserves every embedded property
interval for strings and buffers instead of spreading position-zero
properties across the replacement.
- `tp-text` application preserves the caller's `tp-set`, `tp-reset`,
or `tp-add` write semantics even when replacement text is unchanged.
- Explicit nil properties override embedded `tp-text` values.
- Non-parameterized layer redefinition refreshes managed regions with
old/new ownership reconciliation: removed keys disappear, new keys
replace them, and unrelated or externally changed values survive.
- Search APIs distinguish omitted VALUE (any directly present value)
from explicit nil (a present nil value), with one presence-aware run
scanner shared by strings and buffers.
- Removing the last nested sub-property removes the empty parent key
consistently for strings and buffers.
- Stack NOERROR catches only unresolved layer specifications; errors
from layer bodies and internal operations propagate.
- When hidden-layer full-stack storage detects an external direct
property edit, stack decoding now signals `tp-layer-conflict` before
any managed write instead of silently discarding the external value.
- Buffer transaction rollback tracks its live range with markers, so
insertions and deletions inside the range are removed or restored
together with the original text-property snapshot.
### Changed
- Transform and compute failures now propagate as business-output
errors. A transform returning a non-string also signals. Watcher
failures remain isolated observers, but are recorded structurally
while the managed update continues.
- Managed layer entries now store `tp-meta` in authoritative
`tp-layers` storage, including parameterized args and definition
versions. Direct rendered properties and public stack queries strip
`tp-meta`; historical returns remain unchanged.
- Parameterized mounted layer entries refresh from stored args after
redefinition.
- Insert/copy/yank/stickiness/narrowing/indirect-buffer behavior is
now documented as direct Emacs delegation with no tp wrapper.
- Overlay creation, movement, deletion, priority management, and
lifecycle remain native Emacs responsibilities; tp only reports
overlay-aware lookup results.
- `tp-with-mutation-policy` accepts only ordinary+respect,
ordinary+inhibit, and silent+inhibit; silent+respect is rejected.
- Theme enable/disable events now increment theme generation and expose
conservative refresh diagnostics. Reproducible benchmark evidence is
recorded in `docs/BENCHMARKS.md`; timings are advisory baseline data,
not release thresholds.
## 0.3.0 (2026-07-27)
### Added

10
Makefile
View File

@ -4,6 +4,7 @@
# make test # run all ERT test suites
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
# make doctest # execute README examples against the code
# make benchmark # run reproducible correctness-first benchmarks
# make compile # byte-compile the library modules
# make compile-all # byte-compile modules + tests + dev scripts
# make clean # remove compiled files
@ -18,11 +19,11 @@ WERROR ?= nil
LOADPATH = -L . $(LOAD_EXTRA)
SRC = tp-core.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \
tp-render.el tp-stack.el tp-palette.el tp-builtins.el tp.el
tp-render.el tp-stack.el tp-query.el tp-palette.el tp-builtins.el tp.el
TESTS = $(wildcard *-tests.el)
DEV = tp-doctest.el tp-run-shuffled.el
DEV = tp-doctest.el tp-run-shuffled.el tp-benchmark.el
.PHONY: test test-shuffled doctest compile compile-all clean
.PHONY: test test-shuffled doctest benchmark compile compile-all clean
test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
@ -35,6 +36,9 @@ test-shuffled:
doctest:
$(EMACS) -Q --batch $(LOADPATH) -l tp-doctest.el
benchmark:
$(EMACS) -Q --batch $(LOADPATH) -l tp-benchmark.el -f tp-benchmark-run
compile: clean
$(EMACS) -Q --batch $(LOADPATH) \
--eval "(setq byte-compile-error-on-warn $(WERROR))" \

273
README.md
View File

@ -55,6 +55,11 @@
- [tp-forward-do / tp-backward-do](#tp-forward-do--tp-backward-do)
- [tp-search](#tp-search---search-all-matches)
- [tp-search-map](#tp-search-map---apply-function-to-matched-text)
- [Native Text Property Compatibility](#native-text-property-compatibility)
- [tp-lookup-result / tp-lookup](#tp-lookup-result--tp-lookup)
- [tp-property-change](#tp-property-change)
- [tp-property-any / tp-property-not-all](#tp-property-any--tp-property-not-all)
- [tp-with-mutation-policy](#tp-with-mutation-policy)
- [The Property Layer System](#the-property-layer-system)
- [Custom Text Properties](#custom-text-properties)
- [Text Property Layers](#text-property-layers)
@ -82,6 +87,10 @@
- [tp-switch-layer](#tp-switch-layer---switch-two-layers)
- [Property Layer Visibility](#property-layer-visibility)
- [tp-hide-layer / tp-show-layer](#tp-hide-layer--tp-show-layer---hide-and-show-layers)
- [Managed Layer Lifecycle](#managed-layer-lifecycle)
- [tp-attach-managed-layers / tp-detach-managed-layers](#tp-attach-managed-layers--tp-detach-managed-layers)
- [tp-managed-layer-diagnostics / tp-managed-buffer-diagnostics / tp-managed-diagnostics](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics)
- [tp-layer-transaction](#tp-layer-transaction)
- [Property Layer Merging](#property-layer-merging)
- [tp-merge-layers](#tp-merge-layers---merge-multiple-layers)
- [tp-flatten-layers](#tp-flatten-layers---flatten-all-layers)
@ -215,6 +224,12 @@ case, so OBJECT sits before the range instead of after it.
| `tp-put-layer` / `tp-push-layer` | OBJECT when given (the string itself in string forms), else `(START . END)` |
| `tp-add-to-layers` / `tp-add-to-all-layers` | the string itself (mutated **in place**) for string forms; nil for buffers |
The precise object, mutation, nil/presence, search, and managed-layer
contracts are centralized in
[docs/API-SEMANTICS.md](docs/API-SEMANTICS.md). “Unified” means one
high-level vocabulary; a few documented string/buffer return differences
remain for compatibility.
**Namespace map**: `tp-layer-NAME` functions taking a *layer name* argument
(`tp-layer-props`, `tp-layer-arglist`, ...) query the layer **registry**
(definitions); the ones taking *position* arguments — START END
@ -382,7 +397,7 @@ 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 'marker nil my-string)
(tp-search-map #'upcase 'marker tp-any-value my-string)
```
## Requirements
@ -420,6 +435,7 @@ The modules and their roles:
| `tp-search.el` | `tp-match-*`, `tp-regexp-*`, `tp-search`, navigation |
| `tp-render.el` | Reactive re-rendering engine |
| `tp-stack.el` | Layer stack operations (push/pop/move/merge/flatten/...) |
| `tp-query.el` | Native text lookup/change wrappers and mutation policy |
| `tp-palette.el` | Light/dark color palette data |
| `tp-builtins.el` | Built-in layers, palette gallery, display-buffer helpers |
@ -470,6 +486,16 @@ A complete overview of all tp.el functions organized by category:
| [`tp-search`](#tp-search---search-all-matches) | Search all matching properties in range or string |
| [`tp-search-map`](#tp-search-map---apply-function-to-matched-text) | Apply function to all matches (with optional start/end range) |
#### Native Text Property Compatibility
| Function | Description |
|----------|-------------|
| [`tp-lookup`](#tp-lookup-result--tp-lookup) | Text-only direct/effective/source-aware property lookup |
| [`tp-lookup-result`](#tp-lookup-result--tp-lookup) | Result record returned by `tp-lookup` |
| [`tp-property-change`](#tp-property-change) | Wrapper for next/previous single-property or all-property change positions |
| [`tp-property-any`](#tp-property-any--tp-property-not-all) | Wrapper for `text-property-any` |
| [`tp-property-not-all`](#tp-property-any--tp-property-not-all) | Wrapper for `text-property-not-all` |
| [`tp-with-mutation-policy`](#tp-with-mutation-policy) | Explicit modified/read-only mutation policy wrapper |
#### Property Layer Definition Functions
| Function | Description |
|----------|-------------|
@ -515,6 +541,16 @@ A complete overview of all tp.el functions organized by category:
| [`tp-hide-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers) | Hide a layer without removing it from the stack |
| [`tp-show-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers) | Make a hidden layer render again |
#### Managed Layer Lifecycle
| Function | Description |
|----------|-------------|
| [`tp-attach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | Attach inserted/copied managed layer storage to the current buffer registry |
| [`tp-detach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | Remove managed storage, optionally keeping rendered visible properties |
| [`tp-managed-layer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only diagnostics for one layer |
| [`tp-managed-buffer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only diagnostics for one buffer |
| [`tp-managed-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only global managed lifecycle diagnostics |
| [`tp-layer-transaction`](#tp-layer-transaction) | Run a managed stack change with rollback on error |
#### Property Layer Merging Functions
| Function | Description |
|----------|-------------|
@ -1434,9 +1470,11 @@ START/END bounds and the SUBEXP capture group work exactly as in
Search forward/backward N times for text with PROPERTY.
- **N** is the number of searches, defaulting to 1.
- **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.
- **VALUE** is `equal`-matched against directly present property values.
Omitting VALUE matches any present value; explicit nil matches a present
nil value. Missing-property spans never match.
- Pass the unique public sentinel **`tp-any-value`** when wildcard matching
is wanted and later positional arguments such as OBJECT or N are supplied.
- **`tp-backward` mirrors `tp-forward`**: the same equal-matching semantics,
in the opposite direction.
- **OBJECT** can be a buffer or string; nil defaults to current buffer.
@ -1449,7 +1487,7 @@ Search forward/backward N times for text with PROPERTY.
- For buffers, returns the prop-match object from the last successful search.
- For strings, returns a list of (START END VALUE) for the **first N** runs
where PROPERTY matches, counted from position 0 (point is not involved);
VALUE nil means any value. `tp-backward` returns them from end to start.
`tp-backward` returns them from end to start.
**Examples:**
@ -1464,14 +1502,20 @@ Search forward/backward N times for text with PROPERTY.
(prop-match-beginning match))))
;; => 7
;; VALUE nil equal-matches nil - i.e. the run WITHOUT the property
;; Omitting VALUE matches the next directly present marker value
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char 1)
(let ((match (tp-forward 'marker)))
(list (prop-match-beginning match) (prop-match-end match))))
;; => (1 7) ; the run where marker is absent
;; => (7 12)
;; Explicit nil matches only a present nil value
(let ((str (copy-sequence "abc")))
(tp-set 1 2 '(marker nil) str)
(tp-forward 'marker nil str))
;; => ((1 2 nil))
;; Backward mirrors forward: same value matching, opposite direction
(with-temp-buffer
@ -1496,7 +1540,7 @@ Search forward/backward N times for text with PROPERTY.
(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 'marker tp-any-value my-string 2))
;; => ((0 5 t) (12 17 t))
;; PREDICATE - match with a custom function instead of `equal'
@ -1550,7 +1594,9 @@ a function to *every* match.
- **FUNCTION** receives `(TEXT &optional START END IDX)` where TEXT is the matched text, START and END are the positions of the match, and IDX is the 0-based match index. FUNCTION is called with as many of these arguments as it accepts. When FUNCTION returns a string, it replaces the matched text in the string or buffer.
- **Replacements may change length in buffers** (the match is deleted and the replacement inserted). **Strings cannot change length in place**: a replacement of a different length signals an error; same-length replacements are applied in place.
- **PROPERTY** is the text property to search for.
- **VALUE** is the optional value to match; nil means search for PROPERTY without matching value.
- **VALUE** follows the presence-aware search contract: omitted means any
present value; explicit nil means a present nil value. Use
`tp-any-value` when later positional arguments are supplied.
- **OBJECT** can be a buffer or string; nil defaults to current buffer.
- **TIMES** is the number of searches, defaulting to 1. The function searches TIMES times but only applies FUNCTION to the TIMES-th match. All-or-nothing: if fewer than TIMES matches exist, FUNCTION is not applied at all and the number of available matches is returned.
- **START** and **END** define the search range; defaults are object start and end.
@ -1566,7 +1612,7 @@ a function to *every* match.
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-forward-do #'upcase 'marker nil my-string 2)
(tp-forward-do #'upcase 'marker tp-any-value my-string 2)
my-string)
;; => "hello world HELLO" ; Only the 2nd match is upcased
@ -1574,7 +1620,7 @@ a function to *every* match.
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-forward-do #'upcase 'marker nil my-string 2 6 17)
(tp-forward-do #'upcase 'marker tp-any-value my-string 2 6 17)
my-string)
;; => "hello world hello" ; only 1 match in range 6-17, so the
;; requested 2nd match does not exist: nothing is applied
@ -1590,7 +1636,7 @@ a function to *every* match.
(lambda (text start end)
(setq match-info (list start end))
(upcase text))
'marker nil my-string 2)
'marker tp-any-value my-string 2)
(list my-string match-info))
;; => ("hello world HELLO" (12 17)) ; Only the last match is transformed
@ -1598,7 +1644,7 @@ a function to *every* match.
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-backward-do #'upcase 'marker nil my-string 2)
(tp-backward-do #'upcase 'marker tp-any-value my-string 2)
my-string)
;; => "HELLO world hello" ; The first match (last when searching backward) is upcased
```
@ -1668,7 +1714,9 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT.
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.
- **VALUE** follows the presence-aware search contract: omitted means any
present value; explicit nil means a present nil value. Use
`tp-any-value` when later positional arguments are supplied.
- **OBJECT** can be a buffer or string; nil defaults to current buffer.
- **START** and **END** define the search range; defaults are object start and end.
- Returns the number of matches processed.
@ -1680,7 +1728,7 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT.
(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)
(tp-search-map #'upcase 'marker tp-any-value my-string)
my-string)
;; => "HELLO world HELLO"
@ -1688,7 +1736,7 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT.
(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 0 10)
(tp-search-map #'upcase 'marker tp-any-value my-string 0 10)
my-string)
;; => "HELLO world hello" ; Only first match in range 0-10
@ -1703,20 +1751,129 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT.
(lambda (text start end idx)
(push (list idx start end) positions)
(upcase text))
'marker nil my-string)
'marker tp-any-value my-string)
(list my-string (nreverse positions)))
;; => ("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11)))
;; Custom transformation without optional parameters
(let ((my-string (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) my-string)
(tp-search-map #'upcase 'marker nil my-string)
(tp-search-map #'upcase 'marker tp-any-value my-string)
my-string)
;; => "HELLO world"
```
---
## Native Text Property Compatibility
Stage 3 makes the text-property boundary explicit, and Stage 5 adds overlay-aware character-property lookup. These APIs map to GNU Emacs primitives; tp does not manage overlay lifecycle.
#### `tp-lookup-result` / `tp-lookup`
`tp-lookup` returns a `tp-lookup-result` record. Use the generated accessors:
| Accessor | Meaning |
|----------|---------|
| `tp-lookup-result-property` | requested property |
| `tp-lookup-result-value` | resolved value |
| `tp-lookup-result-present-p` | non-nil when the chosen source provides the property; a direct nil counts, while a nil alias follows Emacs' alias fallback |
| `tp-lookup-result-source` | `:text-direct`, `:category`, `:alias`, `:default`, or `:absent` |
| `tp-lookup-result-mode` | lookup mode |
| `tp-lookup-result-object` | queried object |
| `tp-lookup-result-position` | queried position |
| `tp-lookup-result-overlay` | winning overlay for `:char` / `:char-source`, otherwise nil |
Modes:
| Mode | Behavior |
|------|----------|
| `:text-direct` | inspect only direct text properties with `text-properties-at`; explicit nil is present |
| `:text-effective` | return `get-text-property`'s effective text value and report its text source |
| `:text-source` | report the winning text source without overlays |
| `:char` | overlay-aware `get-char-property-and-overlay` value; text fallback follows Emacs |
| `:char-source` | like `:char`, plus `:overlay` source and overlay identity when an overlay wins |
```elisp
;; Direct lookup distinguishes explicit nil from absence
(let ((str (copy-sequence "ab")))
(put-text-property 0 1 'state nil str)
(let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct))
(absent-result (tp-lookup 1 'state :object str :mode :text-direct)))
(list (list (tp-lookup-result-present-p nil-result)
(tp-lookup-result-value nil-result)
(tp-lookup-result-source nil-result))
(list (tp-lookup-result-present-p absent-result)
(tp-lookup-result-value absent-result)
(tp-lookup-result-source absent-result)))))
;; => ((t nil :text-direct) (nil nil :absent))
;; Source-aware lookup explains category/default/alias/direct text sources
(let* ((str (copy-sequence "a"))
(category (make-symbol "tp-doc-category")))
(put category 'state 'category-value)
(put-text-property 0 1 'category category str)
(let ((result (tp-lookup 0 'state :object str :mode :text-source)))
(list (tp-lookup-result-value result)
(tp-lookup-result-source result))))
;; => (category-value :category)
;; Character-source lookup reports the winning overlay identity
(with-temp-buffer
(insert "x")
(let ((low (make-overlay 1 2))
(high (make-overlay 1 2)))
(overlay-put low 'priority 1)
(overlay-put low 'state 'low)
(overlay-put high 'priority 10)
(overlay-put high 'state 'high)
(let ((result (tp-lookup 1 'state :mode :char-source)))
(list (tp-lookup-result-value result)
(tp-lookup-result-source result)
(eq (tp-lookup-result-overlay result) high)))))
;; => (high :overlay t)
```
`tp-lookup` reports overlay winners, but overlay creation, deletion, movement, priority management, and lifecycle remain native Emacs responsibilities.
#### `tp-property-change`
`tp-property-change` wraps `next-property-change`, `previous-property-change`, `next-single-property-change`, and `previous-single-property-change`.
```elisp
(tp-property-change POSITION :object OBJECT :limit LIMIT :direction :next)
(tp-property-change POSITION :property PROPERTY :object OBJECT :limit LIMIT :direction :previous)
```
Omit `:property` for any property change. Pass `:property` for a single-property change. `:direction` is `:next` or `:previous`.
#### `tp-property-any` / `tp-property-not-all`
These are thin wrappers over Emacs primitives:
```elisp
(tp-property-any START END PROPERTY VALUE &optional OBJECT)
(tp-property-not-all START END PROPERTY VALUE &optional OBJECT)
```
They preserve Emacs behavior exactly, including explicit nil matching.
#### `tp-with-mutation-policy`
`tp-with-mutation-policy` makes modified/read-only behavior explicit for buffer mutations:
| Policy | Behavior |
|--------|----------|
| `(:modified :ordinary :read-only :respect)` | normal Emacs mutation; read-only text can signal |
| `(:modified :ordinary :read-only :inhibit)` | bind `inhibit-read-only` and record ordinary modified/undo state |
| `(:modified :silent :read-only :inhibit)` | bind `inhibit-read-only` and use `with-silent-modifications` |
`(:modified :silent :read-only :respect)` is rejected because silent modification cannot be combined with respecting read-only text.
Insert/copy/yank/stickiness/narrowing/indirect-buffer behavior is delegated directly to Emacs. tp does not provide wrappers for those operations; use the native primitives (`insert`, `insert-and-inherit`, `copy-sequence`, `substring`, `insert-for-yank`, narrowing commands, and indirect buffers).
---
## The Property Layer System
The **property layer system** is tp.el's innovative feature that allows stacking multiple sets of properties on the same text region. Only the **top layer** is visible, but lower layers are preserved and can be revealed through rotation or pinning.
@ -2443,7 +2600,7 @@ returns nil instead of signaling.
: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)
;; => (:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2)
```
---
@ -2879,6 +3036,12 @@ full stack, hidden layers included (0 = top, -1 = bottom).
- Hiddenness is stored as a `tp-hidden` flag inside the layer's plist in
`tp-layers` stack storage, so `tp-hidden` is a reserved property name
inside layers, like `tp-name`.
- While any layer is hidden, direct properties are a render cache for the
first visible managed layer. Definition/reactive refresh has enough
ownership context to preserve native edits on that visible layer. A normal
stack decode/write remains strict and signals `tp-layer-conflict` before
changing state when the cache differs; properties appearing while every
layer is hidden are always a conflict.
Both functions return the number of property runs modified. A NAME matching
no layer never signals, and hiding an already-hidden layer (or showing a
@ -2946,6 +3109,64 @@ visible one) is a silent no-op — 0 means nothing changed.
---
### Managed Layer Lifecycle
Stage 4 adds explicit lifecycle metadata for managed layer stacks. A single managed layer now uses `tp-layers` storage when metadata is present, because `tp-meta` is authoritative lifecycle state. The rendered direct text properties and public stack queries strip `tp-meta`: `text-properties-at` should show only rendered properties plus stack storage, and `tp-layer-stack-at` returns public layer plists without metadata.
Legacy return values remain unchanged. Stack mutators still return their documented object/range/run-count values; diagnostics are separate read-only APIs.
Parameterized mounted layers store their args and definition version in `tp-meta`. Redefining a parameterized layer refreshes mounted entries from stored args. Entries created before metadata existed are treated conservatively as legacy entries.
#### `tp-attach-managed-layers` / `tp-detach-managed-layers`
```elisp
(tp-attach-managed-layers START END &optional OBJECT)
(tp-detach-managed-layers START END &optional OBJECT KEEP-RENDERED)
```
`tp-attach-managed-layers` scans a range that already contains managed layer storage, normalizes missing metadata, registers found layers in the reactive buffer registry, and returns discovered layer names in range order. Use it after inserting a propertized managed string through native insertion paths.
`tp-detach-managed-layers` removes managed storage and returns detached layer names. When KEEP-RENDERED is non-nil, the currently visible rendered properties remain as ordinary text properties; lifecycle storage (`tp-name`, `tp-layers`, `tp-meta`) is removed.
#### `tp-managed-layer-diagnostics` / `tp-managed-buffer-diagnostics` / `tp-managed-diagnostics`
```elisp
(tp-managed-layer-diagnostics LAYER-NAME)
(tp-managed-buffer-diagnostics &optional BUFFER)
(tp-managed-diagnostics)
```
These functions are read-only diagnostics. They report layers, buffers, entries, stored args, registry state, errors, and theme diagnostics. `tp-managed-diagnostics` includes a `:theme` plist with generation, last hook source, refresh mode, refreshed ranges, and errors. Theme enable/disable hooks increment the generation and use conservative refresh diagnostics; this is lifecycle evidence, not a benchmark.
#### `tp-layer-transaction`
```elisp
(tp-layer-transaction START END OBJECT FUNCTION &optional NOERROR)
```
Runs FUNCTION over a managed range. On success it returns a structured plist with `:status ok`, `:ok t`, FUNCTION's value in `:result`, an operation id, the range, and changed ranges. On error it restores the exact pre-transaction text/property snapshot; by default it signals `tp-layer-transaction-error`, while NOERROR returns the structured failure plist with rollback status.
```elisp
(progn
(tp-layer-reset)
(define-tp tx-base () '(face bold))
(define-tp tx-temp () '(face italic))
(with-temp-buffer
(insert "abcd")
(let ((result
(tp-layer-transaction
1 4 (current-buffer)
(lambda () (tp-put-layer 1 3 'tx-base 0)))))
(list (plist-get result :status)
(plist-get result :range)
(tp-at 1 'face)))))
;; => (ok (1 . 4) bold)
```
Theme generation and managed diagnostics are verified as lifecycle behavior. Reproducible benchmark evidence is recorded in `docs/BENCHMARKS.md`; those timings are advisory baseline data, not release thresholds.
---
### Property Layer Merging
#### `tp-merge-layers` - Merge Multiple Layers
@ -3836,7 +4057,12 @@ 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
- Must return a string; failures and non-string results propagate instead of
rendering stale input
Compute functions follow the same business-error rule. Watch callbacks are
observers: their failures are isolated so rendering continues, and structured
records are appended newest-first to `tp-reactive-observer-errors`.
### Anonymous Reactive Layers
@ -3868,6 +4094,13 @@ All text property APIs (`tp-set`, `tp-match-set`, `tp-regexp-set`, etc.) now acc
(tp-regexp-set "[0-9]+" 'warning-style)
```
This direct use is **template expansion** for non-reactive layers: the
definition becomes ordinary text properties and does not retain `tp-name`.
Use `tp-push-layer` or `tp-put-layer` for a **managed mount** that can later
be queried, moved, hidden, deleted by name, or refreshed after a layer
redefinition. Parameterized mounted entries retain their arguments and use
them to refresh existing instances after redefinition.
### Reactive Layer Groups
Layer groups can also use reactive features:

268
README_CN.md
View File

@ -54,6 +54,11 @@
- [tp-forward-do / tp-backward-do](#tp-forward-do--tp-backward-do)
- [tp-search](#tp-search---搜索所有匹配)
- [tp-search-map](#tp-search-map---对匹配文本应用函数)
- [原生文本属性兼容](#原生文本属性兼容)
- [tp-lookup-result / tp-lookup](#tp-lookup-result--tp-lookup)
- [tp-property-change](#tp-property-change)
- [tp-property-any / tp-property-not-all](#tp-property-any--tp-property-not-all)
- [tp-with-mutation-policy](#tp-with-mutation-policy)
- [属性层系统](#属性层系统)
- [自定义文本属性](#自定义文本属性)
- [文本属性层](#文本属性层)
@ -81,6 +86,10 @@
- [tp-switch-layer](#tp-switch-layer---交换两个属性层)
- [属性层可见性](#属性层可见性)
- [tp-hide-layer / tp-show-layer](#tp-hide-layer--tp-show-layer---隐藏与显示属性层)
- [Managed Layer 生命周期](#managed-layer-生命周期)
- [tp-attach-managed-layers / tp-detach-managed-layers](#tp-attach-managed-layers--tp-detach-managed-layers)
- [tp-managed-layer-diagnostics / tp-managed-buffer-diagnostics / tp-managed-diagnostics](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics)
- [tp-layer-transaction](#tp-layer-transaction)
- [属性层合并](#属性层合并)
- [tp-merge-layers](#tp-merge-layers---合并多个属性层)
- [tp-flatten-layers](#tp-flatten-layers---扁平化所有属性层)
@ -214,6 +223,10 @@ OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和
| `tp-put-layer` / `tp-push-layer` | 给定 OBJECT 时返回 OBJECT（字符串形式返回该字符串本身），否则返回 `(START . END)` |
| `tp-add-to-layers` / `tp-add-to-all-layers` | 字符串形式返回该字符串本身（**就地**修改）；缓冲区返回 nil |
对象、修改性、nil/presence、搜索和 managed layer 的精确契约统一记录在
[docs/API-SEMANTICS.md](docs/API-SEMANTICS.md)。“统一”指共享同一套高层
词汇；为保持兼容，当前仍存在少数已记录的字符串/缓冲区返回值差异。
**命名空间地图**：接受*层名*参数的 `tp-layer-NAME` 函数
（`tp-layer-props`、`tp-layer-arglist` 等）查询的是层**注册表**（层定
义）；接受*位置*参数的函数 —— START END（`tp-layer-list`、
@ -381,7 +394,7 @@ OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和
(tp-search my-string 'marker) ; => ((0 5 t) (12 17 t))
;; 将所有标记文本转为大写
(tp-search-map #'upcase 'marker nil my-string)
(tp-search-map #'upcase 'marker tp-any-value my-string)
```
## 系统要求
@ -418,6 +431,7 @@ OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和
| `tp-search.el` | `tp-match-*`、`tp-regexp-*`、`tp-search`、导航 |
| `tp-render.el` | 响应式重渲染引擎 |
| `tp-stack.el` | 属性层栈操作（push/pop/移动/合并/扁平化/...） |
| `tp-query.el` | 原生文本查询/change 封装与修改策略 |
| `tp-palette.el` | 亮色/暗色调色板数据 |
| `tp-builtins.el` | 内置属性层、调色板画廊、display-buffer 辅助工具 |
@ -467,6 +481,16 @@ tp.el 所有函数按类别组织的完整概览：
| [`tp-search`](#tp-search---搜索所有匹配) | 在范围或字符串中搜索所有匹配的属性 |
| [`tp-search-map`](#tp-search-map---对匹配文本应用函数) | 对所有匹配的文本应用函数（支持起始和结束范围） |
#### 原生文本属性兼容
| 函数 | 描述 |
|------|------|
| [`tp-lookup`](#tp-lookup-result--tp-lookup) | text-only 的 direct/effective/source-aware 属性查询 |
| [`tp-lookup-result`](#tp-lookup-result--tp-lookup) | `tp-lookup` 返回的结果记录 |
| [`tp-property-change`](#tp-property-change) | next/previous single-property 或 all-property change 位置封装 |
| [`tp-property-any`](#tp-property-any--tp-property-not-all) | `text-property-any` 封装 |
| [`tp-property-not-all`](#tp-property-any--tp-property-not-all) | `text-property-not-all` 封装 |
| [`tp-with-mutation-policy`](#tp-with-mutation-policy) | 显式 modified/read-only 修改策略封装 |
#### 属性层定义函数
| 函数 | 描述 |
|------|------|
@ -512,6 +536,16 @@ tp.el 所有函数按类别组织的完整概览：
| [`tp-hide-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) | 隐藏属性层而不将其从栈中移除 |
| [`tp-show-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) | 让隐藏的属性层重新渲染 |
#### Managed Layer 生命周期
| 函数 | 描述 |
|------|------|
| [`tp-attach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | 将插入/复制进来的 managed layer storage 登记到当前缓冲区注册表 |
| [`tp-detach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | 移除 managed storage，可选保留当前可见渲染属性 |
| [`tp-managed-layer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 某一层的只读诊断 |
| [`tp-managed-buffer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 某一缓冲区的只读诊断 |
| [`tp-managed-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 全局 managed lifecycle 只读诊断 |
| [`tp-layer-transaction`](#tp-layer-transaction) | 以失败回滚方式执行 managed stack 修改 |
#### 属性层合并函数
| 函数 | 描述 |
|------|------|
@ -1415,9 +1449,10 @@ START/END 边界和 SUBEXP 捕获组的用法与
向前/向后搜索 N 次具有 PROPERTY 的文本。
- **N** 是搜索次数，默认为 1。
- **VALUE** 在缓冲区中与属性值做 `equal` 匹配。
因此传入 nil 会匹配下一段 PROPERTY *不存在*（值为 nil）的区段；
要查找带属性的区域，请显式传入属性值。
- **VALUE** 与直接存在的属性值做 `equal` 匹配。省略 VALUE 匹配任意已
存在值；显式 nil 只匹配“键存在且值为 nil”。缺少该属性的区段不匹配。
- 需要继续传入 OBJECT、N 等后续位置参数并保持通配时，传入公共唯一哨兵
**`tp-any-value`**。
- **`tp-backward` 与 `tp-forward` 对称**：相同的 equal 匹配语义，
方向相反。
- **OBJECT** 可以是缓冲区或字符串；nil 默认为当前缓冲区。
@ -1429,8 +1464,8 @@ START/END 边界和 SUBEXP 捕获组的用法与
有 point，因此在字符串上会被忽略。
- 对于缓冲区，返回最后一次成功搜索的 prop-match 对象。
- 对于字符串，返回**前 N 个** PROPERTY 匹配区段的 (START END VALUE)
列表，从位置 0 开始计数（与 point 无关）；VALUE 为 nil 表示匹配任意
值。`tp-backward` 按从末尾到开头的顺序返回。
列表，从位置 0 开始计数（与 point 无关）。`tp-backward` 按从末尾到
开头的顺序返回。
**示例：**
@ -1445,14 +1480,20 @@ START/END 边界和 SUBEXP 捕获组的用法与
(prop-match-beginning match))))
;; => 7
;; VALUE 为 nil 时 equal 匹配 nil - 即匹配没有该属性的区段
;; 省略 VALUE 时匹配下一个直接存在的 marker 值
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
(goto-char 1)
(let ((match (tp-forward 'marker)))
(list (prop-match-beginning match) (prop-match-end match))))
;; => (1 7) ; marker 不存在的区段
;; => (7 12)
;; 显式 nil 只匹配“属性存在且值为 nil”
(let ((str (copy-sequence "abc")))
(tp-set 1 2 '(marker nil) str)
(tp-forward 'marker nil str))
;; => ((1 2 nil))
;; backward 与 forward 对称：相同的值匹配，方向相反
(with-temp-buffer
@ -1477,7 +1518,7 @@ START/END 边界和 SUBEXP 捕获组的用法与
(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 'marker tp-any-value my-string 2))
;; => ((0 5 t) (12 17 t))
;; PREDICATE - 用自定义函数代替 `equal' 进行匹配
@ -1530,7 +1571,9 @@ START/END 边界和 SUBEXP 捕获组的用法与
- **FUNCTION** 的参数是 `(TEXT &optional START END IDX)`，其中 TEXT 是此次匹配到的文本，START 和 END 为开始结束的位置，IDX 是从 0 开始的匹配索引。FUNCTION 会按其实际接受的参数个数被调用。当 FUNCTION 返回字符串时，它将替换字符串或缓冲区中的匹配文本。
- **在缓冲区中替换文本可以改变长度**（先删除匹配文本，再插入替换文本）。**字符串无法就地改变长度**：长度不同的替换会发出错误信号；长度相同的替换会就地应用。
- **PROPERTY** 是要搜索的文本属性。
- **VALUE** 为 nil 时，表示搜索 PROPERTY 属性，不用匹配值。
- **VALUE** 遵循 presence-aware 搜索契约：省略表示任意已存在值；显式
nil 表示“键存在且值为 nil”。需要继续传入后续位置参数时使用
`tp-any-value`。
- **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。
- **TIMES** 表示向前/向后搜索几次，默认搜索一次。该函数会搜索 TIMES 次，但仅对第 TIMES 个匹配应用 FUNCTION。要么全有要么全无：当匹配数量不足 TIMES 时，完全不应用 FUNCTION，仅返回实际找到的匹配数量。
- **START** 和 **END** 默认为 OBJECT 的起始和结束位置。
@ -1546,7 +1589,7 @@ START/END 边界和 SUBEXP 捕获组的用法与
(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)
(tp-forward-do #'upcase 'marker tp-any-value my-string 2)
my-string)
;; => "hello world HELLO" ; 仅第 2 次匹配被转为大写
@ -1554,7 +1597,7 @@ START/END 边界和 SUBEXP 捕获组的用法与
(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 6 17)
(tp-forward-do #'upcase 'marker tp-any-value my-string 2 6 17)
my-string)
;; => "hello world hello" ; 范围 6-17 内仅有 1 个匹配，请求的
;; 第 2 个匹配不存在：不做任何应用（要么全有要么全无；
@ -1570,7 +1613,7 @@ START/END 边界和 SUBEXP 捕获组的用法与
(lambda (text start end)
(setq match-info (list start end))
(upcase text))
'marker nil my-string 2)
'marker tp-any-value my-string 2)
(list my-string match-info))
;; => ("hello world HELLO" (12 17)) ; 仅最后一次匹配被转换
@ -1578,7 +1621,7 @@ START/END 边界和 SUBEXP 捕获组的用法与
(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)
(tp-backward-do #'upcase 'marker tp-any-value my-string 2)
my-string)
;; => "HELLO world hello" ; 向后搜索时第一个匹配（即最后找到的）被转为大写
```
@ -1646,7 +1689,9 @@ START/END 边界和 SUBEXP 捕获组的用法与
**字符串无法就地改变长度**：长度不同的替换会发出错误信号；
长度相同的替换会就地应用。
- **PROPERTY** 是要搜索的文本属性。
- **VALUE** 为 nil 时，表示搜索 PROPERTY 属性，不用匹配值。
- **VALUE** 遵循 presence-aware 搜索契约：省略表示任意已存在值；显式
nil 表示“键存在且值为 nil”。需要继续传入后续位置参数时使用
`tp-any-value`。
- **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。
- **START** 和 **END** 默认为 OBJECT 的起始和结束位置。
- 返回处理的匹配数量。
@ -1658,7 +1703,7 @@ START/END 边界和 SUBEXP 捕获组的用法与
(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)
(tp-search-map #'upcase 'marker tp-any-value my-string)
my-string)
;; => "HELLO world HELLO"
@ -1666,7 +1711,7 @@ START/END 边界和 SUBEXP 捕获组的用法与
(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 0 10)
(tp-search-map #'upcase 'marker tp-any-value my-string 0 10)
my-string)
;; => "HELLO world hello" ; 仅范围 0-10 内的第一个匹配被处理
@ -1681,20 +1726,129 @@ START/END 边界和 SUBEXP 捕获组的用法与
(lambda (text start end idx)
(push (list idx start end) positions)
(upcase text))
'marker nil my-string)
'marker tp-any-value my-string)
(list my-string (nreverse positions)))
;; => ("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11)))
;; 不使用可选参数的自定义转换
(let ((my-string (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) my-string)
(tp-search-map #'upcase 'marker nil my-string)
(tp-search-map #'upcase 'marker tp-any-value my-string)
my-string)
;; => "HELLO world"
```
---
## 原生文本属性兼容
Stage 3 明确了文本属性边界，Stage 5 增加 overlay-aware 字符属性查询。这组 API 映射 GNU Emacs 原语；tp 不管理 overlay 生命周期。
#### `tp-lookup-result` / `tp-lookup`
`tp-lookup` 返回 `tp-lookup-result` 记录。使用自动生成的访问器读取字段：
| 访问器 | 含义 |
|--------|------|
| `tp-lookup-result-property` | 请求的属性 |
| `tp-lookup-result-value` | 解析出的值 |
| `tp-lookup-result-present-p` | 选定来源提供该属性时为非 nil；direct 显式 nil 计为存在，alias nil 则遵循 Emacs 的 alias fallback |
| `tp-lookup-result-source` | `:text-direct`、`:category`、`:alias`、`:default` 或 `:absent` |
| `tp-lookup-result-mode` | 查询模式 |
| `tp-lookup-result-object` | 被查询对象 |
| `tp-lookup-result-position` | 被查询位置 |
| `tp-lookup-result-overlay` | `:char` / `:char-source` 中的获胜 overlay；其他模式为 nil |
模式：
| 模式 | 行为 |
|------|------|
| `:text-direct` | 只检查 `text-properties-at` 的直接文本属性；显式 nil 算存在 |
| `:text-effective` | 返回 `get-text-property` 的有效文本值，并报告其文本来源 |
| `:text-source` | 报告不含 overlay 的获胜文本来源 |
| `:char` | overlay-aware 的 `get-char-property-and-overlay` 值；文本 fallback 遵循 Emacs |
| `:char-source` | 类似 `:char`，当 overlay 获胜时额外记录 `:overlay` 来源和 overlay 对象 |
```elisp
;; direct 查询区分显式 nil 与缺失
(let ((str (copy-sequence "ab")))
(put-text-property 0 1 'state nil str)
(let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct))
(absent-result (tp-lookup 1 'state :object str :mode :text-direct)))
(list (list (tp-lookup-result-present-p nil-result)
(tp-lookup-result-value nil-result)
(tp-lookup-result-source nil-result))
(list (tp-lookup-result-present-p absent-result)
(tp-lookup-result-value absent-result)
(tp-lookup-result-source absent-result)))))
;; => ((t nil :text-direct) (nil nil :absent))
;; source-aware 查询解释 category/default/alias/direct 文本来源
(let* ((str (copy-sequence "a"))
(category (make-symbol "tp-doc-category")))
(put category 'state 'category-value)
(put-text-property 0 1 'category category str)
(let ((result (tp-lookup 0 'state :object str :mode :text-source)))
(list (tp-lookup-result-value result)
(tp-lookup-result-source result))))
;; => (category-value :category)
;; char-source 查询报告获胜 overlay 身份
(with-temp-buffer
(insert "x")
(let ((low (make-overlay 1 2))
(high (make-overlay 1 2)))
(overlay-put low 'priority 1)
(overlay-put low 'state 'low)
(overlay-put high 'priority 10)
(overlay-put high 'state 'high)
(let ((result (tp-lookup 1 'state :mode :char-source)))
(list (tp-lookup-result-value result)
(tp-lookup-result-source result)
(eq (tp-lookup-result-overlay result) high)))))
;; => (high :overlay t)
```
`tp-lookup` 会报告 overlay 获胜者，但 overlay 创建、删除、移动、priority 管理和生命周期仍由 Emacs 原生机制负责。
#### `tp-property-change`
`tp-property-change` 封装 `next-property-change`、`previous-property-change`、`next-single-property-change` 和 `previous-single-property-change`。
```elisp
(tp-property-change POSITION :object OBJECT :limit LIMIT :direction :next)
(tp-property-change POSITION :property PROPERTY :object OBJECT :limit LIMIT :direction :previous)
```
省略 `:property` 表示任意属性变化；传入 `:property` 表示单属性变化。`:direction` 为 `:next` 或 `:previous`。
#### `tp-property-any` / `tp-property-not-all`
这两个函数是 Emacs 原语的薄封装：
```elisp
(tp-property-any START END PROPERTY VALUE &optional OBJECT)
(tp-property-not-all START END PROPERTY VALUE &optional OBJECT)
```
它们完整保留 Emacs 行为，包括显式 nil 匹配。
#### `tp-with-mutation-policy`
`tp-with-mutation-policy` 显式声明 buffer 修改的 modified/read-only 行为：
| 策略 | 行为 |
|------|------|
| `(:modified :ordinary :read-only :respect)` | 普通 Emacs 修改；read-only 文本可报错 |
| `(:modified :ordinary :read-only :inhibit)` | 绑定 `inhibit-read-only`，并记录普通 modified/undo 状态 |
| `(:modified :silent :read-only :inhibit)` | 绑定 `inhibit-read-only`，并使用 `with-silent-modifications` |
`(:modified :silent :read-only :respect)` 会被拒绝，因为 silent modification 不能与尊重 read-only 文本同时成立。
insert/copy/yank/stickiness/narrowing/indirect-buffer 行为直接委托 Emacs。tp 不提供这些操作的 wrapper；请使用原生原语（`insert`、`insert-and-inherit`、`copy-sequence`、`substring`、`insert-for-yank`、narrowing 命令和 indirect buffer）。
---
## 属性层系统
属性层系统是 tp.el 的创新功能，允许在同一文本区域堆叠多组属性。只有顶层属性可见，但下层属性会被保留，并可通过轮转或固定操作使其显现。
@ -2417,7 +2571,7 @@ LAYER 返回 nil 而不发出错误信号。
: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)
;; => (:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2)
```
---
@ -2843,6 +2997,10 @@ OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的
的属性 —— 隐藏的内容绝不会泄漏（参见[属性层合并](#属性层合并)）。
- 隐藏状态以 `tp-hidden` 标志的形式存储在 `tp-layers` 栈存储内该层的
plist 中，因此 `tp-hidden` 与 `tp-name` 一样是层内部的保留属性名。
- 任一层隐藏期间，直接属性是第一个可见 managed layer 的渲染缓存。
definition/reactive refresh 具备明确所有权上下文，会把原生编辑保留到该
可见层；普通栈解码/写入仍采用严格策略，缓存不一致时会在改变状态之前发出
`tp-layer-conflict`。所有层都隐藏时出现直接属性始终属于冲突。
两个函数都返回被修改的属性区段数量。NAME 不匹配任何层时从不发出错误信
号，隐藏一个已隐藏的层（或显示一个可见的层）是静默的空操作 —— 返回 0
@ -2910,6 +3068,64 @@ OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的
---
### Managed Layer 生命周期
Stage 4 为 managed layer stack 增加显式生命周期 metadata。只要存在 metadata，单个 managed layer 现在也使用 `tp-layers` 存储，因为 `tp-meta` 是权威生命周期状态。直接渲染到文本上的属性和公开 stack 查询都会剥离 `tp-meta`：`text-properties-at` 应只显示渲染属性和 stack storage，`tp-layer-stack-at` 返回的公开层 plist 不含 metadata。
历史返回值保持不变。stack mutator 仍返回各自已记录的 object/range/run-count；诊断信息通过独立的只读 API 查询。
参数化 mounted layer 会把 args 和 definition version 存入 `tp-meta`。重新定义参数化层后，已挂载 entry 会用保存的 args 刷新。metadata 出现前创建的 entry 作为 legacy entry 保守处理。
#### `tp-attach-managed-layers` / `tp-detach-managed-layers`
```elisp
(tp-attach-managed-layers START END &optional OBJECT)
(tp-detach-managed-layers START END &optional OBJECT KEEP-RENDERED)
```
`tp-attach-managed-layers` 扫描已含 managed layer storage 的区域，补齐缺失 metadata，把发现的层登记到响应式缓冲区注册表，并按范围顺序返回层名。通过原生插入路径插入带 managed 属性的字符串后使用它。
`tp-detach-managed-layers` 移除 managed storage 并返回被 detach 的层名。KEEP-RENDERED 非 nil 时，当前可见渲染属性会保留为普通文本属性；生命周期存储（`tp-name`、`tp-layers`、`tp-meta`）会被移除。
#### `tp-managed-layer-diagnostics` / `tp-managed-buffer-diagnostics` / `tp-managed-diagnostics`
```elisp
(tp-managed-layer-diagnostics LAYER-NAME)
(tp-managed-buffer-diagnostics &optional BUFFER)
(tp-managed-diagnostics)
```
这些函数是只读诊断。它们报告 layers、buffers、entries、保存的 args、registry state、errors 和 theme diagnostics。`tp-managed-diagnostics` 包含 `:theme` plist，其中有 generation、last hook source、refresh mode、refreshed ranges 和 errors。theme enable/disable hook 会递增 generation，并使用 conservative refresh diagnostics；这是生命周期证据，不是 benchmark。
#### `tp-layer-transaction`
```elisp
(tp-layer-transaction START END OBJECT FUNCTION &optional NOERROR)
```
在 managed range 上执行 FUNCTION。成功时返回结构化 plist，包含 `:status ok`、`:ok t`、FUNCTION 返回值对应的 `:result`、operation id、range 和 changed ranges。失败时恢复事务前的完整文本/属性快照；默认发出 `tp-layer-transaction-error`，NOERROR 非 nil 时返回带 rollback 状态的结构化失败 plist。
```elisp
(progn
(tp-layer-reset)
(define-tp tx-base () '(face bold))
(define-tp tx-temp () '(face italic))
(with-temp-buffer
(insert "abcd")
(let ((result
(tp-layer-transaction
1 4 (current-buffer)
(lambda () (tp-put-layer 1 3 'tx-base 0)))))
(list (plist-get result :status)
(plist-get result :range)
(tp-at 1 'face)))))
;; => (ok (1 . 4) bold)
```
theme generation 与 managed diagnostics 已作为生命周期行为验证。可复现 benchmark 证据记录在 `docs/BENCHMARKS.md`；这些耗时是建议性基线，不是发布阈值。
---
### 属性层合并
#### `tp-merge-layers` - 合并多个属性层
@ -3783,7 +3999,11 @@ OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的
- 接收原始的 `tp-text` 字符串值
- 返回用于显示的转换后字符串
- 在初始显示和响应式更新时都会应用
- 转换函数中的错误会被捕获并记录
- 必须返回字符串；失败或返回非字符串会向上传播，不会渲染陈旧输入
compute 函数遵循相同的业务错误规则。watch 回调属于 observer：其失败会被
隔离，渲染仍继续；结构化错误按 newest-first 记录在
`tp-reactive-observer-errors`。
### 匿名响应式层
@ -3815,6 +4035,12 @@ OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的
(tp-regexp-set "[0-9]+" 'warning-style)
```
对非响应式层而言，这种直接使用属于**模板展开**：定义被展开为普通文本
属性，不保留 `tp-name`。如果需要后续按名查询、移动、隐藏、删除，或在非
参数化层重定义后刷新，请使用 `tp-push-layer` / `tp-put-layer` 建立
**managed mount**。参数化 mounted entry 目前没有保存实参，因此参数化层
重定义不会自动刷新既有实例。
### 响应式层组
层组也可以使用响应式特性：

171
docs/API-SEMANTICS.md Normal file
View File

@ -0,0 +1,171 @@
# tp API 语义规范
本文档是 tp 核心 API 的当前行为契约。代码、测试、README 与 docstring 若与本文冲突，应以经过测试的代码为准并同步修正文档。
tp 当前定位是 **Emacs 文本属性的高层操作工具箱，以及一套受管理的命名层、层栈和响应式渲染模型**。它尚不是全部原生文本/字符属性语义的等价替代品；完整范围与路线见 [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。
Stage 2 canonical façade 已完成为内部模型：`tp--native-range`、`tp--presence`、`tp--request`、`tp--match`、`tp--result` 是模块间传递的规范记录。公开入口和历史返回值保持兼容，不因内部模型收敛而改变。
Stage 3 text-only 原生语义 façade 已完成：direct/effective/source-aware lookup、property change/any/not-all 与三种 mutation policy 组合均有明确公开边界。
Stage 4 managed lifecycle 已完成：managed metadata、attach/detach、diagnostics、transaction、参数化 mounted layer args/version refresh 与 theme generation diagnostics 均有公开边界。
Stage 5 overlay-aware 字符属性查询已完成：`tp-lookup :char` / `:char-source` 报告 Emacs 选出的字符属性值、overlay 来源和获胜 overlay 身份。overlay 创建、移动、删除、priority 管理和生命周期不属于 tp 契约。
## 1. 对象、范围与坐标
- 所有范围均采用半开区间 `[START, END)`。
- 字符串使用 Emacs 原生的 0-based 坐标，合法边界为 `0` 到 `(length STRING)`。
- 缓冲区使用 Emacs 原生位置，通常从 `point-min` 开始；显式 BUFFER 和 nil（当前缓冲区）具有相同语义。
- 范围结果原则上使用目标对象的原生坐标。当前公开兼容例外是 `tp-intervals` / `tp-intervals-map`：缓冲区默认返回相对 START 的 offset，传入 `ABSOLUTE` 才返回可直接回传给写 API 的原生坐标。内部 canonical range 使用原生坐标，但该 relative 默认作为历史兼容例外保留。
## 2. 修改策略
| 调用族 | 字符串 | 缓冲区 |
| --- | --- | --- |
| `tp-set` / `tp-reset` / `tp-add` / `tp-remove` 整串形式 | 复制后返回新字符串 | 不适用 |
| 上述函数的 START/END 形式 | 原地修改显式字符串 OBJECT | 原地修改 |
| `tp-match-*` / `tp-regexp-*` | 返回新字符串 | 原地修改，返回匹配范围 |
| 层栈修改函数 | 原地修改字符串 | 原地修改 |
| `tp-forward-do` / `tp-backward-do` / `tp-search-map` | 原地修改；替换文本必须等长 | 原地修改；替换文本可增减长度 |
普通缓冲区写入使用 Emacs 的属性修改原语，因此遵循 Emacs 的 modified、undo 和 read-only 行为；tp 不把所有修改默认包装为 silent modification。响应式重渲染和 `tp-text` 文本替换为了恢复受管理输出会在内部允许修改 read-only 文本，这是当前实现边界，不代表公开 API 已提供统一的 read-only 策略。相同值刷新会尽量避免无意义地翻转 buffer-modified 状态。
## 3. presence、nil 与 wildcard
以下三种状态必须区分：
1. 属性键不存在；
2. 属性键存在，值为 nil；
3. 属性键存在，值为非 nil。
`tp-member` 用于判断直接属性键是否存在；`tp-at` / `plist-get` 单独使用时不能区分前两种状态。删除最后一个子属性会移除空的父属性键，不会偶然留下 `(PROPERTY nil)`。
搜索 API 的规则是：
- 省略 VALUE：匹配该直接属性的任意已存在值；
- 显式传入 nil：只匹配“键存在且值为 nil”；
- 需要继续提供 OBJECT、次数或范围等后续位置参数时，传入公共唯一哨兵 `tp-any-value` 表示任意值；
- 自定义 PREDICATE 总是优先执行，并接收请求 VALUE（可能是 `tp-any-value`）和实际属性值。
属性缺失的范围不属于搜索结果，即使搜索值是 nil。
## 4. 搜索结果
- `tp-search` 对字符串和缓冲区范围都返回 `(START END VALUE)` 列表。
- `tp-forward` / `tp-backward` 的字符串路径返回前/后 N 个 `(START END VALUE)`；缓冲区路径移动 point，并返回第 N 次搜索的 `prop-match`。
- `tp-forward-do` / `tp-backward-do` 只在第 N 个匹配上调用函数；匹配不足 N 个时不调用函数，返回实际找到的数量。
- `tp-search-map` 处理全部匹配并返回处理数量。
`tp-forward` / `tp-backward` 的对象相关结果差异是现存公开兼容契约。内部搜索路径已收敛到 canonical match/result 记录；公开返回结构暂不改变。
## 5. 原生文本查询与修改策略
Stage 3/5 查询 façade 已完成：text modes 保持 text-only，char modes 委托 Emacs 的 overlay-aware 字符属性查询。
`tp-lookup` 返回 `tp-lookup-result` 记录，字段为 property、value、present-p、source、mode、object、position、overlay。text modes 中 overlay 始终为 nil；`:char` / `:char-source` 中 overlay 为 Emacs 选出的获胜 overlay，若文本 fallback 获胜则为 nil。
| MODE | 语义 |
| --- | --- |
| `:text-direct` | 只读取直接文本属性；显式 nil 与缺失通过 present-p/source 区分 |
| `:text-effective` | 值使用 `get-text-property`；source 使用 text-only 来源解释 |
| `:text-source` | 返回 direct/category/alias/default/absent 来源和值，不查看 overlay |
| `:char` | 使用 `get-char-property-and-overlay` 的值，按 Emacs overlay/text 优先级解析 |
| `:char-source` | 同 `:char`，并在 overlay 获胜时把 source 设为 `:overlay`、overlay 设为获胜 overlay |
source 取值为 `:text-direct`、`:category`、`:alias`、`:default`、`:overlay` 或 `:absent`。direct 显式 nil 的结果是 present-p 为 t、value 为 nil、source 为 `:text-direct`；alias nil 与 Emacs 原生语义一致，会继续寻找后续 alias/default；缺失属性的结果是 present-p 为 nil、value 为 nil、source 为 `:absent`。
`tp-property-change` 是 Emacs property change 原语的显式封装：`:direction :next` / `:previous` 选择 next/previous，传入 `:property` 时使用 single-property change，省略时使用 all-property change。
`tp-property-any` / `tp-property-not-all` 是 `text-property-any` / `text-property-not-all` 的薄封装，保留 Emacs 对显式 nil、边界和对象的行为。
`tp-with-mutation-policy` 只接受三种有效组合：
| POLICY | 语义 |
| --- | --- |
| `(:modified :ordinary :read-only :respect)` | 普通修改，尊重 read-only |
| `(:modified :ordinary :read-only :inhibit)` | 绑定 `inhibit-read-only`，普通 modified/undo 行为 |
| `(:modified :silent :read-only :inhibit)` | 绑定 `inhibit-read-only` 并使用 `with-silent-modifications` |
`(:modified :silent :read-only :respect)` 明确拒绝，因为 silent modification 与尊重 read-only 不能同时满足。
insert、copy、yank、stickiness、narrowing 和 indirect buffer 行为直接委托 Emacs；tp 不为这些原生操作提供 wrapper。
## 6. 直接模板展开与 managed mount
层名有两种不同用途：
### 6.1 直接模板展开
把非响应式层名传给 `tp-set`、`tp-reset`、`tp-add`、`tp-match-*` 或 `tp-regexp-*` 时，层定义展开为普通属性，通常不保留 `tp-name`。结果不能依赖层名进行后续移动、隐藏、按名删除或静态重定义刷新。
匿名响应式属性和响应式层需要保留 `tp-name` 才能登记与刷新，这是直接路径中的受管理例外。
### 6.2 managed mount
`tp-push-layer` / `tp-put-layer` 明确保留 `tp-name` 和必要的 `tp-layers` 状态。mounted layer 可以被查询、移动、隐藏、显示、删除和响应式刷新。
非参数化层重新定义后，已挂载区域按 old/new 所有权协调：
- 新定义写入其拥有的键；
- 旧定义拥有、但新定义不再拥有的键，仅在当前值仍等于旧值时移除；
- 外部已经改写的值不会被当作旧层残留删除。
所有 managed mount 都携带 lifecycle metadata。即使只有单个 managed layer，只要存在 `tp-meta`，权威存储也使用 `tp-layers`；直接渲染属性和 `tp-layer-stack-at` 等 public stack query 不暴露 `tp-meta`。
参数化层的已挂载 entry 保存调用实参、形参表和 definition version；重新定义参数化层后，既有 managed entry 会按保存的 args 刷新。历史无 metadata 的 entry 按 legacy entry 保守处理。
`tp-attach-managed-layers` 扫描已经进入缓冲区的 managed storage，补齐/规范化 metadata，登记发现的层，并返回层名列表。`tp-detach-managed-layers` 移除 managed storage；KEEP-RENDERED 非 nil 时保留当前可见渲染属性为普通文本属性。
`tp-managed-layer-diagnostics`、`tp-managed-buffer-diagnostics` 和 `tp-managed-diagnostics` 是只读诊断入口，报告 entries、args、registry、errors 与 theme diagnostics。`tp-managed-diagnostics` 的 theme 部分报告 generation、last hook source、refresh mode、refreshed ranges 和 errors；这是 lifecycle 诊断，不是性能基准。
`tp-layer-transaction` 在给定范围内执行 managed stack 修改。成功返回结构化 plist，其中 `:status` 为 `ok`、`:ok` 为 t，`:result` 保留 FUNCTION 的返回值；失败时恢复事务前文本/属性快照并默认发出 `tp-layer-transaction-error`，NOERROR 非 nil 时返回结构化失败 plist。
## 7. `tp-text` 替换
- 初次应用和响应式更新都按内嵌字符串的真实属性 interval 处理，不从位置 0 采样后扩散到整段。
- 调用者显式属性覆盖内嵌属性；显式 nil 也是有效覆盖值。
- 未被调用者覆盖的内嵌属性按各自 interval 保留。
- 每个 interval 算出待写属性后，`tp-set` 只覆盖这些键并保留其他目标属性，`tp-reset` 替换目标的完整属性集合，`tp-add` 则对目标已有的 face-family 与嵌套 plist 继续合并；文本内容相同和发生替换时遵守同一规则。
- 字符串和缓冲区路径遵守相同的 per-interval 属性计算；对象的复制/原地策略仍按第 2 节执行。
## 8. 错误边界
- 未定义或无法解析的层使用 `tp-unresolved-layer` 表达。
- 栈 API 的 NOERROR 只抑制 `tp-unresolved-layer`；参数化层 body、计算、属性结构和其他内部错误必须传播。
- 隐藏层存储发生所有权冲突时使用 `tp-layer-conflict`。
- transform 失败或返回非字符串、compute 失败都属于业务输出失败，必须传播。
- watcher 属于 observer：单个 watcher 失败不会阻断 managed update；失败会记录到 `tp-reactive-observer-errors`（newest first）并输出消息。
- 公开边界不应把内部失败转换为默认值后继续写入。
## 9. 隐藏层与外部直接修改
存在隐藏层时，`tp-layers` 保存完整 managed stack，其他直接属性是第一个可见层的渲染缓存。两类调用采用不同但明确的策略：
- definition/reactive refresh 知道正在刷新哪个定义，也知道直接属性对应哪个可见 entry；它先把原生直接编辑协调进该可见 entry，再执行 old/new 所有权刷新，因此外部改写值不会被当作旧定义残留删除；
- 普通 stack decode/write 缺少这次 definition refresh 的所有权上下文，缓存不一致时会在写入前发出 `tp-layer-conflict`，且不修改层栈；
- 所有层都隐藏时没有可接收直接属性的可见 entry，此时出现直接属性始终发出 `tp-layer-conflict`。
tp 不会把外部属性收编成新的匿名层，也不会静默覆盖它。
## 10. 返回值现状
核心写 API 的返回值仍保留历史差异：
- buffer/region `tp-set` / `tp-reset` / `tp-add`：`(START . END)`；
- 整串复制式写入：新字符串；
- buffer `tp-remove` / `tp-clear`：nil；
- stack mutator：修改的 property-run 数量；
- `tp-put-layer` / `tp-push-layer`：显式 OBJECT 或 `(START . END)`。
这些返回值是当前兼容契约。property-run 数量会受无关 interval 边界影响，不应被当成稳定业务标识。内部 request/result 模型已建立，但不会改变这些历史 public returns。
## 11. 明确不在当前完整契约内
以下能力仍需设计或补齐，不能据现有 API 推断：
- overlay lifecycle（创建、移动、删除、priority 管理）；
- insert/copy/yank/stickiness 的 tp wrapper 或 managed workflow；
- mutation policy 三种组合之外的统一 read-only、silent modification、undo 策略；
- 字符串/缓冲区完全一致的搜索结果结构；
- observer 错误的清理、重试与汇总策略。

104
docs/ARCHITECTURE.md
View File

@ -2,12 +2,17 @@
本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。
自 0.2.0 起，原来的单文件 tp.el 已拆分为九个分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。0.3.0 进一步收紧了模块边界：`tp-text` 处理链下沉至 tp-ops、批量更新上收至 tp-render、层栈存储编解码与匿名层机制归位 tp-layer，钩子变量从四个减少到两个。各变更的缘由见 [CHANGELOG.md](../CHANGELOG.md)。
当前 API 的规范契约见 [API-SEMANTICS.md](API-SEMANTICS.md)；Emacs 原生
文本属性覆盖范围、已确认问题与演进路线见
[REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。
自 0.2.0 起，原来的单文件 tp.el 已拆分为分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。0.3.0 进一步收紧了模块边界：`tp-text` 处理链下沉至 tp-ops、批量更新上收至 tp-render、层栈存储编解码与匿名层机制归位 tp-layer，钩子变量从四个减少到两个。Stage 3 新增 tp-query，承载原生文本查询/change 封装与修改策略。各变更的缘由见 [CHANGELOG.md](../CHANGELOG.md)。
## 目录
- [架构概述](#架构概述)
- [模块分层](#模块分层)
- [Canonical records 与 dataflow](#canonical-records-与-dataflow)
- [tp-core.el：基础工具](#tp-coreel基础工具)
- [tp-reactive.el：响应式基础设施](#tp-reactiveel响应式基础设施)
- [tp-layer.el：层定义、解析与层栈存储](#tp-layerel层定义解析与层栈存储)
@ -15,6 +20,7 @@
- [tp-search.el：模式匹配与搜索](#tp-searchel模式匹配与搜索)
- [tp-render.el：响应式渲染引擎](#tp-renderel响应式渲染引擎)
- [tp-stack.el：属性层栈操作](#tp-stackel属性层栈操作)
- [tp-query.el：原生文本查询与修改策略](#tp-queryel原生文本查询与修改策略)
- [tp-palette.el：调色板数据](#tp-paletteel调色板数据)
- [tp-builtins.el：内置层与辅助工具](#tp-builtinsel内置层与辅助工具)
- [钩子变量：唯一许可的反向调用](#钩子变量唯一许可的反向调用)
@ -30,7 +36,7 @@ tp 采用严格的线性分层：**每个模块只允许 `require` 并调用排
```
tp-core → tp-reactive → tp-layer → tp-ops → tp-search
→ tp-render → tp-stack → tp-palette → tp-builtins
→ tp-render → tp-stack → tp-query → tp-palette → tp-builtins
```
注意加载顺序是依赖顺序的**上界**：并非每个模块都依赖它前面的全部模块。各模块实际 `require` 的 tp- 模块如下（逐一核对自源码头部）：
@ -44,6 +50,7 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
| tp-search | tp-core、tp-reactive、tp-layer、tp-ops |
| tp-render | tp-core、tp-reactive、tp-layer、tp-ops、tp-search |
| tp-stack | tp-core、tp-reactive、tp-layer（**不依赖 tp-ops / tp-search / tp-render**） |
| tp-query | tp-core |
| tp-palette | —（不依赖任何 tp- 模块，仅 subr-x） |
| tp-builtins | tp-core、tp-layer、tp-ops、tp-palette |
@ -58,6 +65,8 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
│ tp-palette.el 明/暗主题调色板数据、tp-parse-color │
│ （独立叶模块，不依赖任何 tp- 模块） │
├────────────────────────────────────────────────────────────────┤
│ tp-query.el 原生文本 lookup/change 封装、mutation policy │
├────────────────────────────────────────────────────────────────┤
│ tp-stack.el 层栈操作（push/pop/move/hide/show/merge …） │
├────────────────────────────────────────────────────────────────┤
│ tp-render.el 响应式重渲染引擎、最小差异 tp-text 编辑、 │
@ -91,6 +100,20 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
## 模块分层
### Canonical records 与 dataflow
Stage 2 canonical façade 是内部模型，不改变公开入口和历史返回值。五个记录承担模块间的规范数据边界：
| 记录 | 所有者 | 用途 |
|------|--------|------|
| `tp--native-range` | tp-core | 目标对象的原生 `[START, END)` 范围；字符串使用 0-based，缓冲区使用原生 buffer position |
| `tp--presence` | tp-core | 区分属性缺失、present nil、present non-nil |
| `tp--request` | tp-ops | 公开重载参数解析后的规范请求：对象、范围、操作、属性/值/谓词、修改策略 |
| `tp--match` | tp-search | 搜索内部匹配结果，统一字符串与缓冲区路径 |
| `tp--result` | tp-search | 搜索内部结果载体；最终按公开 API 的历史契约适配返回 |
数据流为：公开入口解析成 `tp--request`，tp-core 提供对象、native range、presence 与 adapter，tp-ops/tp-search/tp-stack 只在 I/O 边界按对象类型分支。内部搜索先产生 canonical `tp--match` / `tp--result`，再由公开入口保留旧返回结构；`tp-intervals` / `tp-intervals-map` 的缓冲区 relative 默认是显式保留的兼容例外。
### tp-core.el：基础工具
最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。0.3.0 起 tp-core **不再持有任何可变状态**（匿名层计数器已迁至 tp-layer；仅剩 `tp-debug-mode` / `tp-debug-echo` 两个 defcustom 用户选项）。
@ -112,7 +135,6 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
| `tp--merge-face-values` | 合并两个 face 值 | 合并引擎内部 |
| `tp--merge-duplicate-keys` | 合并 plist 中的重复键 | tp--parse-args |
| `tp--parse-face-list` | 解析 face 列表 | 合并引擎内部 |
| `tp--merge-string-props-into-plist` | 将字符串内嵌属性并入 plist | tp-ops 的 tp-text 处理链 |
| `tp--get-nested` | 按路径获取嵌套属性值 | tp-get, tp-at |
`tp-face-properties`（常量，`'(face font-lock-face mouse-face)`）定义参与 face 感知合并的属性家族。
@ -238,11 +260,14 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
| `tp--normalize-layer-spec` | 规范化层规格（含多参数 `(LAYER ARG1 ... ARGN)`） |
| `tp--build-layer-props` / `tp--layer-stack-to-list` | 旧式编解码原语（无隐藏层语义） |
| `tp--stack-hidden-p` | 层 plist 是否带 `tp-hidden` 标志 |
| `tp--stack-props-to-list` | 原始属性 → 有序层列表（顶层在前，含隐藏层）。有隐藏层时 `tp-layers` 持有完整栈，直接属性只是最顶可见层的渲染缓存 |
| `tp--plist-equivalent-p` / `tp--assert-hidden-render-cache` | 普通栈解码时验证完整存储的直接渲染缓存；无刷新上下文的不一致在改写前发出 `tp-layer-conflict` |
| `tp--stack-props-to-list` | 原始属性 → 有序层列表（顶层在前，含隐藏层）。完整存储模式下 `tp-layers` 持有完整栈，直接属性只是最顶可见层的渲染缓存，并在普通解码时执行冲突检查；definition/reactive refresh 由 tp-render 在明确可见 entry 上协调外部编辑 |
| `tp--stack-build-props` | 有序层列表 → 原始属性。单层栈不携带 `tp-layers`；含隐藏层时切换为"完整栈 + 渲染缓存"存储模式（全部隐藏时不渲染任何层属性） |
| `tp--get-layer-by-idx-or-name` | 通过索引或名称查找层 |
钩子变量：`tp--layer-refresh-function`（定义于此，由 tp-render.el 安装为 `tp--update-layer-regions`）；`tp--layer-refresh` 是它的调用入口，层重定义后经它触发已应用区域的重渲染。
钩子变量：`tp--layer-refresh-function`（定义于此，由 tp-render.el 安装为
`tp--update-layer-regions`）；`tp--layer-refresh` 是它的调用入口，非参数化
层重定义后把 old props 一并传给渲染层，触发已挂载区域的 old/new 所有权协调。
---
@ -307,12 +332,12 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
#### 搜索和导航
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-forward` | 向前搜索 N 次并移动点；0.3.0 起接受 PREDICATE 与 NOT-CURRENT（默认保持 0.2.0 的对称 `equal` 匹配契约） | text-property-search-forward |
| `tp-forward` | 向前搜索 N 次并移动点；省略 VALUE 匹配任意直接存在值，显式 nil 精确匹配 present-nil | tp--property-search-forward |
| `tp-backward` | 向后搜索 N 次并移动点（与向前语义对称，同样新增 PREDICATE/NOT-CURRENT） | tp--property-search-backward |
| `tp--property-search-backward` | 带谓词的向后搜索引擎 | text-property-search-backward |
| `tp--property-match-p` | 谓词归一化（nil/t → `equal`；函数 → `(funcall PRED VALUE PROP-VALUE)`） | - |
| `tp--string-property-matches` | 字符串路径的按段匹配收集器 | - |
| `tp-search` | 收集所有匹配区间 | tp-intervals 等 |
| `tp--property-search-forward` / `tp--property-search-backward` | 基于统一直接属性 run 的单步搜索引擎 | tp--property-matches |
| `tp--property-match-p` | 谓词归一化（函数优先；否则 `tp-any-value` 通配，其他值用 `equal`） | - |
| `tp--property-matches` | 字符串/缓冲区共用、presence-aware 的直接属性 run 收集器 | text-properties-at, next-property-change |
| `tp-search` | 收集所有 `(START END VALUE)` 匹配区间 | tp--property-matches |
| `tp-search-forward` / `tp-search-backward` | **已废弃（0.3.0，make-obsolete）**：裸封装原语，nil-PREDICATE 默认语义与库内 `equal` 匹配相悖；请改用 `tp-forward` / `tp-backward`，或直接用 Emacs 原语 | text-property-search-* |
#### 遍历与替换
@ -339,10 +364,10 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
#### 重渲染
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp--update-layer-regions` | 重渲染携带某层的所有文本区域（替换该层自己的属性键，保留其他来源属性），并**写穿**到 `tp-layers` 栈存储 | tp--layer-render-props, tp-search-map, tp--write-layer-through-stack-storage |
| `tp--write-layer-through-stack-storage` | 把新属性写进栈存储里该层的条目（被覆盖或被隐藏的副本也保持最新，`tp-show-layer` 后渲染当前值而非陈旧快照；值未变的段不触碰缓冲区） | tp--stack-props-to-list, tp--stack-build-props [tp-layer] |
| `tp--merge-props-into-stack-entry` | 更新栈条目的键，保留其 `tp-hidden` 标志与栈位置 | - |
| `tp--update-layer-computed` | 更新 `:compute` 计算属性（nil 值可正常传播） | tp--resolve-reactive-symbols, tp--set-layer-props |
| `tp--update-layer-regions` | 用 old/new 所有权协调重渲染已挂载区域，并**写穿**到 `tp-layers` 栈存储 | tp--layer-render-props, tp-search-map, tp--write-layer-through-stack-storage |
| `tp--write-layer-through-stack-storage` | 先按旧定义移除仍由该层拥有的键，再写入新定义；被覆盖或隐藏的副本也保持最新 | tp--stack-props-to-list, tp--stack-build-props [tp-layer] |
| `tp--reconcile-layer-props` / `tp--reconcile-layer-region` | 计算和写入 old/new 属性协调；保留不属于旧层或已被外部改写的值 | - |
| `tp--update-layer-computed` | 更新 `:compute` 计算属性（nil 可传播；错误向上抛出） | tp--store-computed-value |
| `tp--layer-render-props` / `tp--layer-reactive-props` | 求取层的渲染属性 | tp-layer-props |
#### 响应式文本（tp-text）
@ -424,6 +449,52 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
| `tp-add-to-layers` | 向特定层添加属性 | tp--deep-merge-plist, tp--stack-map-region |
| `tp-add-to-all-layers` | 向所有层添加属性 | tp-add-to-layers |
#### Managed lifecycle（Stage 4）
| 函数/状态 | 描述 | 依赖 |
|------|------|------|
| `tp-meta` | lifecycle metadata，保存在 `tp-layers` 权威存储中；直接渲染属性和 public stack query 会剥离它 | tp--managed-render-props, tp--managed-public-layer-props |
| `tp--managed-operation-counter` | transaction/entry id 的单调计数器 | tp--managed-next-operation-id |
| `tp-attach-managed-layers` | 扫描已有 managed storage、规范化 metadata、登记发现的层并返回层名 | tp--managed-normalize-stack, tp-reactive--register-layer-buffer |
| `tp-detach-managed-layers` | 移除 managed storage；KEEP-RENDERED 时保留当前可见渲染属性 | tp--managed-detached-props |
| `tp-managed-layer-diagnostics` | 只读层诊断：entries、args、registry、buffers、errors | tp--managed-buffer-diagnostic-data |
| `tp-managed-buffer-diagnostics` | 只读缓冲区诊断 | tp--managed-buffer-diagnostic-data |
| `tp-managed-diagnostics` | 全局只读诊断，含 theme diagnostics | tp--managed-theme-diagnostics |
| `tp-layer-transaction` | managed transaction；失败恢复原文本/属性快照，默认发出 `tp-layer-transaction-error` | tp--transaction-* |
只要 layer stack entry 携带 `tp-meta`，即使只有一个 managed layer，也使用 `tp-layers` 保存权威 stack storage。参数化 mounted entry 保存 args、arglist 与 definition-version；层重定义后通过保存的 args 刷新既有 entry。历史无 metadata entry 作为 legacy entry 保守处理。
---
### tp-query.el：原生文本查询与修改策略
只依赖 tp-core。提供 Stage 3/5 原生 façade：直接/effective/source-aware text lookup、overlay-aware char lookup、property change/any/not-all 封装，以及显式 modified/read-only 修改策略。overlay lifecycle（创建、移动、删除、priority 管理）不属于 tp-query。
#### 查询记录与 lookup
| 函数/记录 | 描述 | 依赖 |
|------|------|------|
| `tp-lookup-result` | `cl-defstruct` 结果记录：property、value、present-p、source、mode、object、position、overlay | - |
| `tp-lookup` | 按 MODE 查询属性；支持 `:text-direct`、`:text-effective`、`:text-source`、`:char`、`:char-source` | tp--lookup-direct, tp--lookup-effective, tp--lookup-char, tp--lookup-source-cell |
| `tp--lookup-direct` | 只检查 `text-properties-at` 的直接 plist，区分 explicit nil 与 absent | plist-member |
| `tp--lookup-effective` | 值使用 `get-text-property`，source 使用 text-only 解释 | tp--lookup-source-cell |
| `tp--lookup-char` | 使用 `get-char-property-and-overlay`，overlay 获胜时 source 为 `:overlay` 且记录 overlay 对象 | get-char-property-and-overlay |
| `tp--lookup-source-cell` | 按 direct → category → alias → default → absent 解释来源 | text-properties-at, symbol-plist, char-property-alias-alist, default-text-properties |
| `tp--lookup-alias-cell` | 查找 `char-property-alias-alist` 中第一个直接存在的 alias 属性 | plist-member |
#### property change 与区域谓词
| 函数 | 描述 | 依赖 |
|------|------|------|
| `tp-property-change` | `:direction :next` / `:previous`；传入 PROPERTY 时走 single-property change，省略时走 all-property change | next/previous-property-change, next/previous-single-property-change |
| `tp-property-any` | `text-property-any` 薄封装 | text-property-any |
| `tp-property-not-all` | `text-property-not-all` 薄封装 | text-property-not-all |
#### 修改策略
| 函数/宏 | 描述 |
|------|------|
| `tp--mutation-policy-modes` | 校验并归一化 `:modified` 与 `:read-only`；拒绝 `(:modified :silent :read-only :respect)` |
| `tp-with-mutation-policy` | 三种有效组合：ordinary+respect、ordinary+inhibit、silent+inhibit |
insert/copy/yank/stickiness/narrowing/indirect buffer 均不在 tp-query 中封装，行为直接委托 Emacs 原生操作。
---
### tp-palette.el：调色板数据
@ -434,6 +505,9 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
|------|------|
| `define-tp-palette` | 定义调色板（重定义立即生效）；别名 `tp-define-palette` |
| `tp-palette-alist` | 调色板注册表（唯一数据源） |
| `tp-theme-generation` / `tp-theme-last-*` | theme lifecycle diagnostics：generation、last hook source、refresh mode、refreshed ranges、errors |
| `tp-theme-change-hook` | `enable-theme` / `disable-theme` 后运行的 hook；palette 只负责事件检测，managed renderer 可订阅 |
| `tp--palette-after-enable-theme` / `tp--palette-after-disable-theme` | theme lifecycle advice，递增 generation 并记录来源 |
| `tp-parse-color` | 解析颜色规格（支持 `("light" . "dark")` 及单边 cons） |
| `tp-theme-dark-p` / `tp-theme-light-p` | 当前主题判断 |
| `tp-palette-color` | 通用的主题解析取色器（0.3.0 新增的首选查询入口） |
@ -483,7 +557,7 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search
|------|------|------|------|
| tp-core | —— | **无可变状态**（仅 `tp-debug-mode`/`tp-debug-echo` 两个用户选项；调试日志写入 *tp-debug* 缓冲区，由 `tp-debug-clear` 清除） | - |
| tp-reactive | `tp-reactive-deps` | 变量 → 依赖层 注册表 | `tp-reactive-reset` |
| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` | `:watch` / `:compute` / `:data` 注册表 | `tp-reactive-reset` |
| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` / `tp-reactive-observer-errors` | `:watch` / `:compute` / `:data` 注册表与结构化 observer 错误 | `tp-reactive-reset` |
| tp-reactive | `tp--batch-update-pending` | 批量更新队列（0.3.0 起也被 reset 清空，防止残留条目对新定义的层重放） | `tp-reactive-reset` |
| tp-reactive | `tp--layer-buffers` | 层→缓冲区注册表（哈希表，0.3.0 新增） | `tp-reactive-reset`（clrhash）；单层条目随 `tp-undefine-layer`/层重定义移除；死缓冲区经 kill-buffer-hook 与惰性访问剔除 |
| tp-reactive | `tp--batch-update-active` / `tp--reactive-updating` | 动态标志（let 绑定，非持久状态） | 随作用域退出 |

42
docs/BENCHMARKS.md Normal file
View File

@ -0,0 +1,42 @@
# Reproducible benchmark evidence
## Command and environment
```sh
make benchmark \
EMACS=/Applications/Emacs.app/Contents/MacOS/Emacs \
LOAD_EXTRA='-L /tmp/tp-elpa.Ur243x/dash-2.20.0'
```
- Emacs: 30.2
- Fixed seeds: `1`, `7`, `42`, `747555`
- Reproducible generated seed: `8675309`
- Every scenario performs a correctness assertion before accepting timing.
- The full command completed successfully on 2026-07-28.
The runner is `tp-benchmark.el`; `make benchmark` is the stable entry point. Output rows include scenario, status, fixture, seed, requested/actual size, operations, scanned/changed/refreshed counts, elapsed wall time, and GC count.
## Representative result: seed 42
| Scenario | Requested / actual | Operations | Scanned | Changed | Refreshed | Elapsed (s) | GC |
| --- | ---: | ---: | ---: | ---: | ---: | ---: | ---: |
| large text | 100,000 | 2 | 100,000 | 100,000 | 0 | 0.000304 | 0 |
| large text | 1,000,000 | 2 | 1,000,000 | 1,000,000 | 0 | 0.000323 | 0 |
| fragmented intervals | 1,000 | 1 | 1,000 | 500 | 0 | 0.044254 | 0 |
| fragmented intervals | 10,000 | 1 | 10,000 | 5,000 | 0 | 0.404836 | 1 |
| fragmented intervals | 50,000 | 1 | 50,000 | 25,000 | 0 | 1.965066 | 3 |
| stack depth | 1 | 2 | 2,000 | 2,000 | 0 | 0.000909 | 0 |
| stack depth | 5 | 6 | 2,000 | 2,000 | 0 | 0.003204 | 0 |
| stack depth | 20 | 21 | 2,000 | 2,000 | 0 | 0.012905 | 0 |
| stack depth | 50 | 51 | 2,000 | 2,000 | 0 | 0.037830 | 0 |
| reactive fan-out | 1 / 1 | 1 | 1 | 1 | 1 | 0.000763 | 0 |
| reactive fan-out | 10 / 10 | 1 | 10 | 10 | 10 | 0.005469 | 0 |
| reactive fan-out | 100 / 100 | 1 | 100 | 100 | 100 | 0.051376 | 0 |
| reactive fan-out | 500 / 200 | 1 | 200 | 200 | 200 | 0.102989 | 0 |
| theme refresh | 1 / 1 | 1 | 1,000 | 0 | 1 | 0.001317 | 0 |
The 500-buffer fan-out fixture is intentionally capped at 200 live buffers on local hardware; output reports both requested and actual counts. Theme refresh uses the v1 conservative managed-range strategy.
## Interpretation
These figures are advisory, not release thresholds. Fragmented interval count is the clearest scaling risk and should remain the first optimization target. Large-text lookup over one property run and deep-stack top lookup are cheap in this fixture, but those results must not be generalized to fragmented text or repeated stack mutation.

3
docs/CODE-ANALYSIS.md
View File

@ -6,6 +6,9 @@
> tp.el 仅作总入口），并修复了大量已确认的 bug。当前架构请以
> [ARCHITECTURE.md](ARCHITECTURE.md) 为准，本次变更明细见 [CHANGELOG.md](../CHANGELOG.md)。
> 下文的调用堆栈与问题分析保留为历史分析；"文件结构"与"关键代码位置"表已更新为当前模块位置。
> 当前 0.3.0 的 API 语义、原生兼容能力、已确认缺陷与扩展路线，请参阅
> [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)；修复后的规范契约见
> [API-SEMANTICS.md](API-SEMANTICS.md)。
本报告旨在帮助想要参与 tp.el 开发的开发者快速了解项目结构、核心功能实现、以及潜在的优化方向。

1897
docs/REPOSITORY-AUDIT.md Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -488,7 +488,8 @@ 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
- Must return a string; errors and non-string results propagate rather
than leaving stale output visible
> 📖 **For more optimization features like batched updates and debug mode, see [Reactive System Optimization](reactive-optimization-en.md)**

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

@ -488,7 +488,7 @@ tp.el 的响应式系统借鉴了 Vue 的 API，提供了三个强大的关键
- 接收原始的 `tp-text` 字符串值
- 返回用于显示的转换后字符串
- 在初始显示和响应式更新时都会应用
- 转换函数中的错误会被捕获并记录
- 必须返回字符串；错误或非字符串返回值会向上传播，避免继续显示陈旧结果
> 📖 **更多优化功能如批量更新和调试模式，请参阅 [响应式系统优化文档](reactive-optimization.md)**

66
postmortem/2026-07-28-api-semantics-phase-1.md Normal file
View File

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

69
postmortem/2026-07-28-complete-text-property-facade.md Normal file
View File

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

217
tp-benchmark.el Normal file
View File

@ -0,0 +1,217 @@
;;; tp-benchmark.el --- Batch benchmarks for tp -*- lexical-binding: t -*-
;; Copyright (C) 2024-2026 Geekinney
;; Author: Geekinney (kinneyzhang666@gmail.com)
;;; Commentary:
;; Run with:
;; emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run
;;; Code:
(require 'cl-lib)
(require 'tp)
(defconst tp-benchmark--fixed-seeds '(1 7 42 747555)
"Fixed deterministic benchmark seeds.")
(defconst tp-benchmark--generated-seed 8675309
"Printed generated seed. Fixed so the benchmark output is reproducible.")
(defvar tp-bench-fanout-color nil
"Reactive color variable used by `tp-benchmark-run'.")
(defun tp-benchmark--print (plist)
"Print one benchmark row from PLIST."
(princ
(concat
(mapconcat
(lambda (key)
(format "%s=%S" (substring (symbol-name key) 1)
(plist-get plist key)))
'(:scenario :status :fixture :seed :requested :actual :operations
:scanned :changed :refreshed :elapsed :gcs :note)
" ")
"\n")))
(defun tp-benchmark--random-string (size seed)
"Return deterministic random string of SIZE using SEED."
(let ((state seed)
(chars "abcdefghijklmnopqrstuvwxyz")
(result (make-string size ?a))
(pos 0))
(while (< pos size)
(setq state (mod (+ (* state 1103515245) 12345) 2147483648))
(aset result pos (aref chars (mod state (length chars))))
(setq pos (1+ pos)))
result))
(defun tp-benchmark--measure (scenario fixture seed requested actual body)
"Measure BODY after GC and print a benchmark row."
(garbage-collect)
(let* ((gc-start gcs-done)
(start (float-time))
(result (funcall body))
(elapsed (- (float-time) start)))
(tp-benchmark--print
(append
(list :scenario scenario :status 'ok :fixture fixture :seed seed
:requested requested :actual actual)
result
(list :elapsed elapsed :gcs (- gcs-done gc-start) :note nil)))))
(defun tp-benchmark--blocked (scenario fixture seed requested note)
"Print a blocked benchmark row."
(tp-benchmark--print
(list :scenario scenario :status 'blocked :fixture fixture :seed seed
:requested requested :actual 0 :operations 0 :scanned 0
:changed 0 :refreshed 0 :elapsed nil :gcs 0 :note note)))
(defun tp-benchmark--large-text (size seed)
"Benchmark large text property set/search for SIZE and SEED."
(let ((text (tp-benchmark--random-string size seed)))
(tp-set 0 size '(tp-bench t) text)
(unless (equal (tp-search text 'tp-bench t) (list (list 0 size t)))
(error "large-text correctness failed"))
(set-text-properties 0 size nil text)
(tp-benchmark--measure
'large-text 'string seed size size
(lambda ()
(tp-set 0 size '(tp-bench t) text)
(let ((matches (tp-search text 'tp-bench t)))
(unless (equal matches (list (list 0 size t)))
(error "timed large-text correctness failed"))
(list :operations 2 :scanned size :changed size
:refreshed 0 :note (length matches)))))))
(defun tp-benchmark--fragmented (runs seed)
"Benchmark RUNS fragmented property intervals using SEED."
(let ((text (make-string runs ?x)))
(cl-loop for i below runs
when (zerop (mod i 2))
do (put-text-property i (1+ i) 'tp-bench i text))
(unless (= (length (tp-search text 'tp-bench)) (/ (1+ runs) 2))
(error "fragmented correctness failed"))
(tp-benchmark--measure
'fragmented 'string seed runs runs
(lambda ()
(let ((matches (tp-search text 'tp-bench)))
(list :operations 1 :scanned runs :changed (length matches)
:refreshed 0 :note nil))))))
(defun tp-benchmark--define-stack-layers (depth)
"Define DEPTH benchmark stack layers."
(cl-loop for i below depth
do (eval `(define-tp ,(intern (format "tp-bench-stack-%d" i))
() '(face bold)))))
(defun tp-benchmark--stack-depth (depth seed)
"Benchmark stack operations at DEPTH using SEED."
(tp-layer-reset)
(tp-benchmark--define-stack-layers depth)
(with-temp-buffer
(insert (make-string 2000 ?s))
(cl-loop for i below depth
do (tp-push-layer 1 2001
(intern (format "tp-bench-stack-%d" i))))
(unless (= (tp-layer-count 1 2001) depth)
(error "stack-depth correctness failed"))
(set-text-properties 1 2001 nil)
(tp-benchmark--measure
'stack-depth 'buffer seed depth depth
(lambda ()
(cl-loop for i below depth
do (tp-push-layer 1 2001
(intern (format "tp-bench-stack-%d" i))))
(unless (= (tp-layer-count 1 2001) depth)
(error "timed stack-depth correctness failed"))
(let ((top (tp-layer-top 1 2001)))
(list :operations (1+ depth) :scanned 2000 :changed 2000
:refreshed 0 :note top))))))
(defun tp-benchmark--define-fanout-layer (seed)
"Define one reactive layer for SEED."
(set 'tp-bench-fanout-color "red")
(eval '(define-tp tp-bench-fanout ()
:props '(face (:foreground $tp-bench-fanout-color))
:data '((tp-bench-fanout-color . "red"))))
seed)
(defun tp-benchmark--reactive-fanout (requested seed)
"Benchmark reactive fanout REQUESTED using SEED."
(let ((actual (min requested 200)))
(tp-layer-reset)
(tp-reactive-reset)
(tp-benchmark--define-fanout-layer seed)
(let ((buffers nil))
(unwind-protect
(progn
(dotimes (i actual)
(let ((buf (generate-new-buffer
(format " *tp-bench-fanout-%d*" i))))
(push buf buffers)
(with-current-buffer buf
(insert "x")
(tp-set 1 2 'tp-bench-fanout))))
(setq tp-bench-fanout-color "blue")
(with-current-buffer (car buffers)
(unless (equal (plist-get (get-text-property 1 'face)
:foreground)
"blue")
(error "reactive-fanout correctness failed")))
(tp-benchmark--measure
'reactive-fanout 'buffers seed requested actual
(lambda ()
(setq tp-bench-fanout-color "green")
(list :operations 1 :scanned actual :changed actual
:refreshed actual
:note (format "requested=%d actual=%d"
requested actual)))))
(mapc (lambda (buf)
(when (buffer-live-p buf) (kill-buffer buf)))
buffers)))))
(defun tp-benchmark--theme-refresh (seed)
"Benchmark current theme managed refresh hook using SEED."
(if (not (fboundp 'tp--refresh-managed-after-theme-change))
(tp-benchmark--blocked
'theme-managed-refresh 'buffer seed 1
"tp--refresh-managed-after-theme-change unavailable")
(tp-layer-reset)
(with-temp-buffer
(insert (make-string 1000 ?t))
(define-tp tp-bench-theme () '(face (:foreground "red")))
(tp-push-layer 1 1001 'tp-bench-theme)
(tp--refresh-managed-after-theme-change 'benchmark)
(unless tp-theme-last-refreshed-ranges
(error "theme-refresh correctness failed"))
(tp-benchmark--measure
'theme-managed-refresh 'buffer seed 1 1
(lambda ()
(tp--refresh-managed-after-theme-change 'benchmark)
(list :operations 1 :scanned 1000 :changed 0
:refreshed (length tp-theme-last-refreshed-ranges)
:note tp-theme-last-refresh-mode))))))
(defun tp-benchmark-run ()
"Run tp benchmarks in batch mode."
(interactive)
(princ (format "tp-benchmark emacs=%S generated-seed=%d fixed-seeds=%S\n"
emacs-version tp-benchmark--generated-seed
tp-benchmark--fixed-seeds))
(dolist (seed (append tp-benchmark--fixed-seeds
(list tp-benchmark--generated-seed)))
(dolist (size '(100000 1000000))
(tp-benchmark--large-text size seed))
(dolist (runs '(1000 10000 50000))
(tp-benchmark--fragmented runs seed))
(dolist (depth '(1 5 20 50))
(tp-benchmark--stack-depth depth seed))
(dolist (fanout '(1 10 100 500))
(tp-benchmark--reactive-fanout fanout seed))
(tp-benchmark--theme-refresh seed)))
(provide 'tp-benchmark)
;;; tp-benchmark.el ends here

43
tp-builtins.el
View File

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

136
tp-char-tests.el Normal file
View File

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

65
tp-core-tests.el
View File

@ -68,6 +68,71 @@
"The face-family property list contains the three face properties."
(should (equal tp-face-properties '(face font-lock-face mouse-face))))
;;; Stage 2 canonical façade
(ert-deftest tp-core-test-native-range-string-and-buffer-coordinates ()
"Canonical ranges store concrete objects and native coordinates."
(let* ((str (copy-sequence "abcd"))
(range (tp--native-range-from-object str 1 3)))
(should (tp--native-range-p range))
(should (eq (tp--native-range-kind range) :string))
(should (eq (tp--native-range-object range) str))
(should (equal (list (tp--native-range-start range)
(tp--native-range-end range))
'(1 3))))
(with-temp-buffer
(insert "abcd")
(narrow-to-region 2 4)
(let ((range (tp--native-range-from-object nil nil nil)))
(should (eq (tp--native-range-kind range) :buffer))
(should (eq (tp--native-range-object range) (current-buffer)))
(should (equal (list (tp--native-range-start range)
(tp--native-range-end range))
'(2 4))))))
(ert-deftest tp-core-test-presence-distinguishes-three-value-states ()
"Canonical presence distinguishes absence, explicit nil, and a value."
(let ((str (copy-sequence "abc")))
(put-text-property 0 1 'state nil str)
(put-text-property 1 2 'state 'ready str)
(let ((nil-value (tp--presence-at 0 'state str))
(value (tp--presence-at 1 'state str))
(absent (tp--presence-at 2 'state str)))
(should (tp--presence-present-p nil-value))
(should-not (tp--presence-value nil-value))
(should (tp--presence-present-p value))
(should (eq (tp--presence-value value) 'ready))
(should-not (tp--presence-present-p absent))
(should-not (tp--presence-value absent)))))
(ert-deftest tp-core-test-canonical-request-match-and-result-adapters ()
"Canonical records preserve policy and adapt only at public boundaries."
(let* ((str (copy-sequence "abcd"))
(range (tp--native-range-from-object str 1 3))
(request (tp--make-request
:operation :set :range range :props '(face bold)
:mutation :copy :read-only :respect
:noerror nil :public-return :range))
(match (tp--make-match range 'face 'bold))
(result (tp--make-result
:request request :matches (list match)
:count 1 :object str :native 'native-value)))
(should (tp--request-p request))
(should (eq (tp--request-operation request) :set))
(should (eq (tp--request-mutation request) :copy))
(should (equal (tp--match-to-list match) '(1 3 bold)))
(let ((native-match (tp--match-to-prop-match match)))
(should (= (prop-match-beginning native-match) 1))
(should (= (prop-match-end native-match) 3))
(should (eq (prop-match-value native-match) 'bold)))
(should (equal (tp--result-public-value result) '(1 . 3)))
(setf (tp--request-public-return request) :matches)
(should (equal (tp--result-public-value result) '((1 3 bold))))
(setf (tp--request-public-return request) :count)
(should (= (tp--result-public-value result) 1))
(setf (tp--request-public-return request) :native)
(should (eq (tp--result-public-value result) 'native-value))))
;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map
(ert-deftest tp-core-test-intervals-buffer-relative-default ()

112
tp-core.el
View File

@ -23,6 +23,7 @@
(require 'cl-lib)
(require 'dash)
(require 'seq)
(require 'text-property-search)
(defgroup tp nil
"Group for tp.el text property manipulation."
@ -114,6 +115,84 @@ FORMAT-STRING and ARGS are passed to `format'."
(let ((inhibit-read-only t))
,@body)))
(cl-defstruct (tp--native-range
(:constructor tp--make-native-range
(object kind start end)))
object kind start end)
(cl-defstruct (tp--presence
(:constructor tp--make-presence (present-p value)))
present-p value)
(cl-defstruct (tp--request
(:constructor tp--make-request
(&key operation range props property value
predicate mutation read-only noerror
public-return)))
operation range props property value predicate mutation read-only
noerror public-return)
(cl-defstruct (tp--match
(:constructor tp--make-match (range property value)))
range property value)
(cl-defstruct (tp--result
(:constructor tp--make-result
(&key request value matches count object native)))
request value matches count object native)
(defun tp--object-kind (object)
"Return the canonical kind for OBJECT."
(if (stringp object) :string :buffer))
(defun tp--object-bounds (object)
"Return native bounds for OBJECT."
(if (stringp object)
(cons 0 (length object))
(with-current-buffer (or object (current-buffer))
(cons (point-min) (point-max)))))
(defun tp--native-range-from-object (object start end)
"Return a concrete native range for OBJECT from START to END."
(let* ((obj (or object (current-buffer)))
(bounds (tp--object-bounds obj)))
(tp--make-native-range
obj (tp--object-kind obj)
(max (or start (car bounds)) (car bounds))
(min (or end (cdr bounds)) (cdr bounds)))))
(defun tp--presence-at (pos property &optional object)
"Return canonical presence of PROPERTY at POS in OBJECT."
(let ((cell (plist-member (text-properties-at pos object) property)))
(tp--make-presence (and cell t) (cadr cell))))
(defun tp--match-to-list (match)
"Convert MATCH to the historical (START END VALUE) list."
(let ((range (tp--match-range match)))
(list (tp--native-range-start range)
(tp--native-range-end range)
(tp--match-value match))))
(defun tp--match-to-prop-match (match)
"Convert MATCH to an Emacs `prop-match' object."
(let ((range (tp--match-range match)))
(make-prop-match :beginning (tp--native-range-start range)
:end (tp--native-range-end range)
:value (tp--match-value match))))
(defun tp--result-public-value (result)
"Return RESULT using its request's public return convention."
(pcase (tp--request-public-return (tp--result-request result))
(:range
(let ((range (tp--request-range (tp--result-request result))))
(cons (tp--native-range-start range)
(tp--native-range-end range))))
(:matches (mapcar #'tp--match-to-list (tp--result-matches result)))
(:count (tp--result-count result))
(:object (tp--result-object result))
(:native (tp--result-native result))
(_ (tp--result-value result))))
(defun tp-intervals (start end &optional object absolute)
"Return list of property intervals from START to END in OBJECT.
Each element is (START END PROPERTIES). OBJECT defaults to current
@ -323,34 +402,6 @@ Returns the modified face value with the layer's face contribution removed."
;; 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.
@ -361,8 +412,9 @@ 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.
`tp--merge-embedded-props' uses it for each property run of a
propertized replacement string. 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

66
tp-doctest.el
View File

@ -85,7 +85,7 @@
(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)
(tp-search-map #'upcase 'marker tp-any-value my-string)
(substring-no-properties my-string)))
(chk "F-teaser-fullname" '(help-echo "John Doe" face (:foreground "purple") tp-name full-name-layer)
(progn
@ -120,6 +120,40 @@
(tp-set 1 6 '(face bold))
(tp-member 1 'face)))
;; ---- tp-lookup ----
(chk "Q-lookup-direct-nil-absent" '((t nil :text-direct) (nil nil :absent))
(let ((str (copy-sequence "ab")))
(put-text-property 0 1 'state nil str)
(let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct))
(absent-result (tp-lookup 1 'state :object str :mode :text-direct)))
(list (list (tp-lookup-result-present-p nil-result)
(tp-lookup-result-value nil-result)
(tp-lookup-result-source nil-result))
(list (tp-lookup-result-present-p absent-result)
(tp-lookup-result-value absent-result)
(tp-lookup-result-source absent-result))))))
(chk "Q-lookup-source-category" '(category-value :category)
(let* ((str (copy-sequence "a"))
(category (make-symbol "tp-doc-category")))
(put category 'state 'category-value)
(put-text-property 0 1 'category category str)
(let ((result (tp-lookup 0 'state :object str :mode :text-source)))
(list (tp-lookup-result-value result)
(tp-lookup-result-source result)))))
(chk "Q-lookup-char-source-overlay" '(high :overlay t)
(with-temp-buffer
(insert "x")
(let ((low (make-overlay 1 2))
(high (make-overlay 1 2)))
(overlay-put low 'priority 1)
(overlay-put low 'state 'low)
(overlay-put high 'priority 10)
(overlay-put high 'state 'high)
(let ((result (tp-lookup 1 'state :mode :char-source)))
(list (tp-lookup-result-value result)
(tp-lookup-result-source result)
(eq (tp-lookup-result-overlay result) high))))))
;; ---- tp-remove nested ----
(chk "R-remove-nested" '(:color "blue")
(let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue")))))
@ -134,7 +168,7 @@
(goto-char 1)
(let ((match (tp-forward 'marker t)))
(when match (prop-match-beginning match)))))
(chk "N-fwd-nil" '(1 7)
(chk "N-fwd-any" '(7 12)
(with-temp-buffer
(insert "Hello World Test")
(tp-set 7 12 '(marker t))
@ -159,20 +193,20 @@
(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 'marker tp-any-value 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)
(tp-forward-do #'upcase 'marker tp-any-value my-string 2)
(substring-no-properties my-string)))
(chk "DO-bdo" "HELLO world hello"
(let ((my-string (copy-sequence "hello world hello")))
(tp-set 0 5 '(marker t) my-string)
(tp-set 12 17 '(marker t) my-string)
(tp-backward-do #'upcase 'marker nil my-string 2)
(tp-backward-do #'upcase 'marker tp-any-value my-string 2)
(substring-no-properties my-string)))
(chk "DO-fdo-pos" '("hello world HELLO" (12 17))
(let ((my-string (copy-sequence "hello world hello"))
@ -183,7 +217,7 @@
(lambda (text start end)
(setq match-info (list start end))
(upcase text))
'marker nil my-string 2)
'marker tp-any-value my-string 2)
(list (substring-no-properties my-string) match-info)))
(chk "SM-idx" '("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11)))
(let ((my-string (copy-sequence "aaa bbb ccc"))
@ -195,7 +229,7 @@
(lambda (text start end idx)
(push (list idx start end) positions)
(upcase text))
'marker nil my-string)
'marker tp-any-value my-string)
(list (substring-no-properties my-string) (nreverse positions))))
;; ---- Layer definitions ----
@ -355,7 +389,7 @@
(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)
(chk "P-stack" '(:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2)
(progn
(tp-layer-reset)
(define-tp base () '(face default))
@ -368,6 +402,20 @@
:top (tp-layer-top 1 10)
:layers (tp-layer-list 1 10)
:hidden (length (tp-at 1 'tp-layers))))))
(chk "P-transaction-ok" '(ok (1 . 4) bold)
(progn
(tp-layer-reset)
(define-tp tx-base () '(face bold))
(define-tp tx-temp () '(face italic))
(with-temp-buffer
(insert "abcd")
(let ((result
(tp-layer-transaction
1 4 (current-buffer)
(lambda () (tp-put-layer 1 3 'tx-base 0)))))
(list (plist-get result :status)
(plist-get result :range)
(tp-at 1 'face))))))
;; ---- Utilities ----
(chk "U-intervals" '((0 5 (face bold)) (5 6 nil) (6 11 (face italic)))
@ -561,7 +609,7 @@
(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)
(list (tp-forward-do #'upcase 'marker tp-any-value str 3)
(substring-no-properties str))))
;; ---- 0.3.0: search bounds and SUBEXP ----

27
tp-layer-tests.el
View File

@ -428,14 +428,19 @@
(should (equal (get-text-property 0 'help-echo s) "tip")))))
(ert-deftest tp-layer-test-multi-arg-normalize-layer-spec ()
"tp--normalize-layer-spec accepts (LAYER ARG1 ARG2) specs."
"Normalized parameterized specs retain args in managed metadata."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(should (equal (tp--normalize-layer-spec
'(tp-layer-test-fgbg "red" "blue"))
'(face (:foreground "red" :background "blue")
tp-name tp-layer-test-fgbg)))))
(let* ((entry (tp--normalize-layer-spec
'(tp-layer-test-fgbg "red" "blue")))
(meta (plist-get entry 'tp-meta)))
(should (equal (plist-get entry 'face)
'(:foreground "red" :background "blue")))
(should (eq (plist-get entry 'tp-name) 'tp-layer-test-fgbg))
(should (equal (plist-get meta :args) '("red" "blue")))
(should (equal (plist-get meta :arglist) '(fg bg)))
(should (integerp (plist-get meta :definition-version))))))
(ert-deftest tp-layer-test-multi-arg-tp-put-layer ()
"tp-put-layer accepts multi-argument parameterized layer specs."
@ -650,12 +655,16 @@ text property list\"."
(let ((err (should-error
(tp--normalize-layer-spec '(tp-lt-colors "red")))))
(should (string-match-p "expects 2 args, got 1" (cadr err))))
;; Correct arity through the stack path is unchanged.
;; Correct arity through the stack path keeps the rendered facade
;; while authoritative metadata lives in stack storage.
(let ((s (copy-sequence "st")))
(tp-push-layer s '(tp-lt-colors "red" "blue"))
(should (equal (text-properties-at 0 s)
'(face (:foreground "red" :background "blue")
tp-name tp-lt-colors))))))
(should (equal (get-text-property 0 'face s)
'(:foreground "red" :background "blue")))
(should (eq (get-text-property 0 'tp-name s) 'tp-lt-colors))
(let* ((entry (car (get-text-property 0 'tp-layers s)))
(meta (plist-get entry 'tp-meta)))
(should (equal (plist-get meta :args) '("red" "blue")))))))
;;; API-SYM-01: public tp-group-props-with-args mirrors the layer pair

286
tp-layer.el
View File

@ -22,20 +22,59 @@
(require 'tp-core)
(require 'tp-reactive)
(define-error 'tp-unresolved-layer "Unresolved tp layer or group")
(define-error 'tp-layer-conflict "Conflicting edit in a managed tp range")
(defvar tp--layer-refresh-function nil
"Function re-rendering regions that carry a given layer, or nil.
Installed by tp-render.el. Called with (LAYER-NAME) after a layer is
redefined, so text that already uses the layer picks up the new
definition. When nil, redefinition only updates the registry.")
Installed by tp-render.el. Called with
\(LAYER-NAME nil nil OLD-PROPS) after a non-parameterized layer is
redefined, so text that already uses the layer can replace the old
owned properties with the new definition. When nil, redefinition
only updates the registry.")
(defun tp--layer-refresh (layer-name)
(defun tp--layer-refresh (layer-name &optional old-props)
"Re-render regions carrying LAYER-NAME via `tp--layer-refresh-function'."
(when tp--layer-refresh-function
(funcall tp--layer-refresh-function layer-name)))
(funcall tp--layer-refresh-function layer-name nil nil old-props)))
(defvar tp-layer-alist nil
"Alist of layer definitions: (LAYER-NAME . PROPERTIES).")
(defvar tp--layer-definition-counter 0
"Monotonic counter used for layer definition versions.")
(defvar tp--layer-definition-versions nil
"Alist of layer definition versions: (LAYER-NAME . VERSION).")
(defvar tp--managed-entry-counter 0
"Monotonic counter used for managed stack entry ids.")
(defun tp--layer-definition-version (layer-name)
"Return LAYER-NAME's current definition version, or 0."
(or (cdr (assq layer-name tp--layer-definition-versions)) 0))
(defun tp--bump-layer-definition-version (layer-name)
"Increment and return LAYER-NAME's definition version."
(setq tp--layer-definition-counter (1+ tp--layer-definition-counter))
(setf (alist-get layer-name tp--layer-definition-versions)
tp--layer-definition-counter)
tp--layer-definition-counter)
(defun tp--store-layer-entry (layer-name entry &optional bump-version)
"Store LAYER-NAME registry ENTRY, optionally bumping its version."
(if (assoc layer-name tp-layer-alist)
(setf (cdr (assoc layer-name tp-layer-alist)) entry)
(push (cons layer-name entry) tp-layer-alist))
(when bump-version
(tp--bump-layer-definition-version layer-name))
(assoc layer-name tp-layer-alist))
(defun tp--next-managed-entry-id ()
"Return a fresh managed entry id symbol."
(setq tp--managed-entry-counter (1+ tp--managed-entry-counter))
(intern (format "tp-entry-%d" tp--managed-entry-counter)))
(defvar tp-layer-groups nil
"Alist of layer groups: (GROUP-NAME . (LAYER-NAME1 LAYER-NAME2 ...)).")
@ -248,7 +287,9 @@ the text properties explicitly.
If a layer with the same NAME already exists, it will be overwritten.
The layer is stored in `tp-layer-alist'."
(declare (indent defun))
(let* ((parsed (tp--parse-define-layer-args args))
(let* ((old-props (when (assoc name tp-layer-alist)
(tp-layer-props name t)))
(parsed (tp--parse-define-layer-args args))
(properties (plist-get parsed :props))
(data (plist-get parsed :data))
(watch (plist-get parsed :watch))
@ -299,17 +340,19 @@ The layer is stored in `tp-layer-alist'."
;; Set layer properties with resolved values
(let ((resolved-props (tp--resolve-reactive-symbols properties)))
(tp--set-layer-props name resolved-props))
(tp--bump-layer-definition-version name)
;; Update any text regions that already have this layer applied
;; This ensures re-definition immediately updates applied text
(tp--layer-refresh name)
(tp--layer-refresh name old-props)
(assoc name tp-layer-alist))
;; No reactive symbols - use static properties
(progn
;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
(tp--unregister-reactive-deps name)
(tp--set-layer-props name properties)
(tp--bump-layer-definition-version name)
;; Update any text regions that already have this layer applied
(tp--layer-refresh name)
(tp--layer-refresh name old-props)
(assoc name tp-layer-alist)))))
;;;###autoload
@ -340,7 +383,11 @@ Format 3 - Non-parameterized with reactive features
Usage:
(tp-set \"emacs\" \\='tp-bold t)
(tp-set 0 5 \\='(tp-bold t) \"emacs\")
;; => #(\"emacs\" 0 5 (tp-name tp-bold face bold))
;; => #(\"emacs\" 0 5 (face bold))
Direct `tp-set' use expands a non-reactive layer as a property
template and does not retain `tp-name'. Use `tp-push-layer' or
`tp-put-layer' when the text must retain managed layer identity.
ARGLIST must be either:
- An empty list () for non-parameterized layers
@ -420,12 +467,13 @@ delegates to `tp--define-layer-internal' for proper reactive handling."
(if arglist
;; Parameterized - store for later evaluation
(let ((entry (list arglist body)))
(if (assoc name tp-layer-alist)
(setf (cdr (assoc name tp-layer-alist)) entry)
(push (cons name entry) tp-layer-alist))
(tp--store-layer-entry name entry t)
(tp--layer-refresh name nil)
(assoc name tp-layer-alist))
;; Non-parameterized - check for reactive symbols
(let ((reactive-syms (tp--collect-reactive-symbols body)))
(let ((reactive-syms (tp--collect-reactive-symbols body))
(old-props (when (assoc name tp-layer-alist)
(tp-layer-props name t))))
(if reactive-syms
;; Has reactive symbols - use tp--define-layer-internal for proper handling
(tp--define-layer-internal name body)
@ -433,9 +481,8 @@ delegates to `tp--define-layer-internal' for proper reactive handling."
;; Clean up old reactive dependencies if the layer was previously reactive
(tp--unregister-reactive-deps name)
(let ((entry (list nil `',body)))
(if (assoc name tp-layer-alist)
(setf (cdr (assoc name tp-layer-alist)) entry)
(push (cons name entry) tp-layer-alist))
(tp--store-layer-entry name entry t)
(tp--layer-refresh name old-props)
(assoc name tp-layer-alist))))))
(defun tp--layer-group-element-format (element)
@ -539,42 +586,42 @@ COMPUTE is the list of computed variable definitions.
TRANSFORM, if non-nil, is registered in `tp-layer-transforms';
when nil, any previously registered transform for LAYER-NAME is
removed (mirroring `tp--define-layer-internal')."
;; Register or unregister transform function
(if transform
(if (assoc layer-name tp-layer-transforms)
(setcdr (assoc layer-name tp-layer-transforms) transform)
(push (cons layer-name transform) tp-layer-transforms))
(setq tp-layer-transforms (assq-delete-all layer-name tp-layer-transforms)))
(let* ((reactive-syms (tp--collect-reactive-symbols props))
(computed-vars (when compute (mapcar #'car compute)))
(all-reactive-syms (delete-dups reactive-syms))
(props-vars (mapcar #'tp--reactive-var-symbol reactive-syms))
(all-vars-to-define (delete-dups
(append data
props-vars
computed-vars))))
(if (or all-reactive-syms data compute)
;; Has reactive features - register dependencies and resolve at runtime
(progn
(tp--unregister-reactive-deps layer-name)
(tp--ensure-reactive-variables all-vars-to-define)
(when data
(tp--register-layer-data layer-name data))
(when compute
(tp--register-layer-computed layer-name compute)
(tp--apply-initial-computed compute))
(tp--register-reactive-deps layer-name all-reactive-syms props)
(when watch
(tp--register-layer-watchers layer-name watch))
(let ((resolved-props (tp--resolve-reactive-symbols props)))
(tp--set-layer-props layer-name resolved-props))
(tp--layer-refresh layer-name))
;; No reactive symbols - use static properties
(progn
(let ((old-props (when (assoc layer-name tp-layer-alist)
(tp-layer-props layer-name t))))
;; Register or unregister transform function
(if transform
(if (assoc layer-name tp-layer-transforms)
(setcdr (assoc layer-name tp-layer-transforms) transform)
(push (cons layer-name transform) tp-layer-transforms))
(setq tp-layer-transforms
(assq-delete-all layer-name tp-layer-transforms)))
(let* ((reactive-syms (tp--collect-reactive-symbols props))
(computed-vars (when compute (mapcar #'car compute)))
(all-reactive-syms (delete-dups reactive-syms))
(props-vars (mapcar #'tp--reactive-var-symbol reactive-syms))
(all-vars-to-define
(delete-dups (append data props-vars computed-vars))))
(if (or all-reactive-syms data compute)
(progn
(tp--unregister-reactive-deps layer-name)
(tp--ensure-reactive-variables all-vars-to-define)
(when data
(tp--register-layer-data layer-name data))
(when compute
(tp--register-layer-computed layer-name compute)
(tp--apply-initial-computed compute))
(tp--register-reactive-deps layer-name all-reactive-syms props)
(when watch
(tp--register-layer-watchers layer-name watch))
(tp--set-layer-props
layer-name (tp--resolve-reactive-symbols props))
(tp--bump-layer-definition-version layer-name)
(tp--layer-refresh layer-name old-props))
(tp--unregister-reactive-deps layer-name)
(tp--set-layer-props layer-name props)
(tp--layer-refresh layer-name)))
layer-name))
(tp--bump-layer-definition-version layer-name)
(tp--layer-refresh layer-name old-props))
layer-name)))
(defun tp--define-layer-internal-group (name &rest elements)
"Define a layer group named NAME containing multiple layers.
@ -758,9 +805,7 @@ Stores as (LAYER-NAME . PROPERTIES) for backward compatibility with
reactive layers.
This is an internal function used by layer definition macros and
reactive updates."
(if (assoc layer-name tp-layer-alist)
(setf (cdr (assoc layer-name tp-layer-alist)) properties)
(push (cons layer-name properties) tp-layer-alist)))
(tp--store-layer-entry layer-name properties))
(defun tp--set-group-layers (group-name layer-names)
"Set LAYER-NAMES for group GROUP-NAME in `tp-layer-groups'.
@ -1177,7 +1222,8 @@ PROPS can be:
- A plist (handles anonymous layers with reactive variables)
If PROPS is a symbol:
- First checks `tp-layer-alist' and returns the layer properties WITH `tp-name'
- First checks `tp-layer-alist' and expands the layer properties
WITHOUT `tp-name' for direct property setting
- Then checks `tp-layer-groups' and returns properties WITH `tp-layers'
If PROPS is (LAYER-NAME ARG) or (LAYER-NAME ARG EXTRA-PROPS...):
@ -1201,8 +1247,10 @@ If PROPS is a plist:
Returns nil if PROPS is a symbol but no matching layer/group is found.
For layer names, includes `tp-name' property for reactive text property support.
For group names, includes `tp-layers' property with the full layer stack."
Reactive anonymous properties retain `tp-name' so they can be
updated. Plain layer names used through direct property APIs do not;
use stack APIs for a managed mount. Group names include `tp-layers'
with the full layer stack."
(cond
;; Already a plist - check for reactive variables and add tp-name
((listp props)
@ -1389,6 +1437,9 @@ Also resets all reactive text property watchers, dependencies, and transforms."
(tp-reactive-reset)
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(setq tp--layer-definition-counter 0)
(setq tp--layer-definition-versions nil)
(setq tp--managed-entry-counter 0)
(setq tp-layer-transforms nil)
(setq tp--group-generated-layers nil)
(setq tp--anonymous-layer-registry nil))
@ -1399,6 +1450,8 @@ Also unregisters any reactive dependencies and transforms for this layer,
and drops any anonymous-layer registry entries interned for it."
(tp--unregister-reactive-deps name)
(setq tp-layer-alist (assq-delete-all name tp-layer-alist))
(setq tp--layer-definition-versions
(assq-delete-all name tp--layer-definition-versions))
(setq tp-layer-transforms (assq-delete-all name tp-layer-transforms))
(setq tp--anonymous-layer-registry
(cl-remove-if (lambda (cell) (eq (cdr cell) name))
@ -1416,6 +1469,42 @@ untouched."
(assq-delete-all name tp--group-generated-layers))
(setq tp-layer-groups (assq-delete-all name tp-layer-groups)))
(defun tp--managed-entry-meta (name origin spec args arglist)
"Build managed metadata for NAME with ORIGIN, SPEC, ARGS and ARGLIST."
(list :schema 1
:entry-id (tp--next-managed-entry-id)
:origin origin
:spec (copy-tree spec)
:args (copy-tree args)
:arglist (copy-tree arglist)
:definition-version (tp--layer-definition-version name)
:entry-version 1
:mode 'exclusive
:palette-deps nil
:palette-generation (if (boundp 'tp-theme-generation)
tp-theme-generation 0)
:legacy-no-args nil))
(defun tp--stamp-managed-entry (props name spec args arglist origin)
"Return PROPS stamped with managed metadata for NAME."
(plist-put (copy-tree props)
'tp-meta
(tp--managed-entry-meta name origin spec args arglist)))
(defun tp--entry-render-projection (props)
"Return rendered PROPS without stack-only bookkeeping."
(let ((result (copy-sequence props)))
(dolist (key '(tp-meta tp-hidden tp-layers))
(cl-remf result key))
result))
(defun tp--entry-authoritative-storage-p (layer-list)
"Return non-nil when LAYER-LIST requires `tp-layers' authority."
(seq-some (lambda (layer)
(or (tp--stack-hidden-p layer)
(plist-member layer 'tp-meta)))
layer-list))
(defun tp--normalize-layer-spec (layer-spec)
"Normalize LAYER-SPEC to a plist with tp-name.
Used by layer stack functions that need tp-name for identification.
@ -1438,9 +1527,11 @@ LAYER-SPEC can be:
layer-spec layer-spec))
;; Non-parameterized layer or old-format layer
((assoc layer-spec tp-layer-alist)
(or (tp-layer-props layer-spec t) ; include tp-name for layer stack
(error "Layer %S not found in tp-layer-alist" layer-spec)))
(t (error "Layer %S not found in tp-layer-alist" layer-spec))))
(tp--stamp-managed-entry
(or (tp-layer-props layer-spec t)
(error "Layer %S not found in tp-layer-alist" layer-spec))
layer-spec layer-spec nil nil 'defined))
(t (signal 'tp-unresolved-layer (list layer-spec)))))
;; List starting with symbol - check if it's a parameterized layer
((and (listp layer-spec)
@ -1453,9 +1544,11 @@ LAYER-SPEC can be:
;; many arguments as the layer has parameters
((and (tp-layer-parameterized-p name)
(= (length rest) (length (tp-layer-arglist name))))
(or (tp-layer-props-with-args name rest t) ; include tp-name
(error "Failed to resolve parameterized layer %S with args %S"
name rest)))
(tp--stamp-managed-entry
(or (tp-layer-props-with-args name rest t)
(error "Failed to resolve parameterized layer %S with args %S"
name rest))
name layer-spec rest (tp-layer-arglist name) 'parameterized))
;; ARG-1: a parameterized layer with the wrong number of
;; arguments must not fall through to the named-inline branch,
;; which would build an odd-length plist and die with the
@ -1465,11 +1558,15 @@ LAYER-SPEC can be:
name (length (tp-layer-arglist name)) (length rest)))
;; Named inline layer: (NAME &rest PLIST)
(rest
(append rest (list 'tp-name name)))
(tp--stamp-managed-entry
(append rest (list 'tp-name name))
name layer-spec nil nil 'inline))
;; Just a symbol in a list - treat as non-parameterized layer
((null rest)
(or (tp-layer-props name t)
(error "Layer %S not found in tp-layer-alist" name))))))
(tp--stamp-managed-entry
(or (tp-layer-props name t)
(signal 'tp-unresolved-layer (list name)))
name layer-spec nil nil 'defined)))))
;; Plist (starts with keyword or property name)
((and (listp layer-spec) layer-spec)
@ -1516,6 +1613,29 @@ A layer is hidden when its plist carries a non-nil `tp-hidden' entry;
see `tp-hide-layer'."
(and (plist-get layer 'tp-hidden) t))
(defun tp--plist-equivalent-p (left right)
"Return non-nil when LEFT and RIGHT contain the same plist entries."
(let ((left-proj (tp--entry-render-projection left))
(right-proj (tp--entry-render-projection right)))
(and (cl-loop for (key val) on left-proj by #'cddr
always (and (plist-member right-proj key)
(equal (plist-get right-proj key) val)))
(cl-loop for (key val) on right-proj by #'cddr
always (and (plist-member left-proj key)
(equal (plist-get left-proj key) val))))))
(defun tp--assert-hidden-render-cache (direct stack)
"Signal `tp-layer-conflict' unless DIRECT matches rendered STACK."
(let ((expected (seq-find (lambda (layer)
(not (tp--stack-hidden-p layer)))
stack)))
(unless (tp--plist-equivalent-p direct
(tp--entry-render-projection expected))
(signal 'tp-layer-conflict
(list "Direct properties changed while a layer was hidden"
:actual direct
:expected (tp--entry-render-projection expected))))))
(defun tp--stack-props-to-list (props)
"Return the ordered layer stack stored in raw text properties PROPS.
The result is a list of layer plists, top layer first, including
@ -1526,17 +1646,20 @@ This is the inverse of `tp--stack-build-props': when any entry of the
`tp-layers' bookkeeping property is hidden, that property holds the
whole ordered stack and the direct properties are only a render cache
of the topmost non-hidden layer; otherwise the direct properties are
the top layer and `tp-layers' holds the layers below it. Direct
property edits made outside the stack API (for example `tp-set') are
therefore discarded by the next stack operation while any layer is
hidden."
the top layer and `tp-layers' holds the layers below it.
When full-stack storage is active, an external direct-property edit
cannot be assigned to a managed layer safely. Rather than discard it,
signal `tp-layer-conflict' before decoding or rebuilding the stack."
(let* ((idx (-elem-index 'tp-layers props))
(top (if idx
(-remove-at-indices (list idx (1+ idx)) props)
props))
(belows (plist-get props 'tp-layers)))
(if (seq-some #'tp--stack-hidden-p belows)
belows
(if (tp--entry-authoritative-storage-p belows)
(progn
(tp--assert-hidden-render-cache top belows)
belows)
(tp--layer-stack-to-list top belows))))
(defun tp--stack-build-props (layer-list)
@ -1547,18 +1670,19 @@ garbage (tp-layers nil) property. Consumers must therefore tolerate
an absent `tp-layers' property (both `plist-get' and
`tp--stack-map-region' do).
When any layer in LAYER-LIST is hidden (non-nil `tp-hidden' entry,
see `tp-hide-layer'), the storage switches to full-stack mode: the
direct properties are those of the topmost non-hidden layer (or no
layer properties at all when every layer is hidden) and the
`tp-layers' property holds the complete ordered LAYER-LIST.
`tp--stack-props-to-list' reverses either representation."
When any layer in LAYER-LIST is hidden or carries `tp-meta', the
storage switches to full-stack mode: the direct properties are the
render projection of the topmost non-hidden layer (or no layer
properties at all when every layer is hidden) and the `tp-layers'
property holds the complete ordered LAYER-LIST. `tp--stack-props-to-list'
reverses either representation."
(cond
((null layer-list) nil)
((seq-some #'tp--stack-hidden-p layer-list)
(append (seq-find (lambda (layer)
(not (tp--stack-hidden-p layer)))
layer-list)
((tp--entry-authoritative-storage-p layer-list)
(append (tp--entry-render-projection
(seq-find (lambda (layer)
(not (tp--stack-hidden-p layer)))
layer-list))
(list 'tp-layers layer-list)))
((null (cdr layer-list)) (copy-sequence (car layer-list)))
(t (append (car layer-list)

303
tp-managed-tests.el Normal file
View File

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

210
tp-native-tests.el Normal file
View File

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

49
tp-ops-tests.el
View File

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

452
tp-ops.el
View File

@ -48,35 +48,34 @@ Searches through `tp-reactive-deps' to find the original reactive props."
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."
"Return TEXT transformed by LAYER-NAME's `:transform'.
Signal when the transform fails or returns a non-string value."
(let ((transform-fn (when layer-name
(cdr (assoc layer-name tp-layer-transforms)))))
(if (not transform-fn)
text
(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)))))
(let ((result (funcall transform-fn text)))
(unless (stringp result)
(error "tp: transform for %s returned non-string %S"
layer-name result))
(tp-debug-log " Transform %s: %S -> %S" layer-name text result)
result))))
(defun tp--merge-embedded-props (embedded props)
"Merge the EMBEDDED string props plist under PROPS; PROPS win.
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
Takes one property run's EMBEDDED plist, so callers preserve every
interval instead of treating position 0 as representative.
Face-family values (see
`tp-face-properties') are merged with PROPS taking precedence; other
conflicting keys keep the PROPS value; keys only in EMBEDDED are
added."
(let ((result (copy-sequence props)))
(cl-loop for (key val) on embedded by #'cddr
do (let ((existing (plist-get result key)))
do (let ((present (plist-member result key))
(existing (plist-get result key)))
(setq result
(plist-put result key
(if existing
(if present
(if (memq key tp-face-properties)
(tp--merge-face-values val existing)
existing)
@ -90,13 +89,54 @@ holds a value `equal' to VAL for KEY the call is skipped, so an
update that changes nothing does not flip the buffer-modified flag.
OBJECT is a string, a buffer, or nil for the current buffer."
(when (< start end)
(unless (and (equal (get-text-property start key object) val)
(unless (and (plist-member (text-properties-at start object) key)
(equal (get-text-property start key object) val)
(>= (or (next-single-property-change start key object end)
end)
end))
(put-text-property start end key val object))))
(defun tp--apply-reactive-text-props (source props offset &optional target)
(defun tp--value-after-add (key existing incoming)
"Return EXISTING after adding INCOMING for property KEY."
(cond
((memq key tp-face-properties)
(tp--prepend-face incoming existing))
((and (listp incoming) (keywordp (car-safe incoming))
(listp existing) (keywordp (car-safe existing)))
(tp--deep-merge-plist existing incoming))
(t incoming)))
(defun tp--props-after-add (existing incoming)
"Return EXISTING with INCOMING applied using `tp-add' semantics."
(let ((result (copy-sequence existing)))
(cl-loop
for (key val) on incoming by #'cddr
do (setq result
(plist-put
result key
(tp--value-after-add key (plist-get result key) val))))
result))
(defun tp--apply-props-by-operation (start end props target operation)
"Apply PROPS to TARGET from START to END according to OPERATION."
(let ((pos start))
(while (< pos end)
(let* ((next (or (next-property-change pos target end) end))
(existing (text-properties-at pos target)))
(pcase operation
(:reset
(set-text-properties pos next props target))
(:add
(set-text-properties
pos next (tp--props-after-add existing props) target))
(_
(cl-loop for (key val) on props by #'cddr
do (tp--put-text-property-unless-equal
pos next key val target))))
(setq pos next)))))
(defun tp--apply-reactive-text-props
(source props offset &optional target operation)
"Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET.
SOURCE is the (possibly propertized) replacement string; TARGET is a
string, or nil for the current buffer. For every embedded-property
@ -104,37 +144,40 @@ interval of SOURCE the interval's props are merged under PROPS (see
`tp--merge-embedded-props') and the result is applied to the
corresponding span of TARGET shifted by OFFSET. This keeps
per-interval styling of propertized reactive strings intact instead
of smearing position-0 props across the whole region. Spans that
already carry an `equal' value are left untouched, so an update that
changes nothing does not mark the buffer as modified."
of smearing position-0 props across the whole region.
OPERATION is `:reset', `:add', or nil for ordinary set semantics.
Ordinary set spans that already carry an `equal' value are left
untouched, so an update that changes nothing does not mark the buffer
as modified."
(tp--map-intervals
source nil nil
(lambda (istart iend str-props)
(let ((merged (if str-props
(tp--merge-embedded-props str-props props)
props)))
(cl-loop for (key val) on merged by #'cddr
do (tp--put-text-property-unless-equal
(+ offset istart) (+ offset iend) key val target))))))
(tp--apply-props-by-operation
(+ offset istart) (+ offset iend) merged target operation)))))
(defun tp--tp-text-replace (start end final-text result-props object preserve-props)
(defun tp--tp-text-replace
(start end final-text props object preserve-props operation)
"Replace [START, END) of OBJECT with FINAL-TEXT, handling props.
Implements the text replacement of `tp--handle-tp-text-property' and
returns its (PROPS NEW-END NEW-OBJECT) result.
returns its (PROPS NEW-END NEW-OBJECT PROPS-APPLIED) result.
For a string OBJECT a NEW string is built as prefix + FINAL-TEXT +
suffix, so text outside the region survives. 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.
suffix, so text outside the region survives. For strings and buffers,
PROPS are merged under every embedded property interval of FINAL-TEXT
and applied here through `tp--apply-reactive-text-props'. The final
non-nil return element tells callers not to flatten PROPS over the
whole replacement afterward.
For buffers the region text is replaced in place and the returned
NEW-END is the end of the inserted text; the caller applies
RESULT-PROPS itself.
For buffers the region text is replaced in place and NEW-END is the
end of the inserted text.
When PRESERVE-PROPS is non-nil, properties present at START whose
keys RESULT-PROPS does not set are re-applied over the replacement."
keys PROPS does not set are re-applied over the replacement.
OPERATION selects ordinary set, `:reset', or `:add' semantics."
(if (stringp object)
(let* ((plain (substring-no-properties final-text))
;; Splice: keep the string outside [start, end) intact.
@ -146,17 +189,21 @@ keys RESULT-PROPS does not set are re-applied over the replacement."
(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)))
when (or (eq operation :add)
(not (plist-member props key)))
do (put-text-property start new-end key val new-string))
;; Apply the merged props per embedded interval of FINAL-TEXT
(tp--apply-reactive-text-props final-text result-props start new-string)
(list result-props 0 new-string))
(tp--apply-reactive-text-props
final-text props start new-string operation)
(list props new-end new-string t))
;; Buffer object
(with-current-buffer (or object (current-buffer))
(let ((old-text (buffer-substring-no-properties start end)))
(if (equal old-text (substring-no-properties final-text))
;; Same text content, no replacement needed
(list result-props end object)
(progn
(tp--apply-reactive-text-props
final-text props start object operation)
(list props end object t))
;; Need to replace text
(let ((existing-props (when preserve-props
(text-properties-at start)))
@ -169,9 +216,12 @@ keys RESULT-PROPS does not set are re-applied over the replacement."
(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))))))))
when (or (eq operation :add)
(not (plist-member props key)))
do (put-text-property start new-end key val object))
(tp--apply-reactive-text-props
final-text props start object operation)
(list props new-end object t))))))))
(defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode)
"Handle tp-text property in PROPS for region from START to END in OBJECT.
@ -182,19 +232,22 @@ 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.
MERGE-MODE selects `:reset', `:merge' (`tp-add'), or ordinary
`tp-set' behavior.
All modes now preserve embedded text properties from tp-text, with props taking
precedence over embedded props when there's a conflict.
Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props,
NEW-END is the new end position after any text replacement, and
Returns (PROPS NEW-END NEW-OBJECT PROPS-APPLIED), where PROPS is the
updated props, NEW-END is the new end position after replacement, and
NEW-OBJECT is the new string object (only different for strings whose
text was replaced; 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))
text was replaced). PROPS-APPLIED is non-nil when replacement props
were already applied per embedded interval."
(let ((operation (pcase merge-mode
(:reset :reset)
(:merge :add)
(_ nil))))
(if (not (plist-member props 'tp-text))
;; tp-text not in props - return unchanged
(list props end object)
(list props end object nil)
(let ((tp-text-val (plist-get props 'tp-text))
(layer-name (plist-get props 'tp-name)))
(cond
@ -224,29 +277,21 @@ convention of a 0 NEW-END with pre-applied properties)."
;; 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--tp-text-replace
start end display-text props object preserve-props
operation))))
;; tp-text has a string value - replace the text in the region
((stringp tp-text-val)
;; Apply transform if layer has one registered
(let* ((final-text (tp--tp-text-transform layer-name tp-text-val))
;; 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)))
(let ((final-text (tp--tp-text-transform layer-name tp-text-val)))
(tp--tp-text-replace start end final-text props
object preserve-props operation)))
;; Other types - return unchanged
(t (list props end object))))))
(t (list props end object nil)))))))
(defun tp--parse-args (start-or-string end-or-prop props-or-val rest)
"Parse flexible function arguments and return (OBJECT START END PROPS).
(defun tp--parse-args (start-or-string end-or-prop props-or-val rest
&optional operation)
"Parse flexible function arguments and return a canonical request.
Supports multiple calling conventions:
1. Buffer region: (START END PROPS)
2. Buffer region with object: (START END PROPS OBJECT)
@ -314,7 +359,18 @@ Supports multiple calling conventions:
;; 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)))
(let ((range (tp--native-range-from-object object start finish)))
(tp--make-request
:operation operation
:range range
:props props
:mutation (if (and (stringp start-or-string)
(stringp (tp--native-range-object range)))
:copy
:in-place)
:public-return (if (stringp (tp--native-range-object range))
:object
:range)))))
(defun tp--ops-register-layer-buffer (props object)
"Record OBJECT in the reactive buffer registry for PROPS's layer.
@ -407,37 +463,49 @@ For tp-text, props override embedded text properties.
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)))
(let* ((request (tp--parse-args start-or-string end-or-prop
props-or-val rest :set))
(range (tp--request-range request))
(object (tp--native-range-object range))
(start (tp--native-range-start range))
(finish (tp--native-range-end range))
(props (tp--request-props request)))
;; Handle tp-text property specially - :override means props override embedded props
(pcase-let ((`(,new-props ,new-finish ,new-object)
(pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied)
(tp--handle-tp-text-property start finish props object t :override)))
(setq props new-props finish new-finish object new-object)
(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))))
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(cond
(props-applied
(if (stringp object)
object
(tp--ops-register-layer-buffer props object)
(cons start finish)))
;; Entire string form: create a new propertized string (non-destructive)
((and (stringp object) entire-string-form)
(tp--apply-props-to-string object start finish props nil))
;; Region form with string object: modify in-place
((stringp object)
(let ((has-existing-props (text-properties-at start object)))
(if (and (not has-existing-props)
(= start (or (next-single-property-change
start nil object finish)
finish)))
(set-text-properties start finish props object)
(cl-loop for (key val) on props by #'cddr
do (put-text-property start finish key val object))))
object)
;; Buffer: modify in place
(t
(let ((has-existing-props (text-properties-at start object)))
(if (and (not has-existing-props)
(= start (or (next-single-property-change
start nil object finish)
finish)))
(set-text-properties start finish props object)
(cl-loop for (key val) on props by #'cddr
do (put-text-property start finish key val object))))
(tp--ops-register-layer-buffer props object)
(cons start finish)))))))
(defun tp-reset (start-or-string &optional end-or-prop props-or-val &rest rest)
"Completely replace all text properties with PROPS.
@ -465,27 +533,35 @@ if there's a conflict).
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)))
(let* ((request (tp--parse-args start-or-string end-or-prop
props-or-val rest :reset))
(range (tp--request-range request))
(object (tp--native-range-object range))
(start (tp--native-range-start range))
(finish (tp--native-range-end range))
(props (tp--request-props request)))
;; Handle tp-text property - :reset means only use props, ignore embedded props
(pcase-let ((`(,new-props ,new-finish ,new-object)
(pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied)
(tp--handle-tp-text-property start finish props object nil :reset)))
(setq props new-props finish new-finish object new-object)
(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)
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(cond
(props-applied
(if (stringp object)
object
(tp--ops-register-layer-buffer props object)
(cons start finish)))
;; Entire string form: create a new propertized string (non-destructive)
((and (stringp object) entire-string-form)
(tp--apply-props-to-string object start finish props :reset))
;; Region form with string object: modify in-place
((stringp object)
(set-text-properties start finish props object)
object)
;; Buffer: modify in place
(t
(set-text-properties start finish props object)
(tp--ops-register-layer-buffer props object)
(cons start finish)))))))
(defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest)
"Add or update text properties with deep merging.
@ -515,67 +591,64 @@ For tp-text, embedded text properties are merged with props.
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)))
(let* ((request (tp--parse-args start-or-string end-or-prop
props-or-val rest :add))
(range (tp--request-range request))
(object (tp--native-range-object range))
(start (tp--native-range-start range))
(finish (tp--native-range-end range))
(props (tp--request-props request)))
;; Handle tp-text property - :merge means embedded props are merged with props
(let ((has-tp-text (plist-member props 'tp-text)))
(pcase-let ((`(,new-props ,new-finish ,new-object)
(pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied)
(tp--handle-tp-text-property start finish props object t :merge)))
(setq props new-props finish new-finish object new-object)
(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))))
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(cond
(props-applied
(if (stringp object)
object
(tp--ops-register-layer-buffer props object)
(cons start finish)))
;; Entire string form: create a new propertized string (non-destructive)
((and (stringp object) entire-string-form)
(if has-tp-text
(tp--apply-props-to-string object start finish props :reset)
(tp--apply-props-to-string object start finish props :add)))
;; Region form with string object: modify in-place with deep merging
((stringp object)
(let ((pos start))
(while (< pos finish)
(let* ((current-props (text-properties-at pos object))
(next-pos (or (next-property-change
pos object finish)
finish)))
(cl-loop
for (key val) on props by #'cddr
do (put-text-property
pos next-pos key
(tp--value-after-add
key (plist-get current-props key) val)
object))
(setq pos next-pos))))
object)
;; Buffer: modify in place with deep merging
(t
(let ((pos start))
(while (< pos finish)
(let* ((current-props (text-properties-at pos object))
(next-pos (or (next-property-change
pos object finish)
finish)))
(cl-loop
for (key val) on props by #'cddr
do (put-text-property
pos next-pos key
(tp--value-after-add
key (plist-get current-props key) val)
object))
(setq pos next-pos))))
(tp--ops-register-layer-buffer props object)
(cons start finish))))))))
(defun tp-get (start-or-string &optional end-or-property &rest args)
"Get text property value(s) with support for nested sub-properties.
@ -801,21 +874,18 @@ Examples:
(when-let ((cell (plist-member plist property)))
(list (car cell) (cadr cell)))))
(defun tp--value-after-sub-removal (value sub-property)
"Return VALUE after removing SUB-PROPERTY, or nil when empty."
(tp--remove-sub-from-face-value value sub-property))
(defun tp--remove-sub (start end property sub-property &optional object)
"Remove SUB-PROPERTY from PROPERTY between START and END in OBJECT."
(let* ((pos start))
(while (< pos end)
(let* ((current-value (get-text-property pos property object))
(next-pos (or (next-single-property-change pos property object end) end))
(new-value
(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))))
(new-value (tp--value-after-sub-removal
current-value sub-property)))
(if new-value
(put-text-property pos next-pos property new-value object)
(remove-text-properties pos next-pos (list property nil) object))
@ -1058,15 +1128,17 @@ remaining properties."
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)))
(new-value (tp--value-after-sub-removal prop-value sub-key))
(final-props (let ((res nil))
(cl-loop for (key val) on existing-props by #'cddr
do (setq res (plist-put res key
(if (eq key property)
new-value
val))))
unless (and (eq key property)
(null new-value))
do (setq res
(plist-put
res key
(if (eq key property)
new-value
val))))
res)))
(set-text-properties istart iend final-props result))))
result))

40
tp-palette.el
View File

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

179
tp-query.el Normal file
View File

@ -0,0 +1,179 @@
;;; tp-query.el --- Native query and policy helpers for tp -*- lexical-binding: t -*-
;; Copyright (C) 2024-2026 Geekinney
;; Author: Geekinney (kinneyzhang666@gmail.com)
;;; Commentary:
;; Explicit native text-property query boundaries and mutation policy.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(cl-defstruct (tp-lookup-result
(:constructor tp--make-lookup-result
(&key property value present-p source mode
object position overlay)))
"Normalized text or character property lookup result.
PRESENT-P distinguishes an explicit nil value from absence. SOURCE
identifies the winning text source or `:overlay'; OVERLAY is non-nil
only when that overlay supplied the winning character-property value."
property value present-p source mode object position overlay)
(defun tp--lookup-direct (position property object mode)
"Return direct text lookup result at POSITION for PROPERTY in OBJECT."
(let* ((obj (or object (current-buffer)))
(cell (plist-member (text-properties-at position object) property)))
(tp--make-lookup-result
:property property :value (cadr cell) :present-p (and cell t)
:source (if cell :text-direct :absent) :mode mode
:object obj :position position)))
(defun tp--lookup-effective (position property object mode)
"Return effective text lookup result at POSITION for PROPERTY in OBJECT."
(let* ((value (get-text-property position property object))
(source-cell (tp--lookup-source-cell position property object))
(present-p (nth 2 source-cell)))
(tp--make-lookup-result
:property property :value value :present-p present-p
:source (if present-p (car source-cell) :absent) :mode mode
:object (or object (current-buffer)) :position position)))
(defun tp--lookup-char (position property object mode)
"Return overlay-aware lookup for PROPERTY at POSITION in OBJECT.
MODE is recorded in the returned `tp-lookup-result'."
(let* ((native (get-char-property-and-overlay position property object))
(overlay (cdr native))
(text-object (if (windowp object) (window-buffer object) object))
(text-source (tp--lookup-source-cell
position property text-object))
(present-p (or overlay (nth 2 text-source)))
(source (if overlay :overlay (car text-source))))
(tp--make-lookup-result
:property property :value (car native) :present-p (and present-p t)
:source source :mode mode :object (or object (current-buffer))
:position position :overlay overlay)))
(defun tp--lookup-alias-cell (position property object)
"Return the first non-nil alias value for PROPERTY at POSITION."
(catch 'found
(dolist (alias (cdr (assq property char-property-alias-alist)))
(when-let ((value (get-text-property position alias object)))
(throw 'found (list alias value))))))
(defun tp--lookup-source-cell (position property object)
"Return (SOURCE VALUE PRESENT-P) for text-only source lookup."
(let* ((props (text-properties-at position object))
(direct (plist-member props property))
(category (plist-get props 'category))
(cat-cell (and category (plist-member (symbol-plist category) property)))
(alias-cell (tp--lookup-alias-cell position property object))
(default-cell (plist-member default-text-properties property)))
(cond
(direct (list :text-direct (cadr direct) t))
(cat-cell (list :category (cadr cat-cell) t))
(alias-cell (list :alias (cadr alias-cell) t))
(default-cell (list :default (cadr default-cell) t))
(t (list :absent nil nil)))))
;;;###autoload
(cl-defun tp-lookup (position property &key object (mode :text-effective))
"Look up PROPERTY at POSITION in OBJECT according to MODE.
MODE is one of `:text-direct', `:text-effective', `:text-source',
`:char', or `:char-source'. Text modes ignore overlays. Character
modes delegate overlay precedence to `get-char-property-and-overlay';
when an overlay supplies the winning value, the result records both
source `:overlay' and the winning overlay object.
Always return a `tp-lookup-result'. Its `present-p' field separates
absence from a direct property whose value is nil."
(pcase mode
(:text-direct (tp--lookup-direct position property object mode))
(:text-effective (tp--lookup-effective position property object mode))
(:text-source
(pcase-let ((`(,source ,value ,present-p)
(tp--lookup-source-cell position property object)))
(tp--make-lookup-result
:property property :value value :present-p present-p
:source source :mode mode :object (or object (current-buffer))
:position position)))
((or :char :char-source)
(tp--lookup-char position property object mode))
(_ (error "tp-lookup: unknown mode %S" mode))))
;;;###autoload
(cl-defun tp-property-change
(position &key property object limit (direction :next))
"Return a native property change position from POSITION.
With PROPERTY, delegate to the single-property change primitives;
with nil PROPERTY, observe changes to any property. DIRECTION is
`:next' or `:previous'. OBJECT and LIMIT retain their native Emacs
meanings. Return the changed position or nil."
(pcase direction
(:next
(if property
(next-single-property-change position property object limit)
(next-property-change position object limit)))
(:previous
(if property
(previous-single-property-change position property object limit)
(previous-property-change position object limit)))
(_ (error "tp-property-change: unknown direction %S" direction))))
;;;###autoload
(defun tp-property-any (start end property value &optional object)
"Return first position in [START, END) where PROPERTY is VALUE.
This is the facade entry for `text-property-any'; OBJECT is a string,
a buffer, or nil for the current buffer."
(text-property-any start end property value object))
;;;###autoload
(defun tp-property-not-all (start end property value &optional object)
"Return first position in [START, END) where PROPERTY is not VALUE.
This delegates directly to `text-property-not-all'."
(text-property-not-all start end property value object))
(defun tp--mutation-policy-modes (policy)
"Return normalized (MODIFIED READ-ONLY) modes for POLICY."
(unless (and (proper-list-p policy) (cl-evenp (length policy)))
(error "tp-with-mutation-policy: POLICY must be a plist"))
(cl-loop for (key _value) on policy by #'cddr
unless (memq key '(:modified :read-only))
do (error "tp-with-mutation-policy: unknown key %S" key))
(let ((modified (if (plist-member policy :modified)
(plist-get policy :modified)
:ordinary))
(read-only (if (plist-member policy :read-only)
(plist-get policy :read-only)
:respect)))
(unless (memq modified '(:ordinary :silent))
(error "tp-with-mutation-policy: unknown :modified %S" modified))
(unless (memq read-only '(:respect :inhibit))
(error "tp-with-mutation-policy: unknown :read-only %S" read-only))
(when (and (eq modified :silent) (eq read-only :respect))
(error "tp-with-mutation-policy: :silent requires :read-only :inhibit"))
(list modified read-only)))
;;;###autoload
(defmacro tp-with-mutation-policy (policy &rest body)
"Run BODY with explicit mutation POLICY.
POLICY accepts `:modified' (`:ordinary' or `:silent') and
`:read-only' (`:respect' or `:inhibit'). The supported combinations
are ordinary/respect, ordinary/inhibit, and silent/inhibit.
Silent/respect is rejected because native `with-silent-modifications'
itself inhibits read-only text."
(declare (indent 1) (debug (form body)))
`(pcase (tp--mutation-policy-modes ,policy)
('(:ordinary :respect) ,@body)
('(:ordinary :inhibit)
(let ((inhibit-read-only t)) ,@body))
('(:silent :inhibit)
(let ((inhibit-read-only t))
(with-silent-modifications ,@body)))))
(provide 'tp-query)
;;; tp-query.el ends here

45
tp-reactive.el
View File

@ -30,6 +30,12 @@ Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).")
(defvar tp-layer-watchers nil
"Alist of layer watchers: (LAYER-NAME . ((VAR-SYMBOL . CALLBACK) ...)).")
(defvar tp-reactive-observer-errors nil
"Structured observer failures, newest first.
Each entry is a plist containing `:kind', `:layer', `:symbol',
`:condition', `:new-value', and `:old-value'. Watcher failures are
recorded here and reported, but do not block the managed update.")
(defvar tp-layer-computed nil
"Alist of computed properties: (LAYER-NAME . ((VAR-SYMBOL . COMPUTE-FN) ...)).")
@ -83,6 +89,12 @@ entry. Dead buffers and a nil LAYER-NAME are ignored. Installs the
(unless (memq buffer bufs)
(puthash layer-name (cons buffer bufs) tp--layer-buffers)))))
(defun tp-reactive--unregister-layer-buffer (layer-name buffer)
"Remove BUFFER from LAYER-NAME's registry entry when it is known."
(let ((buffers (gethash layer-name tp--layer-buffers 'unknown)))
(unless (eq buffers 'unknown)
(puthash layer-name (delq buffer buffers) tp--layer-buffers))))
(defun tp-reactive-layer-buffers (layer-name)
"Return the live buffers registered as showing layer LAYER-NAME.
Return a list of live buffers - possibly empty, meaning \"known: no
@ -164,12 +176,6 @@ 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
@ -314,8 +320,16 @@ NEWVAL is the new value, OLDVAL is the old value."
(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))))))))
(error
(push (list :kind 'watcher
:layer layer-name
:symbol watch-sym
:condition err
:new-value newval
:old-value oldval)
tp-reactive-observer-errors)
(message "tp: watcher error for %s watching %s: %s"
layer-name watch-sym err))))))))
(defun tp--register-layer-watchers (layer-name watchers)
"Register WATCHERS for LAYER-NAME.
@ -353,19 +367,13 @@ COMPUTED is a list of (VAR-SYMBOL COMPUTE-FN) pairs."
"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')."
A compute function returning nil is a legitimate result. Compute
errors propagate because a skipped value would leave stale state."
(dolist (comp compute)
(let* ((var-sym (car comp))
(compute-fn (cadr comp))
(val (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)))))
(val (funcall compute-fn)))
(set var-sym val))))
(defun tp--data-var-symbol (data-entry)
"Extract the variable symbol from DATA-ENTRY.
@ -435,6 +443,7 @@ it to allow re-definition to change initial values."
;; Clear all registries
(setq tp-reactive-deps nil)
(setq tp-layer-watchers nil)
(setq tp-reactive-observer-errors nil)
(setq tp-layer-computed nil)
(setq tp-layer-data nil)
;; Drop queued re-renders too: entries stranded by an error escaping

171
tp-render-tests.el
View File

@ -45,6 +45,12 @@
(defvar tp-rt-r3a-color nil)
(defvar tp-rt-r3b-color nil)
(defvar tp-rt-r3c-color nil)
(defvar tp-rt-a02-old-color nil)
(defvar tp-rt-a02-new-color nil)
(defvar tp-rt-a11-data nil)
(defvar tp-rt-a11-computed nil)
(defvar tp-rt-a11-watched nil)
(defvar tp-rt-a11-text nil)
(defmacro tp-rt-with-cleanup (layers vars &rest body)
"Run BODY, then undefine LAYERS and reset VARS to nil (teardown)."
@ -52,7 +58,8 @@
`(unwind-protect
(progn ,@body)
,@(mapcar (lambda (l) `(tp-undefine-layer ',l)) layers)
,@(mapcar (lambda (v) `(setq ,v nil)) vars)))
,@(mapcar (lambda (v) `(setq ,v nil)) vars)
(setq tp-reactive-observer-errors nil)))
;;; B9: sub-region tp-text on a string must splice, not replace the whole string
@ -93,6 +100,168 @@
(should (equal (get-text-property 0 'face result) '(:background "green")))
(should (equal (get-text-property 0 'tp-text result) "6"))))
;;; TP-A01 / TP-A03: initial tp-text application uses per-run properties
(ert-deftest tp-render-test-initial-tp-text-keeps-string-property-runs ()
"Initial string tp-text application does not smear position-zero props."
(let* ((payload (concat (propertize "AB" 'face 'bold)
(propertize "CD" 'face 'italic)))
(result (tp-set "xxxx" 'tp-text payload)))
(should (eq (get-text-property 0 'face result) 'bold))
(should (eq (get-text-property 2 'face result) 'italic))))
(ert-deftest tp-render-test-initial-tp-text-keeps-buffer-property-runs ()
"Initial buffer tp-text application preserves every embedded prop run."
(let ((payload (concat (propertize "AB" 'face 'bold)
(propertize "CD" 'face 'italic))))
(with-temp-buffer
(insert "xxxx")
(tp-set 1 5 (list 'tp-text payload))
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 3 'face) 'italic)))))
(ert-deftest tp-render-test-tp-text-explicit-nil-overrides-embedded-value ()
"A caller-provided nil remains present and wins over embedded props."
(let* ((payload (propertize "X" 'custom 'embedded))
(result (tp-set "x" 'tp-text payload 'custom nil)))
(should (equal (tp-member 0 'custom result) '(custom nil)))
(with-temp-buffer
(insert "x")
(tp-set 1 2 (list 'tp-text payload 'custom nil))
(should (equal (tp-member 1 'custom) '(custom nil))))))
(ert-deftest tp-render-test-same-text-reset-removes-old-properties ()
"A same-text tp-reset still replaces the complete property set."
(with-temp-buffer
(insert (propertize "AB" 'help-echo "old" 'face 'italic))
(tp-reset 1 3 '(tp-text "AB" face bold))
(should-not (plist-member (text-properties-at 1) 'help-echo))
(should (eq (get-text-property 1 'face) 'bold)))
(let* ((source (propertize "AB" 'help-echo "old" 'face 'italic))
(result (tp-reset source 'tp-text "AB" 'face 'bold)))
(should-not (plist-member (text-properties-at 0 result) 'help-echo))
(should (eq (get-text-property 0 'face result) 'bold))))
(ert-deftest tp-render-test-same-text-add-merges-existing-face ()
"A same-text tp-add keeps add semantics while applying per-run props."
(with-temp-buffer
(insert (propertize "AB" 'face 'italic))
(tp-add 1 3 '(tp-text "AB" face bold))
(should (equal (get-text-property 1 'face) '(bold italic))))
(let* ((source (propertize "AB" 'face 'italic))
(result (tp-add source 'tp-text "AB" 'face 'bold)))
(should (equal (get-text-property 0 'face result) '(bold italic))))
(let* ((source (propertize "AB" 'face 'italic))
(result (tp-add source 'tp-text nil 'face 'bold)))
(should (equal (get-text-property 0 'face result) '(bold italic)))))
;;; TP-A02: layer redefinition refreshes with full old/new ownership
(ert-deftest tp-render-test-static-redefinition-refreshes-managed-region ()
"A simple static redefinition refreshes an already-mounted layer."
(tp-rt-with-cleanup (tp-rt-a02-static) ()
(define-tp tp-rt-a02-static () '(face bold help-echo "old"))
(with-temp-buffer
(insert "Hello")
(tp-push-layer 1 6 'tp-rt-a02-static)
(define-tp tp-rt-a02-static () '(face italic))
(should (eq (get-text-property 1 'face) 'italic))
(should-not (plist-member (text-properties-at 1) 'help-echo)))))
(ert-deftest tp-render-test-redefinition-preserves-external-value ()
"A value changed after mounting is not deleted as stale layer output."
(tp-rt-with-cleanup (tp-rt-a02-external) ()
(define-tp tp-rt-a02-external () '(face bold help-echo "owned"))
(with-temp-buffer
(insert "Hello")
(tp-push-layer 1 6 'tp-rt-a02-external)
(put-text-property 1 6 'help-echo "external")
(define-tp tp-rt-a02-external () '(face italic))
(should (eq (get-text-property 1 'face) 'italic))
(should (equal (get-text-property 1 'help-echo) "external")))))
(ert-deftest tp-render-test-reactive-redefinition-removes-old-owned-keys ()
"Reactive redefinition removes keys and nested face data it no longer owns."
(tp-rt-with-cleanup
(tp-rt-a02-reactive) (tp-rt-a02-old-color tp-rt-a02-new-color)
(setq tp-rt-a02-old-color "red"
tp-rt-a02-new-color "blue")
(define-tp tp-rt-a02-reactive ()
:props '(face (:foreground $tp-rt-a02-old-color)
help-echo "old"))
(with-temp-buffer
(insert "Hello")
(tp-push-layer 1 6 'tp-rt-a02-reactive)
(define-tp tp-rt-a02-reactive ()
:props '(face (:background $tp-rt-a02-new-color)))
(let ((face (get-text-property 1 'face)))
(should (equal (plist-get face :background) "blue"))
(should-not (plist-member face :foreground)))
(should-not (plist-member (text-properties-at 1) 'help-echo)))))
;;; TP-A11: business computations fail; observers are isolated and recorded
(ert-deftest tp-render-test-transform-error-propagates ()
"Transform failures and non-string results both propagate."
(tp-rt-with-cleanup
(tp-rt-a11-transform tp-rt-a11-nonstring) (tp-rt-a11-text)
(setq tp-rt-a11-text "raw")
(define-tp tp-rt-a11-transform ()
:props '(tp-text $tp-rt-a11-text)
:transform (lambda (_text) (error "transform failed")))
(should-error (tp-set "old" 'tp-rt-a11-transform)
:type 'error)
(define-tp tp-rt-a11-nonstring ()
:props '(tp-text $tp-rt-a11-text)
:transform (lambda (_text) 42))
(should-error (tp-set "old" 'tp-rt-a11-nonstring)
:type 'error)))
(ert-deftest tp-render-test-compute-errors-propagate ()
"Initial and update-time compute failures reach the caller."
(tp-rt-with-cleanup (tp-rt-a11-initial tp-rt-a11-update)
(tp-rt-a11-data tp-rt-a11-computed)
(should-error
(define-tp tp-rt-a11-initial ()
:props '(help-echo $tp-rt-a11-computed)
:compute '((tp-rt-a11-computed
(lambda () (error "initial compute failed")))))
:type 'error)
(setq tp-rt-a11-data "ok")
(define-tp tp-rt-a11-update ()
:props '(help-echo $tp-rt-a11-computed)
:data '(tp-rt-a11-data)
:compute '((tp-rt-a11-computed
(lambda ()
(if (equal tp-rt-a11-data "ok")
"ready"
(error "update compute failed"))))))
(should-error (setq tp-rt-a11-data "fail")
:type 'error)))
(ert-deftest tp-render-test-watcher-error-is-recorded-and-update-continues ()
"Watcher failures are isolated, queryable, and do not block rendering."
(tp-rt-with-cleanup (tp-rt-a11-watcher) (tp-rt-a11-watched)
(setq tp-rt-a11-watched "red")
(when (boundp 'tp-reactive-observer-errors)
(set 'tp-reactive-observer-errors nil))
(define-tp tp-rt-a11-watcher ()
:props '(face (:foreground $tp-rt-a11-watched))
:watch '((tp-rt-a11-watched
(lambda (_new _old _layer)
(error "watcher failed")))))
(with-temp-buffer
(insert "x")
(tp-push-layer 1 2 'tp-rt-a11-watcher)
(setq tp-rt-a11-watched "blue")
(should (equal (plist-get (tp-at 1 'face) :foreground) "blue"))
(should (boundp 'tp-reactive-observer-errors))
(let ((failure (car (symbol-value 'tp-reactive-observer-errors))))
(should (eq (plist-get failure :kind) 'watcher))
(should (eq (plist-get failure :layer) 'tp-rt-a11-watcher))
(should (eq (plist-get failure :symbol) 'tp-rt-a11-watched))
(should (eq (car (plist-get failure :condition)) 'error))))))
;;; B10: computed-variable path must not clobber sibling static attributes
(ert-deftest tp-render-test-computed-update-keeps-static-siblings ()

306
tp-render.el
View File

@ -61,48 +61,36 @@ usable definition."
base (tp--resolve-reactive-symbols reactive override-alist))
base)))))
(defun tp--store-computed-value
(layer-name var-sym computed-val override-alist)
"Store LAYER-NAME's computed VAR-SYM and return updated OVERRIDE-ALIST."
(set var-sym computed-val)
(push (cons var-sym computed-val) override-alist)
(let ((current-props (cdr (assoc layer-name tp-layer-alist)))
(reactive-props (tp--layer-reactive-props layer-name)))
(when (and current-props reactive-props)
(let ((resolved
(tp--resolve-reactive-symbols reactive-props override-alist)))
(when resolved
(tp--set-layer-props
layer-name
(tp--deep-merge-plist current-props resolved))))))
override-alist)
(defun tp--update-layer-computed (layer-name override-alist)
"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)))))))))))
"Compute LAYER-NAME values and return an updated OVERRIDE-ALIST.
Compute errors propagate; returning nil remains a legitimate value."
(dolist (comp (cdr (assoc layer-name tp-layer-computed)))
(let* ((var-sym (car comp))
(compute-fn (cdr comp))
(computed-val
(cl-progv
(mapcar #'car override-alist)
(mapcar #'cdr override-alist)
(funcall compute-fn))))
(setq override-alist
(tp--store-computed-value
layer-name var-sym computed-val override-alist))))
override-alist)
(defun tp--render-visit-buffer (buffer fn)
@ -139,33 +127,158 @@ still picked up by the next update's full scan."
(tp-reactive--register-layer-buffer layer-name buf))
(tp--render-visit-buffer buf fn)))))))
(defun tp--merge-props-into-stack-entry (entry props)
"Return stack-storage plist ENTRY with its keys updated from PROPS.
Every key of PROPS except `tp-name' and `tp-layers' replaces ENTRY's
value for that key (or extends ENTRY when the key is new), so ENTRY's
`tp-hidden' flag and identity survive the update. Returns a fresh
plist; ENTRY itself is not modified."
(let ((new-entry (copy-sequence entry)))
(cl-loop for (key val) on props by #'cddr
unless (memq key '(tp-name tp-layers))
do (setq new-entry (plist-put new-entry key val)))
new-entry))
(defun tp--reconcile-layer-props
(current old-props new-props &optional include-meta)
"Replace one layer's OLD-PROPS in CURRENT with NEW-PROPS.
Keys owned by OLD-PROPS are removed when CURRENT still carries the old
value, then NEW-PROPS are written in full. A differing current value
is preserved when the new definition no longer owns that key, because
it may be an explicit post-application edit. Stack metadata
`tp-layers' and `tp-hidden' is never owned by a layer definition.
`tp-meta' is rendered only when INCLUDE-META is non-nil.
Return a fresh plist."
(let ((result (copy-sequence current)))
(cl-loop for (key val) on old-props by #'cddr
unless (memq key '(tp-name tp-layers tp-hidden tp-meta))
when (and (plist-member result key)
(equal (plist-get result key) val))
do (cl-remf result key))
(cl-loop for (key val) on new-props by #'cddr
unless (or (memq key '(tp-layers tp-hidden))
(and (eq key 'tp-meta) (not include-meta)))
do (setq result (plist-put result key val)))
result))
(defun tp--write-layer-through-stack-storage (layer-name props)
(defun tp--reconcile-layer-region (start end old-props new-props)
"Reconcile OLD-PROPS and NEW-PROPS on every property run in START..END."
(let ((pos start))
(while (< pos end)
(let* ((next (or (next-property-change pos nil end) end))
(current (text-properties-at pos))
(updated (tp--reconcile-layer-props
current old-props new-props)))
(unless (equal updated current)
(set-text-properties pos next updated))
(setq pos next)))))
(defun tp--replace-stack-entry-props (entry old-props new-props)
"Return ENTRY with OLD-PROPS replaced by NEW-PROPS."
(tp--refresh-entry-meta-version
(tp--reconcile-layer-props entry old-props new-props t)))
(defun tp--refresh-entry-meta-version (entry)
"Return ENTRY with refreshed metadata version fields when present."
(if-let ((meta (plist-get entry 'tp-meta))
(name (plist-get entry 'tp-name)))
(let ((updated (copy-tree meta)))
(setq updated
(plist-put updated :definition-version
(tp--layer-definition-version name)))
(setq updated
(plist-put updated :entry-version
(1+ (or (plist-get meta :entry-version) 0))))
(when (boundp 'tp-theme-generation)
(setq updated
(plist-put updated :palette-generation
tp-theme-generation)))
(plist-put entry 'tp-meta updated))
entry))
(defun tp--entry-parameterized-refresh (entry layer-name)
"Return refreshed ENTRY for parameterized LAYER-NAME, or ENTRY."
(let ((meta (plist-get entry 'tp-meta)))
(if (and meta
(eq (plist-get entry 'tp-name) layer-name)
(not (plist-get meta :legacy-no-args))
(plist-member meta :args)
(tp-layer-parameterized-p layer-name))
(tp--entry-from-parameterized-meta entry layer-name meta)
entry)))
(defun tp--entry-from-parameterized-meta (entry layer-name meta)
"Build a refreshed managed ENTRY for LAYER-NAME from META."
(let* ((args (plist-get meta :args))
(props (tp-layer-props-with-args layer-name args t))
(hidden (tp--stack-hidden-p entry))
(updated (tp--refresh-entry-meta-version
(plist-put props 'tp-meta (copy-tree meta)))))
(if hidden
(plist-put updated 'tp-hidden t)
updated)))
(defun tp--refresh-parameterized-stack (stack layer-name)
"Refresh parameterized LAYER-NAME entries in STACK."
(mapcar (lambda (entry)
(tp--entry-parameterized-refresh entry layer-name))
stack))
(defun tp--refresh-parameterized-layer-regions (layer-name)
"Refresh mounted parameterized entries for LAYER-NAME in current buffer."
(let ((pos (point-min))
(max (point-max)))
(while (< pos max)
(let* ((next (or (next-property-change pos nil max) max))
(stack (tp--stack-props-to-list (text-properties-at pos)))
(new-stack (tp--refresh-parameterized-stack stack layer-name)))
(unless (equal new-stack stack)
(set-text-properties pos next
(tp--stack-build-props new-stack)))
(setq pos next)))))
(defun tp--managed-stack-with-direct-edits (props stored)
"Return authoritative STORED after absorbing visible edits from PROPS.
In managed full-stack storage, direct properties are the render
projection of the first visible entry. A caller may legitimately
edit that projection with native text-property primitives. Preserve
those edits on the visible entry before refreshing definitions, while
keeping managed identity and metadata authoritative."
(let ((direct (copy-sequence props)))
(cl-remf direct 'tp-layers)
(let ((visible (seq-find (lambda (entry)
(not (tp--stack-hidden-p entry)))
stored)))
(cond
((null visible)
(if direct
(signal 'tp-layer-conflict
(list "Properties appeared while all layers were hidden"
:actual direct))
stored))
((not (equal (plist-get direct 'tp-name)
(plist-get visible 'tp-name)))
(signal 'tp-layer-conflict
(list "Managed render identity changed"
:actual direct :expected visible)))
(t
(let ((updated (copy-tree visible)))
(cl-loop for (key _value)
on (tp--entry-render-projection visible) by #'cddr
unless (or (eq key 'tp-name)
(plist-member direct key))
do (cl-remf updated key))
(cl-loop for (key value) on direct by #'cddr
unless (eq key 'tp-name)
do (setq updated (plist-put updated key value)))
(mapcar (lambda (entry)
(if (eq entry visible) updated entry))
stored)))))))
(defun tp--write-layer-through-stack-storage
(layer-name props &optional old-props)
"Write PROPS through to LAYER-NAME's entries in `tp-layers' storage.
A reactive re-render rewrites a layer's direct (rendered) properties,
but the same layer can also sit inside the `tp-layers' stack-storage
property of a run: buried below another layer, or hidden (see
`tp-hide-layer'), in which case the direct properties are only a
render cache and the stored entry is what the next stack operation
rebuilds from. For every run of the current buffer whose `tp-layers'
holds an entry whose `tp-name' equals LAYER-NAME, replace the layer's
own keys in that entry with their values from PROPS - preserving the
entry's `tp-hidden' flag and stack position - and rewrite the run via
`tp--stack-props-to-list' / `tp--stack-build-props', which also
refreshes the topmost-visible render cache in full-stack storage
mode. Runs already storing the current values are left untouched, so
an update that changes nothing does not mark the buffer as modified."
rebuilds from. OLD-PROPS, when non-nil, identifies definition-owned
keys that disappeared and must be removed.
For every run of the current buffer whose `tp-layers' holds an entry
whose `tp-name' equals LAYER-NAME, reconcile the layer entry and
rewrite the run via `tp--stack-props-to-list' /
`tp--stack-build-props'. Runs already storing the current values are
left untouched."
(let ((pos (point-min))
(max (point-max)))
(while (< pos max)
@ -175,11 +288,16 @@ an update that changes nothing does not mark the buffer as modified."
(cl-some (lambda (entry)
(equal (plist-get entry 'tp-name) layer-name))
stored))
(let* ((stack (tp--stack-props-to-list (text-properties-at pos)))
(let* ((raw (text-properties-at pos))
(stack
(if (tp--entry-authoritative-storage-p stored)
(tp--managed-stack-with-direct-edits raw stored)
(tp--stack-props-to-list raw)))
(new-stack
(mapcar (lambda (entry)
(if (equal (plist-get entry 'tp-name) layer-name)
(tp--merge-props-into-stack-entry entry props)
(tp--replace-stack-entry-props
entry old-props props)
entry))
stack)))
(unless (equal new-stack stack)
@ -187,49 +305,43 @@ an update that changes nothing does not mark the buffer as modified."
(tp--stack-build-props new-stack)))))
(setq pos next)))))
(defun tp--update-layer-regions (layer-name &optional where override-alist)
(defun tp--update-layer-regions
(layer-name &optional where override-alist old-props)
"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.
Reconcile the layer's current properties with OLD-PROPS, when given,
so redefinition removes keys and nested values the old definition
owned while preserving unrelated direct properties.
The update also writes through to `tp-layers' stack storage (see
`tp--write-layer-through-stack-storage'): copies of the layer that
are hidden or buried below another layer are refreshed in place, so a
later stack operation or `tp-show-layer' renders current values
instead of a stale snapshot.
The update also writes through to `tp-layers' stack storage: copies
of the layer that are hidden or buried below another layer are
refreshed in place, so a later stack operation or `tp-show-layer'
renders current values instead of a stale snapshot.
WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update the buffers registered for the layer in
the reactive buffer registry, falling back to one full
`buffer-list' scan when the registry has no knowledge of the
layer (see `tp--map-layer-buffers').
- If WHERE is nil, update the buffers registered for the layer,
falling back to a full scan when the registry has no knowledge.
OVERRIDE-ALIST maps reactive variables to their new values when 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."
OVERRIDE-ALIST maps reactive variables to their new values when a
watcher fires before those variables are set."
(let ((update-buffer
(lambda ()
(let ((props (tp--layer-render-props layer-name override-alist)))
(when props
(save-excursion
;; Callback for tp-search-map: replaces the layer's own
;; property keys on the matched region. Returns nil to
;; prevent tp-search-map from replacing the text.
(tp-search-map
(lambda (_text start end)
(cl-loop for (key val) on props by #'cddr
do (put-text-property start end key val))
nil)
'tp-name layer-name)
;; Write through to stack storage so hidden or buried
;; copies of the layer do not go stale (HID-1).
(tp--write-layer-through-stack-storage layer-name
props)))))))
(save-excursion
(if props
(progn
;; In hidden/full-stack mode storage is authoritative.
;; Update it first so the render-cache conflict guard
;; compares old cache with old storage.
(tp--write-layer-through-stack-storage
layer-name props old-props)
(tp-search-map
(lambda (_text start end)
(tp--reconcile-layer-region
start end old-props props)
nil)
'tp-name layer-name))
(tp--refresh-parameterized-layer-regions layer-name)))))))
(tp--map-layer-buffers layer-name where update-buffer)))
(defun tp--update-reactive-text (layer-name &optional where override-alist)

113
tp-search-tests.el
View File

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

509
tp-search.el
View File

@ -24,6 +24,13 @@
(require 'tp-layer)
(require 'tp-ops)
(defconst tp-any-value (make-symbol "tp-any-value")
"Unique wildcard used by tp property-search APIs.
Omitting VALUE selects this sentinel automatically. Pass the variable
`tp-any-value' explicitly when a later positional argument is needed
and any present direct value should match. An explicit nil VALUE is
therefore available for exact, presence-aware nil matching.")
(defun tp--search-register-layer-buffer (props object)
"Record OBJECT in the reactive buffer registry for PROPS's layers.
When OBJECT is a buffer or nil (the current buffer) and the applied
@ -451,88 +458,126 @@ PREDICATE follows the convention tp uses for
`text-property-search-forward': nil and t both mean the values must
be `equal' (tp's 0.2.0 symmetric matching contract); a function is
called with VALUE and PROP-VALUE and matches when it returns
non-nil."
non-nil. `tp-any-value' matches every PROP-VALUE."
(if (functionp predicate)
(funcall predicate value prop-value)
(equal value prop-value)))
(or (eq value tp-any-value)
(equal value prop-value))))
(defun tp--string-property-matches (string property value predicate)
"Collect PROPERTY runs of STRING matching VALUE under PREDICATE.
Returns a list of (START END VALUE) lists with 0-based positions. A
run is a maximal stretch with one `eq' PROPERTY value, and it matches
when `tp--property-match-p' accepts that value. Adjacent matching
runs with different values stay separate entries, mirroring how
`text-property-search-forward' ends a match where the property value
changes when a non-nil predicate is given."
(let ((results nil))
(tp--map-intervals
string 0 (length string)
(lambda (beg end val)
(when (tp--property-match-p value val predicate)
(push (list beg end val) results))
nil)
property)
(defun tp--property-matches (object start end property value predicate)
"Return matching direct PROPERTY runs in OBJECT between START and END.
Each result is a canonical `tp--match'. A run is eligible only when
PROPERTY is present in `text-properties-at', so an explicit nil value
is distinct from absence. Boundaries caused only by unrelated
properties are joined back into one PROPERTY run."
(let ((obj (or object (current-buffer)))
(pos start)
(results nil))
(while (< pos end)
(let* ((next (or (next-property-change pos object end) end))
(presence (tp--presence-at pos property object))
(prop-value (tp--presence-value presence)))
(when (and (tp--presence-present-p presence)
(tp--property-match-p value prop-value predicate))
(let ((previous (car results)))
(if (and previous
(= (tp--native-range-end
(tp--match-range previous))
pos)
(equal (tp--match-value previous) prop-value))
(setf (tp--native-range-end
(tp--match-range previous))
next)
(push (tp--make-match
(tp--make-native-range
obj (tp--object-kind obj) pos next)
property prop-value)
results))))
(setq pos next)))
(nreverse results)))
(defun tp--property-search-backward (property value
&optional predicate not-current)
"Search backward for the previous region where PROPERTY matches VALUE.
This is the backward mirror of (text-property-search-forward PROPERTY
VALUE t): by default a region matches when its PROPERTY value is
`equal' to VALUE. It deliberately does not call
`text-property-search-backward' with predicate t, because that
primitive's non-default-predicate branch skips every other property
run when non-matching runs intervene (observed through Emacs 30.2),
silently missing valid matches.
PREDICATE follows `tp--property-match-p': nil and t both mean `equal'
matching (the 0.2.0 contract); a function is called with VALUE and
the region's PROPERTY value. When NOT-CURRENT is non-nil, the
matching region containing point (or ending exactly at point) is
skipped, mirroring the primitive's NOT-CURRENT argument.
If a matching region is found, move point to its beginning and
return a `prop-match' object whose end is clipped to the starting
point (matching the primitive's behavior when point starts inside a
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 (and (tp--property-match-p value val predicate)
;; With NOT-CURRENT, the run point is inside (or
;; just after) is not a candidate.
(not (and not-current (= iend origin))))
(setq found (list ibeg iend val)))
nil)
property)
Only direct PROPERTY runs are candidates. VALUE and PREDICATE follow
`tp--property-match-p'. NOT-CURRENT skips the run containing point."
(unless (bobp)
(let* ((origin (point))
(matches (nreverse
(tp--property-matches
(current-buffer) (point-min) (point-max)
property value predicate)))
(found
(seq-find
(lambda (match)
(and (< (tp--native-range-start (tp--match-range match))
origin)
(not (and not-current
(<= (tp--native-range-start
(tp--match-range match))
origin)
(>= (tp--native-range-end
(tp--match-range match))
origin)))))
matches)))
(when found
(goto-char (car found))
(make-prop-match :beginning (car found)
:end (cadr found)
:value (caddr found))))))
(let ((range (tp--match-range found)))
(goto-char (tp--native-range-start range))
(setf (tp--native-range-end range)
(min origin (tp--native-range-end range)))
(tp--match-to-prop-match found))))))
(defun tp-forward (property &optional value object n predicate not-current)
(defun tp--property-search-forward (property value predicate not-current)
"Search forward once for a direct PROPERTY run from point."
(let* ((origin (point))
(found
(seq-find
(lambda (match)
(and (> (tp--native-range-end (tp--match-range match))
origin)
(not (and not-current
(<= (tp--native-range-start
(tp--match-range match))
origin)
(< origin
(tp--native-range-end
(tp--match-range match)))))))
(tp--property-matches
(current-buffer) (point-min) (point-max)
property value predicate))))
(when found
(let ((range (tp--match-range found)))
(goto-char (tp--native-range-end range))
(setf (tp--native-range-start range)
(max origin (tp--native-range-start range)))
(tp--match-to-prop-match found)))))
(defun tp--search-result-value (object start end property value)
"Return public search matches for OBJECT between START and END."
(let* ((range (tp--native-range-from-object object start end))
(request (tp--make-request
:operation :search :range range :property property
:value value :public-return :matches))
(matches (tp--property-matches
(tp--native-range-object range)
(tp--native-range-start range)
(tp--native-range-end range)
property value nil)))
(tp--result-public-value
(tp--make-result :request request :matches matches))))
(cl-defun tp-forward
(property &optional (value tp-any-value) object n predicate not-current)
"Search forward N times for text with PROPERTY.
VALUE is the optional value to match; N is the number of searches,
defaulting to 1.
Omitted VALUE matches any present direct value; explicit nil matches a
present nil value. Pass `tp-any-value' when later positional
arguments are needed with wildcard matching. N is the number of
searches, defaulting to 1.
OBJECT can be a buffer or string; nil defaults to current buffer.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil. For buffers it
is passed to `text-property-search-forward'.
NOT-CURRENT is passed to `text-property-search-forward' and, when
non-nil, makes the search skip a matching region containing point.
It only applies to the buffer path; strings have no point, so it is
ignored there.
`equal' contract; a function is called with VALUE and the run value.
NOT-CURRENT skips a matching buffer run containing point.
For buffers, each search starts from point and each successful one
moves point to the end of its matched region; the return value is
@ -546,30 +591,30 @@ the N-th match alone. Fewer than N matches return however many
exist."
(let ((count (or n 1)))
(cond
;; String object - use tp-search (or the predicate-aware matcher)
((stringp object)
(let ((matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value))))
(seq-take matches count)))
;; Buffer or nil
(let ((matches (tp--property-matches
object 0 (length object) property value predicate)))
(mapcar #'tp--match-to-list (seq-take matches count))))
(t
(let ((result nil)
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
(setq result (text-property-search-forward
property value
(if (functionp predicate) predicate t)
not-current))))
(catch 'done
(dotimes (_ count)
(setq result (tp--property-search-forward
property value predicate not-current))
(unless result
(throw 'done nil)))))
result)))))
(defun tp-backward (property &optional value object n predicate not-current)
(cl-defun tp-backward
(property &optional (value tp-any-value) object n predicate not-current)
"Search backward N times for text with PROPERTY.
N is the number of searches, defaulting to 1.
VALUE is the optional value to match.
Omitted VALUE matches any present direct value; explicit nil matches a
present nil value. Pass `tp-any-value' when later positional
arguments are needed with wildcard matching.
OBJECT can be a buffer or string; nil defaults to current buffer.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
@ -584,40 +629,37 @@ 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--property-search-backward' for buffers and `tp-search' (or
the predicate-aware matcher) for strings."
Uses the same presence-aware run scanner for strings and buffers."
(let ((count (or n 1)))
(cond
;; String object - use tp-search and reverse
((stringp object)
(let ((matches (nreverse (if (functionp predicate)
(tp--string-property-matches
object property value predicate)
(tp-search object property value)))))
(seq-take matches count)))
;; Buffer or nil
(let ((matches
(nreverse
(tp--property-matches
object 0 (length object) property value predicate))))
(mapcar #'tp--match-to-list (seq-take matches count))))
(t
(let ((result nil)
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
;; `equal' matching by default, mirroring the predicate t
;; that `tp-forward' passes. The previous code used the
;; default nil predicate, which matches values NOT `equal'
;; to VALUE and so inverted the match when VALUE was
;; non-nil.
(setq result (tp--property-search-backward
property value predicate not-current))))
(catch 'done
(dotimes (_ count)
(setq result (tp--property-search-backward
property value predicate not-current))
(unless result
(throw 'done nil)))))
result)))))
(defun tp--forward-do (function property &optional value object times
start end predicate not-current)
(cl-defun tp--forward-do
(function property &optional (value tp-any-value) object times
start end predicate not-current)
"Internal: search forward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT.
TIMES is the number of searches, defaulting to 1.
VALUE is the optional value to match.
Omitted VALUE matches any present value; explicit nil matches a
present nil 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.
PREDICATE and NOT-CURRENT are passed to each underlying search (see
@ -632,15 +674,10 @@ Returns the number of matches found (at most TIMES)."
((stringp object)
(let* ((start-pos (or start 0))
(end-pos (or end (length object)))
(all-matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value)))
(filtered-matches (seq-filter (lambda (m)
(and (>= (car m) start-pos)
(<= (cadr m) end-pos)))
all-matches))
(matches (seq-take filtered-matches count)))
(all-matches (tp--property-matches
object start-pos end-pos
property value predicate))
(matches (seq-take all-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.
@ -657,10 +694,8 @@ Returns the number of matches found (at most TIMES)."
(save-excursion
(goto-char search-start)
(dotimes (i count)
(when-let ((match (text-property-search-forward
property value
(if (functionp predicate) predicate t)
not-current)))
(when-let ((match (tp--property-search-forward
property value predicate not-current)))
(when (<= (prop-match-end match) search-end)
(when (= i (1- count))
(funcall function match buf))
@ -677,16 +712,20 @@ prop-match struct (buffer matches). ARITY is the precomputed
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 string OBJ the replacement happens in place and must have the
same length as the match. A different length signals an error.
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)))
(let* ((range (when (tp--match-p match) (tp--match-range match)))
(m-start (cond (range (tp--native-range-start range))
((listp match) (car match))
(t (prop-match-beginning match))))
(m-end (cond (range (tp--native-range-end range))
((listp match) (cadr match))
(t (prop-match-end match))))
(text (if (stringp obj)
(substring obj m-start m-end)
(buffer-substring m-start m-end)))
@ -735,8 +774,9 @@ length-changing replacements" new-text (length new-text) len))
(goto-char m-start)
(insert new-text)))))))
(defun tp-forward-do (function property &optional value object times
start end predicate not-current)
(cl-defun tp-forward-do
(function property &optional (value tp-any-value) object times
start end predicate not-current)
"Search forward TIMES times for PROPERTY; apply FUNCTION at the Nth match.
Despite the -do suffix this is NOT a for-each: the search advances
@ -748,9 +788,10 @@ 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.
PROPERTY is the text property to search for. Omitted VALUE matches any
present value; explicit nil matches a present nil value. Pass
`tp-any-value' when later positional arguments are needed with
wildcard matching.
OBJECT can be a buffer or string; nil defaults to current buffer.
TIMES is the number of searches, defaulting to 1. The function searches
TIMES times but only applies FUNCTION to the last (Nth) match found.
@ -765,39 +806,41 @@ path (strings have no point).
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.
Note: For string objects, the replacement text must have the same
length as the original matched text, since strings have fixed length
in Emacs; a different length signals an error. Buffer replacements
may grow or shrink.
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)
(tp-forward-do #\\='upcase \\='marker tp-any-value 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)
\\='marker tp-any-value my-string 2)
;; Search within a range
(tp-forward-do #\\='upcase \\='marker nil my-string 1 0 10)"
(tp-forward-do #\\='upcase \\='marker tp-any-value 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 predicate not-current)))
(defun tp--backward-do (function property &optional value object times
start end predicate not-current)
(cl-defun tp--backward-do
(function property &optional (value tp-any-value) object times
start end predicate not-current)
"Internal: search backward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT.
TIMES is the number of searches, defaulting to 1.
VALUE is the optional value to match.
Omitted VALUE matches any present value; explicit nil matches a
present nil 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.
PREDICATE and NOT-CURRENT are passed to each underlying search (see
@ -812,16 +855,10 @@ Returns the number of matches found (at most TIMES)."
((stringp object)
(let* ((start-pos (or start 0))
(end-pos (or end (length object)))
(all-matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value)))
(filtered-matches
(seq-filter (lambda (m)
(and (>= (car m) start-pos)
(<= (cadr m) end-pos)))
all-matches))
(matches (seq-take (nreverse filtered-matches) count)))
(all-matches (tp--property-matches
object start-pos end-pos
property value predicate))
(matches (seq-take (nreverse all-matches) count)))
;; All-or-nothing; see tp--forward-do.
(when (= (length matches) count)
(funcall function (car (last matches)) object))
@ -846,8 +883,9 @@ Returns the number of matches found (at most TIMES)."
(cl-incf matches)))))))
matches)))))
(defun tp-backward-do (function property &optional value object times
start end predicate not-current)
(cl-defun tp-backward-do
(function property &optional (value tp-any-value) object times
start end predicate not-current)
"Search backward TIMES times for PROPERTY; apply FUNCTION at the Nth match.
Despite the -do suffix this is NOT a for-each: the search walks back
@ -859,9 +897,10 @@ 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.
PROPERTY is the text property to search for. Omitted VALUE matches any
present value; explicit nil matches a present nil value. Pass
`tp-any-value' when later positional arguments are needed with
wildcard matching.
OBJECT can be a buffer or string; nil defaults to current buffer.
TIMES is the number of searches, defaulting to 1. The function searches
TIMES times but only applies FUNCTION to the last (Nth) match found.
@ -876,33 +915,37 @@ on each underlying search; it only applies to the buffer path
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.
Note: For string objects, the replacement text must have the same
length as the original matched text, since strings have fixed length
in Emacs; a different length signals an error. Buffer replacements
may grow or shrink.
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)
(tp-backward-do #\\='upcase \\='marker tp-any-value 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)
\\='marker tp-any-value my-string 2)
;; Search within a range
(tp-backward-do #\\='upcase \\='marker nil my-string 1 0 10)"
(tp-backward-do #\\='upcase \\='marker tp-any-value 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 predicate not-current)))
(defun tp-search (start-or-string
&optional end-or-property property-or-value value object)
(cl-defun tp-search
(start-or-string
&optional end-or-property
(property-or-value tp-any-value property-value-supplied-p)
(value tp-any-value value-supplied-p)
object)
"Search for all text with PROPERTY in a buffer/string range or entire string.
This function supports two calling conventions:
@ -913,94 +956,34 @@ This function supports two calling conventions:
2. Entire string:
(tp-search STRING PROPERTY &optional VALUE)
When VALUE is omitted, match every run where PROPERTY is directly
present. An explicit nil matches only directly present nil values.
Use `tp-any-value' explicitly when OBJECT must also be supplied.
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)
(tp--search-result-value
start-or-string 0 (length start-or-string) end-or-property
(if property-value-supplied-p property-or-value tp-any-value)))
((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)))
(tp--search-result-value
(or object (current-buffer)) start-or-string end-or-property
property-or-value
(if value-supplied-p value tp-any-value)))
(t (error "Invalid first argument: %S" start-or-string))))
(defun tp--search-do (function property &optional value object start end)
(cl-defun tp--search-do
(function property &optional (value tp-any-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.
PROPERTY is the text property to search for. Omitted VALUE matches any
present value; explicit nil matches a present nil 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.
@ -1012,31 +995,32 @@ 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))
(let* ((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))
(matches (tp--property-matches
obj s e property value nil)))
(dolist (match matches)
(funcall function (tp--match-to-list match) obj))
(length 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))
(matches (tp--property-matches
obj s e property value nil))
(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)))
(let ((range (tp--match-range m)))
(list (copy-marker
(tp--native-range-start range)
t)
(copy-marker
(tp--native-range-end range))
(tp--match-value m))))
matches)))
(unwind-protect
(dolist (m marked)
@ -1050,7 +1034,8 @@ their text): later matches still receive their up-to-date positions."
(set-marker (cadr m) nil)))
(length marked))))))
(defun tp-search-map (function property &optional value object start end)
(cl-defun tp-search-map
(function property &optional (value tp-any-value) object start end)
"Apply FUNCTION to all matches of PROPERTY in OBJECT.
Signature: (tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END)
@ -1065,33 +1050,35 @@ FUNCTION can either:
- 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.
PROPERTY is the text property to search for. Omitted VALUE matches any
present value; explicit nil matches a present nil value. Pass
`tp-any-value' when later positional arguments are needed with
wildcard matching.
OBJECT can be a buffer or string; nil defaults to current buffer.
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.
as the original matched text, since strings have fixed length in
Emacs; a different length signals an error. Buffer replacements may
grow or shrink.
Example:
;; Upcase all matched text
(tp-search-map #\\='upcase \\='marker nil my-string)
(tp-search-map #\\='upcase \\='marker tp-any-value my-string)
;; Add properties to matched text
(tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold)) \\='marker nil str)
(tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold))
\\='marker tp-any-value 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)
\\='marker tp-any-value str)
;; Search within a range
(tp-search-map #\\='upcase \\='marker nil my-string 0 10)"
(tp-search-map #\\='upcase \\='marker tp-any-value my-string 0 10)"
(let ((idx 0)
(arity (func-arity function)))
(tp--search-do

70
tp-stack-tests.el
View File

@ -102,19 +102,19 @@ definitions cannot leak between tests."
(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."
"Distant properties do not change the public managed stack."
(tp-stack-tests--with-env
(define-tp layer1 () '(face bold))
(let (props-bare props-distant)
(with-temp-buffer
(insert "abcdefghij")
(tp-push-layer 1 4 'layer1)
(setq props-bare (text-properties-at 1)))
(setq props-bare (tp-layer-stack-at 1)))
(with-temp-buffer
(insert "abcdefghij")
(put-text-property 8 10 'help-echo "far")
(tp-push-layer 1 4 'layer1)
(setq props-distant (text-properties-at 1)))
(setq props-distant (tp-layer-stack-at 1)))
(should (equal props-bare props-distant)))))
;;; B30: inline plists with ordinary (non-keyword) properties
@ -267,19 +267,21 @@ definitions cannot leak between tests."
(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
;;; B35: a single managed layer has non-nil authoritative storage
(ert-deftest tp-stack-test-single-layer-no-tp-layers-prop ()
"Pushing one layer does not leave a (tp-layers nil) property behind."
(ert-deftest tp-stack-test-single-layer-has-authoritative-storage ()
"Pushing one layer stores one metadata entry, never tp-layers nil."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 1 6 'layer1)
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers))
(should (= (length (get-text-property 1 'tp-layers)) 1))
(should (plist-get (car (get-text-property 1 'tp-layers)) 'tp-meta))
(should-not (plist-member (tp-layer-stack-at 1) 'tp-meta))
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-delete-to-single-layer-no-tp-layers-prop ()
"Deleting down to one layer drops the tp-layers property entirely."
(ert-deftest tp-stack-test-delete-to-single-layer-keeps-metadata-storage ()
"Deleting down to one layer keeps one authoritative metadata entry."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
@ -289,11 +291,11 @@ definitions cannot leak between tests."
;; 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 (= (length (get-text-property 1 'tp-layers)) 1))
(should (eq (get-text-property 1 'tp-name) 'layer1))))
(ert-deftest tp-stack-test-pop-to-single-layer-no-tp-layers-prop ()
"Popping down to one layer drops the tp-layers property entirely."
(ert-deftest tp-stack-test-pop-to-single-layer-keeps-metadata-storage ()
"Popping down to one layer keeps one authoritative metadata entry."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp layer1 () '(face bold))
@ -301,7 +303,7 @@ definitions cannot leak between tests."
(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 (= (length (get-text-property 0 'tp-layers str)) 1))
(should (eq (get-text-property 0 'tp-name str) 'layer1)))))
(ert-deftest tp-stack-test-absent-tp-layers-tolerated-by-stack-ops ()
@ -513,7 +515,7 @@ definitions cannot leak between tests."
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-hide-show-roundtrip-restores-storage ()
"A hide/show roundtrip restores the exact original properties."
"A hide/show roundtrip restores the exact metadata-backed storage."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
@ -524,7 +526,21 @@ definitions cannot leak between tests."
(should (null (get-text-property 1 'tp-name)))
(tp-show-layer 1 6 'layer1)
(should (equal (text-properties-at 1) before))
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers)))))
(should (= (length (get-text-property 1 'tp-layers)) 1)))))
(ert-deftest tp-stack-test-hidden-direct-edit-signals-before-stack-write ()
"A hidden-range direct edit raises a conflict instead of being discarded."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp tp-st-a10-layer () '(face bold))
(tp-push-layer 1 6 'tp-st-a10-layer)
(tp-hide-layer 1 6 'tp-st-a10-layer)
(put-text-property 1 6 'help-echo "external")
(let ((before (text-properties-at 1)))
(should-error (tp-show-layer 1 6 'tp-st-a10-layer)
:type 'tp-layer-conflict)
(should (equal (text-properties-at 1) before))
(should (equal (get-text-property 1 'help-echo) "external")))))
(ert-deftest tp-stack-test-flatten-drops-tp-hidden-flag ()
"Flattening a stack with a hidden layer never leaks the tp-hidden flag.
@ -974,6 +990,17 @@ selects the legacy order."
(should (null (tp-push-layer 1 6 'undefined-x nil t)))
(should (null (text-properties-at 1)))))
(ert-deftest tp-stack-test-noerror-does-not-catch-layer-body-errors ()
"NOERROR suppresses unresolved names, not errors from a resolved body."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp tp-st-a06-boom (_value)
(error "tp-a06 body failure"))
(should-error
(tp-push-layer 1 6 '(tp-st-a06-boom 1) nil t)
:type 'error)
(should-not (text-properties-at 1))))
;;; Multi-argument parameterized specs through tp-put-layer
(ert-deftest tp-stack-test-put-layer-multiarg-layer-flat ()
@ -1260,5 +1287,18 @@ liveness depends on this)."
(kill-buffer buf))))
(tp-layer-reset)))
;;; Stage 2 canonical layer-operation ranges
(ert-deftest tp-stack-test-parser-resolves-canonical-native-object ()
"Layer argument parsing resolves nil to a concrete buffer object."
(with-temp-buffer
(insert "hello")
(pcase-let ((`(,start ,end ,object ,layer)
(tp--parse-layer-args 2 (list 5 'example nil) 1)))
(should (= start 2))
(should (= end 5))
(should (eq object (current-buffer)))
(should (eq layer 'example)))))
(provide 'tp-stack-tests)
;;; tp-stack-tests.el ends here

425
tp-stack.el
View File

@ -43,11 +43,21 @@ 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)))
(let ((range (tp--native-range-from-object
start-or-string 0 (length start-or-string))))
(append (list (tp--native-range-start range)
(tp--native-range-end range)
(tp--native-range-object range))
(seq-take rest n))))
((numberp start-or-string)
(append (list start-or-string (car rest) (nth (1+ n) rest))
(seq-take (cdr rest) n)))
(let* ((operation-args (seq-take (cdr rest) n))
(object (nth (1+ n) rest))
(range (tp--native-range-from-object
object start-or-string (car rest))))
(append (list (tp--native-range-start range)
(tp--native-range-end range)
(tp--native-range-object range))
operation-args)))
(t (error "Invalid layer arguments: %S" (cons start-or-string rest)))))
(defun tp--plist-remove (plist key)
@ -56,6 +66,68 @@ Comparison uses `eq'. PLIST itself is not modified."
(cl-loop for (k v) on plist by #'cddr
unless (eq k key) append (list k v)))
(define-error 'tp-layer-transaction-error "tp layer transaction failed")
(defvar tp--managed-operation-counter 0
"Monotonic counter for managed lifecycle operation ids.")
(defun tp--managed-next-operation-id ()
"Return a fresh managed lifecycle operation id."
(setq tp--managed-operation-counter (1+ tp--managed-operation-counter))
(intern (format "tp-managed-op-%d" tp--managed-operation-counter)))
(defun tp--plist-remove-keys (plist keys)
"Return a copy of PLIST without any key in KEYS."
(cl-loop for (k v) on plist by #'cddr
unless (memq k keys) append (list k v)))
(defun tp--managed-render-props (layer)
"Return LAYER without lifecycle-only storage properties."
(tp--entry-render-projection layer))
(defun tp--managed-public-layer-props (layer)
"Return LAYER's public stack query properties."
(tp--plist-remove-keys layer '(tp-name tp-meta)))
(defun tp--managed-spec-arglist (name)
"Return NAME's parameter arglist when available."
(cond
((and (fboundp 'tp-layer-parameterized-p)
(tp-layer-parameterized-p name))
(tp-layer-arglist name))
((and (fboundp 'tp-group-parameterized-p)
(tp-group-parameterized-p name))
(tp--group-arglist name))))
(defun tp--managed-meta-for-spec (spec layer)
"Build managed metadata for SPEC mounted as LAYER."
(let* ((name (plist-get layer 'tp-name))
(spec-name (if (consp spec) (car spec) spec))
(group-p (and (symbolp spec-name)
(assoc spec-name tp-layer-groups)))
(parameterized-p (and (symbolp spec-name)
(tp--managed-spec-arglist spec-name)))
(args (when (and (consp spec) (or group-p parameterized-p))
(copy-tree (cdr spec))))
(origin (cond
(group-p 'group)
(args 'parameterized)
((assoc name tp-layer-alist) 'defined)
(name 'inline)
(t 'anonymous))))
(tp--managed-entry-meta
name origin spec args (tp--managed-spec-arglist spec-name))))
(defun tp--managed-add-meta-to-layers (spec layers)
"Return LAYERS with managed metadata derived from SPEC."
(mapcar (lambda (layer)
(if (plist-member layer 'tp-meta)
layer
(append layer
(list 'tp-meta
(tp--managed-meta-for-spec spec layer)))))
layers))
(defun tp--stack-map-region (start end object function)
"Call FUNCTION over each property run of [START, END) in OBJECT.
@ -112,7 +184,8 @@ for buffers) and clipped to the requested region."
(equal layer-name
(plist-get props 'tp-name)))
stack)))
(list abs-start abs-end props)))))
(list abs-start abs-end
(tp--plist-remove props 'tp-meta))))))
(defun tp-layer-list (start end &optional object)
"Return list of all layer names in region from START to END."
@ -173,9 +246,345 @@ strings, 1-based for buffers). OBJECT is a string, a buffer, or nil
for the current buffer."
(mapcar (lambda (layer)
(cons (plist-get layer 'tp-name)
(tp--plist-remove layer 'tp-name)))
(tp--managed-public-layer-props layer)))
(tp--stack-props-to-list (text-properties-at pos object))))
;;; Managed lifecycle APIs
(defun tp--managed-layer-names-in-stack (stack)
"Return named managed layers from STACK in stack order."
(let (names)
(dolist (layer stack)
(when-let ((name (plist-get layer 'tp-name)))
(cl-pushnew name names :test #'equal)))
(nreverse names)))
(defun tp--managed-legacy-meta (layer)
"Return safe legacy metadata for LAYER."
(plist-put
(tp--managed-meta-for-spec (plist-get layer 'tp-name) layer)
:legacy-no-args t))
(defun tp--managed-normalize-stack (stack)
"Return STACK with safe legacy managed entries migrated."
(mapcar (lambda (layer)
(if (or (not (plist-get layer 'tp-name))
(plist-member layer 'tp-meta))
layer
(append layer (list 'tp-meta
(tp--managed-legacy-meta layer)))))
stack))
;;;###autoload
(defun tp-attach-managed-layers (start end &optional object)
"Attach managed layer identity in START..END of OBJECT.
The scan is limited to the requested range. Return discovered layer
names in range order."
(let ((found nil))
(tp--stack-map-region
start end object
(lambda (abs-start abs-end stack)
(let ((new-stack (tp--managed-normalize-stack stack)))
(unless (equal new-stack stack)
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
object))
(dolist (name (tp--managed-layer-names-in-stack new-stack))
(cl-pushnew name found :test #'equal)))))
(dolist (name (nreverse found))
(when (or (null object) (bufferp object))
(tp-reactive--register-layer-buffer
name (or object (current-buffer)))))
(nreverse found)))
(defun tp--managed-detached-props (stack keep-rendered)
"Return raw properties for detaching STACK.
When KEEP-RENDERED is non-nil, preserve the current visible
projection without managed storage properties."
(when keep-rendered
(tp--plist-remove
(tp--managed-render-props
(seq-find (lambda (layer)
(not (tp--stack-hidden-p layer)))
stack))
'tp-name)))
;;;###autoload
(defun tp-detach-managed-layers (start end &optional object keep-rendered)
"Detach managed layer storage in START..END of OBJECT.
When KEEP-RENDERED is non-nil, preserve currently visible text
properties after removing lifecycle storage. Return detached layer
names in range order."
(let ((found nil))
(tp--stack-map-region
start end object
(lambda (abs-start abs-end stack)
(when stack
(dolist (name (tp--managed-layer-names-in-stack stack))
(cl-pushnew name found :test #'equal))
(set-text-properties abs-start abs-end
(tp--managed-detached-props
stack keep-rendered)
object))))
(let ((result (nreverse found)))
(when (or (null object) (bufferp object))
(let* ((buffer (or object (current-buffer)))
(remaining (tp-reactive--buffer-layer-names buffer)))
(dolist (name result)
(unless (member name remaining)
(tp-reactive--unregister-layer-buffer name buffer)))))
result)))
(defun tp--managed-layer-entry (start end layer)
"Return a diagnostics entry for LAYER covering START..END."
(let ((meta (plist-get layer 'tp-meta)))
(list :range (cons start end)
:name (plist-get layer 'tp-name)
:entry-id (plist-get meta :entry-id)
:origin (plist-get meta :origin)
:spec (copy-tree (plist-get meta :spec))
:args (copy-tree (plist-get meta :args))
:arglist (copy-tree (plist-get meta :arglist))
:definition-version (plist-get meta :definition-version)
:entry-version (plist-get meta :entry-version)
:hidden (tp--stack-hidden-p layer)
:palette-deps (copy-tree (plist-get meta :palette-deps))
:palette-generation (plist-get meta :palette-generation)
:legacy-no-args (plist-get meta :legacy-no-args))))
(defun tp--managed-buffer-diagnostic-data (buffer layer-filter)
"Collect managed diagnostics in BUFFER for LAYER-FILTER or all layers."
(let ((layers nil)
(entries nil)
(errors nil))
(when (buffer-live-p buffer)
(tp--map-intervals
buffer nil nil
(lambda (start end props)
(condition-case err
(dolist (layer (tp--stack-props-to-list props))
(let ((name (plist-get layer 'tp-name)))
(when (and name
(or (null layer-filter)
(equal name layer-filter)))
(cl-pushnew name layers :test #'equal)
(push (tp--managed-layer-entry start end layer)
entries))))
(error
(push (list :range (cons start end)
:condition err)
errors))))))
(list :buffer buffer
:layers (nreverse layers)
:entries (nreverse entries)
:observer-errors (copy-tree tp-reactive-observer-errors)
:errors (nreverse errors))))
;;;###autoload
(defun tp-managed-layer-diagnostics (layer-name)
"Return read-only managed diagnostics for LAYER-NAME."
(let ((entries nil)
(buffers nil)
(errors nil)
(registered (tp-reactive-layer-buffers layer-name)))
(dolist (buffer (if (eq registered 'unknown)
(buffer-list)
registered))
(when (buffer-live-p buffer)
(let ((diag (tp--managed-buffer-diagnostic-data
buffer layer-name)))
(when (plist-get diag :entries)
(push buffer buffers)
(setq entries (append entries
(plist-get diag :entries))))
(setq errors (append errors (plist-get diag :errors))))))
(list :layer layer-name
:definition-version (tp--layer-definition-version layer-name)
:entries entries
:args (mapcar (lambda (entry)
(plist-get entry :args))
entries)
:registry registered
:buffers (nreverse buffers)
:observer-errors
(cl-remove-if-not
(lambda (entry) (equal (plist-get entry :layer) layer-name))
(copy-tree tp-reactive-observer-errors))
:errors errors)))
;;;###autoload
(defun tp-managed-buffer-diagnostics (&optional buffer)
"Return read-only managed diagnostics for BUFFER."
(tp--managed-buffer-diagnostic-data
(or buffer (current-buffer)) nil))
(defun tp--managed-theme-diagnostics ()
"Return read-only managed theme diagnostics."
(list :generation (if (boundp 'tp-theme-generation)
tp-theme-generation 0)
:last-hook-source (and (boundp 'tp-theme-last-hook-source)
tp-theme-last-hook-source)
:refresh-mode (if (boundp 'tp-theme-last-refresh-mode)
tp-theme-last-refresh-mode :conservative)
:refreshed-ranges
(and (boundp 'tp-theme-last-refreshed-ranges)
tp-theme-last-refreshed-ranges)
:errors (and (boundp 'tp-theme-last-refresh-errors)
tp-theme-last-refresh-errors)))
;;;###autoload
(defun tp-managed-diagnostics ()
"Return read-only global managed lifecycle diagnostics."
(let ((layers nil)
(buffers nil)
(entries nil)
(errors nil))
(dolist (buffer (buffer-list))
(when (buffer-live-p buffer)
(let ((diag (tp--managed-buffer-diagnostic-data buffer nil)))
(when (plist-get diag :entries)
(push buffer buffers)
(setq layers (append layers (plist-get diag :layers)))
(setq entries (append entries
(plist-get diag :entries))))
(setq errors (append errors (plist-get diag :errors))))))
(list :layers (delete-dups layers)
:buffers (nreverse buffers)
:entries entries
:args (mapcar (lambda (entry)
(plist-get entry :args))
entries)
:registry (copy-hash-table tp--layer-buffers)
:observer-errors (copy-tree tp-reactive-observer-errors)
:errors errors
:theme (tp--managed-theme-diagnostics))))
(defun tp--transaction-snapshot (start end object)
"Snapshot exact text and properties in START..END of OBJECT."
(if (stringp object)
(substring object start end)
(let ((buf (or object (current-buffer))))
(with-current-buffer buf
(buffer-substring start end)))))
(defun tp--transaction-restore (start end object snapshot)
"Restore SNAPSHOT over START..END of OBJECT."
(if (stringp object)
(progn
(unless (= (- end start) (length snapshot))
(error "Cannot restore a resized string transaction"))
(store-substring object start (substring-no-properties snapshot))
(set-text-properties start end nil object)
(tp--map-intervals
snapshot 0 (length snapshot)
(lambda (from to props)
(set-text-properties (+ start from) (+ start to) props object))))
(let ((buf (or object (current-buffer))))
(with-current-buffer buf
(let ((inhibit-read-only t))
(delete-region start end)
(goto-char start)
(insert snapshot))))))
(defun tp--transaction-runs (start end object)
"Return exact property intervals for START..END of OBJECT."
(tp-intervals start end object t))
(defun tp--transaction-changed-ranges (before after)
"Return ranges whose text/property intervals differ between BEFORE and AFTER."
(let (ranges)
(cl-loop for b in before
for a in after
unless (equal b a)
do (push (cons (nth 0 (or a b))
(nth 1 (or a b)))
ranges))
(when (/= (length before) (length after))
(dolist (entry (nthcdr (min (length before) (length after))
(append before after)))
(push (cons (nth 0 entry) (nth 1 entry)) ranges)))
(nreverse ranges)))
(defun tp--transaction-live-bounds (from to markers)
"Return the live transaction bounds for FROM, TO, and MARKERS."
(if markers
(cons (marker-position (car markers))
(marker-position (cdr markers)))
(cons from to)))
(defun tp--transaction-result
(status operation-id stage start end object result condition rollback changed)
"Build a structured transaction result plist."
(list :status status
:ok (eq status 'ok)
:result result
:operation-id operation-id
:stage stage
:object object
:range (cons start end)
:current-run (car (tp--transaction-runs start end object))
:layer nil
:entry-id nil
:expected-version nil
:actual-version nil
:expected-properties nil
:actual-properties nil
:original-condition condition
:rollback-applied rollback
:changed-ranges changed))
;;;###autoload
(defun tp-layer-transaction (start end object function &optional noerror)
"Run FUNCTION as a managed layer transaction over START..END of OBJECT.
On success, return a structured plist whose `:result' is FUNCTION's
value. On failure, restore the exact pre-transaction text/property
state. Signal `tp-layer-transaction-error' unless NOERROR is non-nil,
in which case return the structured failure plist."
(let* ((range (tp--native-range-from-object object start end))
(obj (tp--native-range-object range))
(from (tp--native-range-start range))
(to (tp--native-range-end range))
(operation-id (tp--managed-next-operation-id))
(snapshot (tp--transaction-snapshot from to obj))
(before (tp--transaction-runs from to obj))
(markers (unless (stringp obj)
(cons (copy-marker from nil)
(copy-marker to nil)))))
(unwind-protect
(condition-case err
(let* ((result (funcall function))
(live (tp--transaction-live-bounds from to markers)))
(tp--transaction-result
'ok operation-id 'commit from to obj result nil nil
(tp--transaction-changed-ranges
before (tp--transaction-runs
(car live) (cdr live) obj))))
(error
(let* ((live (tp--transaction-live-bounds from to markers))
(rollback-applied nil)
rollback-condition)
(condition-case rollback-err
(progn
(tp--transaction-restore
(car live) (cdr live) obj snapshot)
(setq rollback-applied t))
(error (setq rollback-condition rollback-err)))
(let ((result (tp--transaction-result
'error operation-id 'body from to obj nil err
rollback-applied
(tp--transaction-changed-ranges
before (tp--transaction-runs from to obj)))))
(when rollback-condition
(setq result
(plist-put result :rollback-condition
rollback-condition)))
(if noerror
result
(signal 'tp-layer-transaction-error (list result)))))))
(when markers
(set-marker (car markers) nil)
(set-marker (cdr markers) nil)))))
;;; Layer spec normalization for tp-put-layer
(defun tp--put-layer-specs (layer-spec)
@ -323,9 +732,11 @@ string forms), otherwise the cons (START . END)."
(if noerr
(condition-case nil
(tp--put-layer-specs layer-spec)
(error 'tp--unresolved))
(tp-unresolved-layer 'tp--unresolved))
(tp--put-layer-specs layer-spec))))
(unless (eq layers-to-add 'tp--unresolved)
(setq layers-to-add
(tp--managed-add-meta-to-layers layer-spec layers-to-add))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)

60
tp-tests.el
View File

@ -676,14 +676,15 @@ leak between tests regardless of how BODY exits."
(goto-char 1)
(let ((match (tp-forward 'face)))
(should match)
(should (= (prop-match-end match) 7)))))
(should (= (prop-match-beginning match) 7))
(should (= (prop-match-end match) 12)))))
(ert-deftest tp-test-forward-on-string ()
"Test tp-forward works on string objects."
(let ((str (copy-sequence "Hello World Hello")))
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
(let ((matches (tp-forward 'marker nil str 2)))
(let ((matches (tp-forward 'marker tp-any-value str 2)))
(should (= (length matches) 2))
(should (equal (car matches) '(0 5 t)))
(should (equal (cadr matches) '(12 17 t))))))
@ -697,7 +698,7 @@ leak between tests regardless of how BODY exits."
(tp-set 13 17 '(face bold))
(goto-char 1)
;; Search twice should find third match
(let ((match (tp-forward 'face nil nil 2)))
(let ((match (tp-forward 'face tp-any-value nil 2)))
(should match))))
(ert-deftest tp-test-backward ()
@ -710,19 +711,19 @@ leak between tests regardless of how BODY exits."
(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).
;; Omitting VALUE matches any directly present property value.
(goto-char 12)
(let ((match (tp-backward 'face)))
(should match)
(should (= (prop-match-beginning match) 6)))))
(should (= (prop-match-beginning match) 1))
(should (= (prop-match-end match) 6)))))
(ert-deftest tp-test-backward-on-string ()
"Test tp-backward works on string objects."
(let ((str (copy-sequence "Hello World Hello")))
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
(let ((matches (tp-backward 'marker nil str 2)))
(let ((matches (tp-backward 'marker tp-any-value str 2)))
(should (= (length matches) 2))
;; Backward returns matches in reverse order
(should (equal (car matches) '(12 17 t)))
@ -736,7 +737,7 @@ leak between tests regardless of how BODY exits."
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
;; Search 2 times, function only applied to the last match
(let ((count (tp-forward-do #'upcase 'marker nil str 2)))
(let ((count (tp-forward-do #'upcase 'marker tp-any-value str 2)))
(should (= count 2))
;; First match should NOT be upcased
(should (equal (substring str 0 5) "hello"))
@ -752,7 +753,8 @@ the buffer path) and returns the available count."
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
;; Search only in range 6-17 (after first match)
(let ((count (tp-forward-do #'upcase 'marker nil str 2 6 17)))
(let ((count
(tp-forward-do #'upcase 'marker tp-any-value str 2 6 17)))
(should (= count 1)) ; Only one match in range 6-17
;; First match should NOT be upcased
(should (equal (substring str 0 5) "hello"))
@ -769,9 +771,9 @@ the buffer path) and returns the available count."
;; Function accepts text, start, end
(let ((count (tp-forward-do (lambda (txt start end)
(push start starts)
(push end ends)
(upcase txt))
'marker nil str 2)))
(push end ends)
(upcase txt))
'marker tp-any-value str 2)))
(should (= count 2))
;; Only the last match positions were passed to function
(should (equal starts '(12)))
@ -786,7 +788,7 @@ the buffer path) and returns the available count."
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
;; Use #'upcase which only takes one argument
(tp-forward-do #'upcase 'marker nil str 2)
(tp-forward-do #'upcase 'marker tp-any-value str 2)
;; Only the last match should be upcased
(should (equal (substring str 0 5) "hello"))
(should (equal (substring str 12 17) "HELLO"))))
@ -797,7 +799,8 @@ the buffer path) and returns the available count."
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
;; Search backward 2 times, function only applied to the last match
(let ((count (tp-backward-do #'upcase 'marker nil str 2)))
(let ((count (tp-backward-do
#'upcase 'marker tp-any-value str 2)))
(should (= count 2))
;; Only the last (2nd) match should be upcased (first in order)
(should (equal (substring str 0 5) "HELLO"))
@ -812,7 +815,8 @@ nothing and returns the available count."
(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)))
(let ((count
(tp-backward-do #'upcase 'marker tp-any-value str 2 0 10)))
(should (= count 1)) ; Only one match in range 0-10
;; The requested 2nd match does not exist: nothing is applied
(should (equal (substring str 0 5) "hello"))
@ -830,7 +834,7 @@ nothing and returns the available count."
(push start starts)
(push end ends)
(upcase txt))
'marker nil str 2)))
'marker tp-any-value str 2)))
(should (= count 2))
;; Only the last match positions were passed to function
(should (equal starts '(0)))
@ -845,7 +849,7 @@ nothing and returns the available count."
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
;; Use #'upcase which only takes one argument
(tp-backward-do #'upcase 'marker nil str 2)
(tp-backward-do #'upcase 'marker tp-any-value str 2)
;; Only the last match should be upcased
(should (equal (substring str 0 5) "HELLO"))
(should (equal (substring str 12 17) "hello"))))
@ -891,7 +895,7 @@ nothing and returns the available count."
(tp--search-do
(lambda (match _obj)
(push (car match) result))
'marker nil str)
'marker tp-any-value str)
(should (= (length result) 2))
(should (member 0 result))
(should (member 12 result)))))
@ -906,7 +910,7 @@ nothing and returns the available count."
(tp--search-do
(lambda (match _obj)
(push (car match) result))
'marker nil nil 1 18)
'marker tp-any-value nil 1 18)
(should (= (length result) 2))
(should (member 1 result))
(should (member 13 result)))))
@ -916,7 +920,7 @@ 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)
(let ((count (tp-search-map #'upcase 'marker nil str)))
(let ((count (tp-search-map #'upcase 'marker tp-any-value str)))
(should (= count 2))
;; Check that text was upcased
(should (equal (substring str 0 5) "HELLO"))
@ -928,7 +932,8 @@ nothing and returns the available count."
(insert "hello World hello")
(tp-set 1 6 '(marker t))
(tp-set 13 18 '(marker t))
(let ((count (tp-search-map #'upcase 'marker nil nil 1 18)))
(let ((count
(tp-search-map #'upcase 'marker tp-any-value nil 1 18)))
(should (= count 2))
;; Check that text was upcased
(should (equal (buffer-substring 1 6) "HELLO"))
@ -940,11 +945,11 @@ nothing and returns the available count."
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
;; First upcase the text
(tp-search-map #'upcase 'marker nil str)
(tp-search-map #'upcase 'marker tp-any-value str)
;; Then add face property
(tp-search-map (lambda (txt)
(tp-add txt 'face '(:background "orange")))
'marker nil str)
'marker tp-any-value str)
;; Check text was upcased
(should (equal (substring str 0 5) "HELLO"))
(should (equal (substring str 12 17) "HELLO"))
@ -965,7 +970,7 @@ nothing and returns the available count."
(tp-search-map (lambda (txt start end idx)
(push (list start end idx) positions)
(upcase txt))
'marker nil str)
'marker tp-any-value str)
;; Check positions and indices were passed in order (reversed due to push)
(should (equal (reverse positions) '((0 3 0) (4 7 1) (8 11 2))))
;; Check text was transformed (uppercased)
@ -984,7 +989,7 @@ nothing and returns the available count."
(tp-search-map (lambda (_txt start end idx)
(push (list start end idx) positions)
(format "[%d]" idx))
'marker nil nil 1 12)
'marker tp-any-value nil 1 12)
;; Check positions and indices were passed in order
(should (equal (reverse positions) '((1 4 0) (5 8 1) (9 12 2))))
;; Check text was replaced with index markers
@ -997,7 +1002,7 @@ nothing and returns the available count."
(let ((str (copy-sequence "hello world")))
(tp-set 0 5 '(marker t) str)
;; Use #'upcase which only takes one argument
(tp-search-map #'upcase 'marker nil str)
(tp-search-map #'upcase 'marker tp-any-value str)
(should (equal (substring str 0 5) "HELLO"))))
(ert-deftest tp-test-search-map-with-range ()
@ -1006,7 +1011,8 @@ nothing and returns the available count."
(tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(marker t) str)
;; Only search in range 0-10 (first match only)
(let ((count (tp-search-map #'upcase 'marker nil str 0 10)))
(let ((count
(tp-search-map #'upcase 'marker tp-any-value str 0 10)))
(should (= count 1))
;; First match should be upcased
(should (equal (substring str 0 5) "HELLO"))

2
tp.el
View File

@ -33,6 +33,7 @@
;; tp-render.el Reactive re-rendering engine (installs itself into
;; tp-reactive and tp-ops).
;; tp-stack.el Layer stack operations: push/pop/move/merge/...
;; tp-query.el Native lookup/change wrappers and mutation policy.
;; tp-palette.el Color palette data (light/dark aware).
;; tp-builtins.el Built-in layers (tp-fg, tp-link, tp-action, ...)
;; and display helpers.
@ -55,6 +56,7 @@
(require 'tp-search)
(require 'tp-render)
(require 'tp-stack)
(require 'tp-query)
(require 'tp-palette)
(require 'tp-builtins)