diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..e590ce1 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,56 @@ +name: CI + +on: + push: + branches: [main, 'dev/**'] + pull_request: + branches: [main] + +jobs: + test: + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + emacs_version: ['28.1', '29.4', '30.1'] + steps: + - uses: actions/checkout@v6 + + - uses: purcell/setup-emacs@master + with: + version: ${{ matrix.emacs_version }} + + - name: Install dash from GNU ELPA + run: | + emacs -Q --batch --eval "(progn \ + (require 'package) \ + (setq package-user-dir (expand-file-name \".elpa\")) \ + (add-to-list 'package-archives '(\"gnu\" . \"https://elpa.gnu.org/packages/\")) \ + (package-initialize) \ + (package-refresh-contents) \ + (package-install 'dash))" + # Trailing slash: match only the package directory, not the + # adjacent dash-N.N.N.signed marker GNU ELPA leaves behind. + echo "LOAD_EXTRA=-L $(ls -d "$PWD"/.elpa/dash-*/ | head -1)" >> "$GITHUB_ENV" + + - name: Byte-compile (warnings are errors) + run: make compile-all WERROR=t LOAD_EXTRA="$LOAD_EXTRA" + + - name: ERT suite + run: make test LOAD_EXTRA="$LOAD_EXTRA" + + - name: ERT suite (shuffled order) + run: make test-shuffled LOAD_EXTRA="$LOAD_EXTRA" + + - name: README doctests + run: | + set -o pipefail + make doctest LOAD_EXTRA="$LOAD_EXTRA" 2>&1 | tee doctest.log || { + # Surface failing assertions as annotations (job logs are + # not readable anonymously; annotations are). + grep -E '^(FAIL| expected:| got:)' doctest.log | head -30 \ + | while IFS= read -r l; do echo "::error::${l}"; done + grep -q '^FAIL' doctest.log || tail -n 8 doctest.log \ + | while IFS= read -r l; do echo "::error::${l}"; done + exit 1 + } diff --git a/CHANGELOG.md b/CHANGELOG.md index 8747395..c9ce2ac 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,148 @@ All notable changes to the tp library are documented here. +## 0.3.0 (2026-07-27) + +### Added + +Layer stack: + +- **Layer visibility**: `tp-hide-layer` / `tp-show-layer` — a hidden + layer stays in the stack (and keeps receiving reactive updates) but + does not render; hiding the visible top reveals the next visible + layer, and with every layer hidden the text renders bare. + `tp-flatten-layers` merges only visible layers; `tp-merge-layers` + excludes hidden matched layers' props. +- `tp-lower-layer` (mirror of `tp-raise-layer`) and a + family-consistent `tp-rotate-layer` calling order + `(START END DIRECTION [COUNT] [OBJECT])`, selected unambiguously by + the symbols `up` / `down`; the legacy order keeps working. +- `tp-layer-stack-at` — the full ordered stack at one position as + `(NAME . PROPS)` conses, hidden layers marked by a `tp-hidden` + entry. +- Stack mutators return the number of property runs they modified + (including `tp-merge-layers` / `tp-flatten-layers`), and layer-name + lookups gained optional NOERROR arguments where they previously + signaled. +- `tp-describe-layer` — interactive help-buffer description of a + layer: storage format, arglist, stored body, expanded props, + reactive deps, transform, owning group. + +Reactive engine: + +- **Layer→buffer registry**: reactive updates now visit only the + buffers registered as showing the affected layer instead of scanning + the whole `(buffer-list)`; every buffer-mutating write path + registers (tp-set family, stack mutators, match/regexp appliers), + killed buffers are pruned, and an unknown layer falls back to one + learning full scan. `tp-reactive-layer-buffers` exposes the + registry; `tp-reactive-track-buffer` closes the + insert-a-propertized-string gap. +- **Minimal-diff `tp-text` re-render**: only the differing span is + edited (insert-before-delete), so point and markers in unchanged + text stay put and identical-text updates no longer touch the buffer + at all (buffer-modified flag preserved). +- `tp-gc-anonymous-layers` — collects interned anonymous layers that + no registered live buffer still shows (stack-aware: buried and + hidden layers count as alive; string-only layers are conservatively + kept). + +Search and matching: + +- `tp-regexp-set/reset/add` accept SUBEXP: properties apply to that + capture group per match (non-participating groups contribute + nothing); SUBEXP beyond the pattern's group count signals a clear + error. +- `tp-match-*` / `tp-regexp-*` accept START/END bounds with + as-if-only-that-portion semantics; reversed bounds are swapped. +- `tp-forward` / `tp-backward` / `tp-forward-do` / `tp-backward-do` + accept PREDICATE and NOT-CURRENT, passed through to the + text-property-search machinery; defaults keep the 0.2.0 symmetric + equal-matching contract exactly. + +Layer definitions: + +- **Multi-argument parameterized layers**: `define-tp` / `define-tps` + arglists may declare any number of parameters; + `(LAYER ARG1 ... ARGN)` and wrapped `(LAYER (ARG1 ... ARGN))` specs + work in `tp-set` and `tp-put-layer`; new `tp-layer-props-with-args` + / `tp-group-props-with-args` / `tp-layer-arglist`. Wrong-arity + calls signal clear errors naming the layer and both counts. +- Prefix-conforming aliases `tp-define-layer` / `tp-define-group` / + `tp-define-palette` for discoverability (`C-h f tp-…`). + +Core and palette: + +- `tp-intervals` / `tp-intervals-map` accept an optional ABSOLUTE + argument returning native buffer coordinates (feedable straight + back into `tp-set`); the range-relative default is unchanged. +- `tp-palette-color` (generic theme-resolved accessor) and + `tp-palette-has-p` consolidate the palette query surface; all + existing query functions remain. + +### Fixed + +All six were found by an adversarial architecture/API review of the +new 0.3.0 code and confirmed with minimal reproductions before fixing: + +- The reactive buffer registry only registered `tp-set`-family writes; + layers applied via `tp-push-layer`, `tp-match-set`, etc. never + re-rendered on variable updates. +- Reactive updates wrote only the rendered top layer; hidden or + buried layers kept stale props (visible again on `tp-show-layer`). +- `tp-gc-anonymous-layers` and `tp-reactive-track-buffer` scanned only + direct `tp-name` properties, so a layer buried in a stack (or + hidden) could be wrongly collected / missed. +- `tp-flatten-layers` / `tp-merge-layers` rendered hidden layers' + properties despite `tp-hide-layer`'s documented contract. +- Minimal-diff `tp-text` edits deleted before inserting, so markers at + the suffix boundary drifted to the wrong character. +- An error escaping a reactive update could strand queued batch + entries (now drained under `unwind-protect`; `tp-reactive-reset` + clears the queue). + +### Changed + +- **Module boundaries tightened** (behavior identical under + `(require 'tp)`): the `tp-text` handler chain moved from tp-render + into tp-ops — partial loads now get working `tp-text` replacement — + and `tp-with-batch-updates` moved up into tp-render; two of the four + upward hook variables are gone + (`tp--tp-text-handler-function`, `tp--reactive-flush-function`). + The layer-stack storage codec and the anonymous-layer machinery now + live in tp-layer; tp-stack's phantom dependency on tp-ops is gone; + 67 lines of dead code deleted. tp-core holds no mutable state. +- String forms of all 16 stack mutators document that they modify the + string in place (unlike `tp-set`'s copy semantics); unifying this is + on the 0.4 ledger. + +### Deprecated + +- `tp-search-forward` / `tp-search-backward` (0.3.0) — thin wrappers + whose nil-PREDICATE default contradicts the rest of the library's + equal-matching; use `tp-forward` / `tp-backward`, or the Emacs + primitives for raw access. +- `tp-suffix-symbol` (0.3.0) — internal helper now private as + `tp--suffix-symbol`; a compatibility alias remains. + +### Infrastructure + +- GitHub Actions CI: Emacs 28.1 / 29.4 / 30.1 matrix running + byte-compilation with warnings-as-errors, the full ERT suite, a + shuffled-order rerun of every test (`make test-shuffled`, + `tp-run-shuffled.el`; `SHUFFLE_SEED=N` reproduces an order), and the + README doctests. +- The whole tree byte-compiles with zero warnings (57 fixed: + docstring rewraps and quoting, `defvar` declarations for reactive + test variables, prefixed doctest counters, one impossible `eq` + comparison corrected to `equal`). +- Autoload cookies for the interactive commands (`tp-debug-show`, + `tp-debug-clear`, `tp-reactive-reset`, `tp-layer-reset`, + `tp-palette-show`, `tp-clear`) and the `define-tp` / `define-tps` + macros. +- Two doctest assertions made property-order-insensitive (Emacs 28 + prints text-property plists in a different order than 29+). + ## 0.2.0 (2026-07-26) ### Architecture diff --git a/Makefile b/Makefile index 504c462..8e9c9cf 100644 --- a/Makefile +++ b/Makefile @@ -2,32 +2,48 @@ # # Usage: # make test # run all ERT test suites +# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces) # make doctest # execute README examples against the code -# make compile # byte-compile all modules +# make compile # byte-compile the library modules +# make compile-all # byte-compile modules + tests + dev scripts # make clean # remove compiled files # +# WERROR=t turns byte-compile warnings into errors (used in CI). # If dash.el is not on the default load-path, point LOAD_EXTRA at it: # make test LOAD_EXTRA="-L ~/.emacs.d/elpa/dash-20240510.1327" EMACS ?= emacs LOAD_EXTRA ?= +WERROR ?= nil LOADPATH = -L . $(LOAD_EXTRA) SRC = tp-core.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \ tp-render.el tp-stack.el tp-palette.el tp-builtins.el tp.el TESTS = $(wildcard *-tests.el) +DEV = tp-doctest.el tp-run-shuffled.el -.PHONY: test doctest compile clean +.PHONY: test test-shuffled doctest compile compile-all clean test: $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ -f ert-run-tests-batch-and-exit +test-shuffled: + $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ + -l tp-run-shuffled.el + doctest: $(EMACS) -Q --batch $(LOADPATH) -l tp-doctest.el compile: clean - $(EMACS) -Q --batch $(LOADPATH) -f batch-byte-compile $(SRC) + $(EMACS) -Q --batch $(LOADPATH) \ + --eval "(setq byte-compile-error-on-warn $(WERROR))" \ + -f batch-byte-compile $(SRC) + +compile-all: clean + $(EMACS) -Q --batch $(LOADPATH) \ + --eval "(setq byte-compile-error-on-warn $(WERROR))" \ + -f batch-byte-compile $(SRC) $(TESTS) $(DEV) clean: rm -f *.elc diff --git a/README.md b/README.md index 61f96a9..694d6e7 100644 --- a/README.md +++ b/README.md @@ -62,6 +62,8 @@ - [Property Layer Definition](#property-layer-definition) - [define-tp / define-tps](#define-tp--define-tps---define-custom-text-properties) - [tp-layer-props / tp-group-props](#tp-layer-props--tp-group-props) + - [tp-layer-props-with-args / tp-group-props-with-args / tp-layer-arglist](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) + - [tp-describe-layer](#tp-describe-layer---describe-a-layer) - [tp-undefine-layer / tp-undefine-group](#tp-undefine-layer--tp-undefine-group) - [tp-layer-reset](#tp-layer-reset) - [tp-reactive-reset](#tp-reactive-reset) @@ -74,9 +76,12 @@ - [Property Layer Movement](#property-layer-movement) - [tp-move-layer](#tp-move-layer---move-layer-to-position) - [tp-raise-layer](#tp-raise-layer---move-layer-updown) + - [tp-lower-layer](#tp-lower-layer---mirror-of-tp-raise-layer) - [tp-rotate-layer](#tp-rotate-layer---cycle-layers) - [tp-pin-layer](#tp-pin-layer---pin-layer-to-top) - [tp-switch-layer](#tp-switch-layer---switch-two-layers) + - [Property Layer Visibility](#property-layer-visibility) + - [tp-hide-layer / tp-show-layer](#tp-hide-layer--tp-show-layer---hide-and-show-layers) - [Property Layer Merging](#property-layer-merging) - [tp-merge-layers](#tp-merge-layers---merge-multiple-layers) - [tp-flatten-layers](#tp-flatten-layers---flatten-all-layers) @@ -85,6 +90,7 @@ - [tp-layer-count](#tp-layer-count) - [tp-layer-exists-p](#tp-layer-exists-p) - [tp-layer-top](#tp-layer-top) + - [tp-layer-stack-at](#tp-layer-stack-at---full-stack-at-a-position) - [tp-add-to-layers](#tp-add-to-layers---add-properties-to-specific-layers) - [tp-add-to-all-layers](#tp-add-to-all-layers---add-properties-to-all-layers) - [Utility Functions](#utility-functions) @@ -107,6 +113,7 @@ - [Layer Name Resolution in APIs](#layer-name-resolution-in-apis) - [Reactive Layer Groups](#reactive-layer-groups) - [Batched Updates](#batched-updates) + - [Layer-Buffer Registry & Lifecycle](#layer-buffer-registry--lifecycle) - [Debug Mode](#debug-mode) - [Resetting Reactive State](#resetting-reactive-state) - [Complete Example: Theme-Aware Text](#complete-example-theme-aware-text) @@ -185,6 +192,43 @@ Native Emacs APIs have different functions and parameter orders for strings and ``` - ✅ **Unified Object Support**: The same function works with both strings and buffers, no need to remember different APIs +**One rule to remember**: when the first argument is a **string**, the call +operates on that whole string; when it is a **number**, the call operates on +the `[START, END)` region of OBJECT — and OBJECT always comes last (nil means +the current buffer). Every core and layer-stack function follows this rule. + +The match/search family (`tp-match-*`, `tp-regexp-*`, `tp-search-map`, +`tp-forward-do`/`tp-backward-do`) follows a deliberate **second convention**: +PATTERN (or FUNCTION) and PLIST come first, then OBJECT, then the optional +START/END bounds. Operating on the whole object is these functions' common +case, so OBJECT sits before the range instead of after it. + +**Return value conventions** (as of 0.3.0): + +| Family | Return value | +|---|---| +| `tp-set` / `tp-reset` / `tp-add` | `(START . END)` for buffer/region forms; a **new** string for whole-string forms | +| `tp-remove` | nil for buffer forms; a **new** string for whole-string forms | +| `tp-clear` | nil | +| `tp-match-*` / `tp-regexp-*` | list of `(START . END)` matches for buffers; a **new** string for strings | +| Stack mutators (delete/pop/move/raise/lower/rotate/pin/switch/hide/show/merge/flatten) | the number of property runs modified (0 = nothing matched) | +| `tp-put-layer` / `tp-push-layer` | OBJECT when given (the string itself in string forms), else `(START . END)` | +| `tp-add-to-layers` / `tp-add-to-all-layers` | the string itself (mutated **in place**) for string forms; nil for buffers | + +**Namespace map**: `tp-layer-NAME` functions taking a *layer name* argument +(`tp-layer-props`, `tp-layer-arglist`, ...) query the layer **registry** +(definitions); the ones taking *position* arguments — START END +(`tp-layer-list`, `tp-layer-count`, `tp-layer-top`, ...) or a single POS +(`tp-layer-stack-at`) — query the layer **stack on actual text**. + +**Naming conventions**: `tp-define-layer` / `tp-define-group` / +`tp-define-palette` are the prefix-conforming canonical names going forward +(discoverable via `C-h f tp-...`); `define-tp` / `define-tps` / +`define-tp-group` / `define-tp-palette` are permanent aliases that will never +be removed (this README's examples still use the historical names). +`tp-search-forward` / `tp-search-backward` are deprecated since 0.3.0 — see +[Search & Navigation](#tp-search-forward--tp-search-backward). + ### Three Property Operation Semantics Native APIs only have simple set and get. tp.el provides three clear operation semantics: @@ -255,9 +299,10 @@ Native APIs only have simple set and get. tp.el provides three clear operation s - ✅ **Rich Property Layer Operations**: - Placement: `tp-put-layer` (specific position), `tp-push-layer` (top) - Deletion: `tp-delete-layer` (by name/index), `tp-pop-layer` (top layer) - - Movement: `tp-raise-layer` (up/down), `tp-rotate-layer` (rotate), `tp-pin-layer` (pin to top), `tp-switch-layer` (swap) + - Movement: `tp-raise-layer` / `tp-lower-layer` (up/down), `tp-rotate-layer` (rotate), `tp-pin-layer` (one-shot move to top), `tp-switch-layer` (swap) + - Visibility: `tp-hide-layer` / `tp-show-layer` (hide a layer without removing it) - Merging: `tp-merge-layers` (merge specified layers), `tp-flatten-layers` (flatten all layers) -- ✅ **Property Layer Queries**: `tp-layer-list`, `tp-layer-count`, `tp-layer-exists-p`, `tp-layer-top` +- ✅ **Property Layer Queries**: `tp-layer-list`, `tp-layer-count`, `tp-layer-exists-p`, `tp-layer-top`, `tp-layer-stack-at` ```elisp ;; Property layer usage example @@ -300,6 +345,7 @@ Native APIs require manual searching and looping. tp.el provides convenient patt - ✅ **:data for Additional State**: Define additional reactive variables that aren't directly used in properties but can trigger updates - ✅ **:compute for Derived Values**: Create computed properties that derive their values from other reactive variables (like Vue's computed properties) - ✅ **:watch for Side Effects**: Execute callbacks when reactive variables change (like Vue's watch) +- ✅ **Targeted Updates (0.3.0)**: a layer→buffer registry means updates visit only the buffers showing the affected layer, `tp-text` re-renders edit only the differing span (point and markers stay put), and `tp-reactive-track-buffer` / `tp-gc-anonymous-layers` manage the layer lifecycle — see [Layer-Buffer Registry & Lifecycle](#layer-buffer-registry--lifecycle) ```elisp ;; Define a layer with reactive properties @@ -327,8 +373,8 @@ Native APIs require manual searching and looping. tp.el provides convenient patt ### Enhanced Search & Navigation - ✅ **Range Search**: `tp-search` returns a list of all matching intervals -- ✅ **N-times Search**: `tp-forward`/`tp-backward` support searching forward/backward N times -- ✅ **Search and Execute**: `tp-forward-do`/`tp-backward-do` search and execute function on matched text +- ✅ **N-times Search**: `tp-forward`/`tp-backward` support searching forward/backward N times, with optional PREDICATE matching and NOT-CURRENT +- ✅ **Search and Execute**: `tp-forward-do`/`tp-backward-do` search N times and apply a function at the Nth match - ✅ **Batch Transform**: `tp-search-map` applies transformation function to all matches ```elisp @@ -405,32 +451,37 @@ A complete overview of all tp.el functions organized by category: #### Pattern Matching Functions | Function | Description | |----------|-------------| -| [`tp-match-set`](#tp-match-set---match-string) | Set properties on string pattern matches | -| [`tp-match-reset`](#tp-match-reset---match-and-reset) | Reset all properties on string matches | -| [`tp-match-add`](#tp-match-add---match-and-add) | Add/merge properties on string matches | -| [`tp-regexp-set`](#tp-regexp-set---match-regexp) | Set properties on regexp matches | -| [`tp-regexp-reset`](#tp-regexp-reset---regexp-and-reset) | Reset all properties on regexp matches | -| [`tp-regexp-add`](#tp-regexp-add---regexp-and-add) | Add/merge properties on regexp matches | +| [`tp-match-set`](#tp-match-set---match-string) | Set properties on string pattern matches (optional bounds) | +| [`tp-match-reset`](#tp-match-reset---match-and-reset) | Reset all properties on string matches (optional bounds) | +| [`tp-match-add`](#tp-match-add---match-and-add) | Add/merge properties on string matches (optional bounds) | +| [`tp-regexp-set`](#tp-regexp-set---match-regexp) | Set properties on regexp matches (optional bounds and capture group) | +| [`tp-regexp-reset`](#tp-regexp-reset---regexp-and-reset) | Reset all properties on regexp matches (optional bounds and capture group) | +| [`tp-regexp-add`](#tp-regexp-add---regexp-and-add) | Add/merge properties on regexp matches (optional bounds and capture group) | #### Search & Navigation Functions | Function | Description | |----------|-------------| -| [`tp-search-forward`](#tp-search-forward--tp-search-backward) | Raw wrapper for text-property-search-forward | -| [`tp-search-backward`](#tp-search-forward--tp-search-backward) | Raw wrapper for text-property-search-backward | -| [`tp-forward`](#tp-forward--tp-backward) | Search forward N times for text with property (buffers and strings) | -| [`tp-backward`](#tp-forward--tp-backward) | Search backward N times for text with property (buffers and strings) | -| [`tp-forward-do`](#tp-forward-do--tp-backward-do) | Apply function to last match in forward search (with optional start/end range) | -| [`tp-backward-do`](#tp-forward-do--tp-backward-do) | Apply function to last match in backward search (with optional start/end range) | +| [`tp-search-forward`](#tp-search-forward--tp-search-backward) | **Deprecated (0.3.0)** — use [`tp-forward`](#tp-forward--tp-backward) or the Emacs primitive | +| [`tp-search-backward`](#tp-search-forward--tp-search-backward) | **Deprecated (0.3.0)** — use [`tp-backward`](#tp-forward--tp-backward) or the Emacs primitive | +| [`tp-forward`](#tp-forward--tp-backward) | Search forward N times for text with property (optional predicate matching) | +| [`tp-backward`](#tp-forward--tp-backward) | Search backward N times for text with property (optional predicate matching) | +| [`tp-forward-do`](#tp-forward-do--tp-backward-do) | Search forward N times, apply function at the Nth match | +| [`tp-backward-do`](#tp-forward-do--tp-backward-do) | Search backward N times, apply function at the Nth match | | [`tp-search`](#tp-search---search-all-matches) | Search all matching properties in range or string | | [`tp-search-map`](#tp-search-map---apply-function-to-matched-text) | Apply function to all matches (with optional start/end range) | #### Property Layer Definition Functions | Function | Description | |----------|-------------| -| [`define-tp`](#define-tp--define-tps---define-custom-text-properties) | Define custom text property (layer) with optional parameter | -| [`define-tps`](#define-tp--define-tps---define-custom-text-properties) | Define custom text property group (layer group) with optional parameter | +| [`define-tp`](#define-tp--define-tps---define-custom-text-properties) | Define custom text property (layer) with optional parameters | +| [`define-tps`](#define-tp--define-tps---define-custom-text-properties) | Define custom text property group (layer group) with optional parameters | +| [`tp-define-layer` / `tp-define-group`](#define-tp--define-tps---define-custom-text-properties) | Prefix-conforming aliases of `define-tp` / `define-tps` | | [`tp-layer-props`](#tp-layer-props--tp-group-props) | Get properties for a layer | | [`tp-group-props`](#tp-layer-props--tp-group-props) | Get properties for all layers in a group | +| [`tp-layer-props-with-args`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | Expand a parameterized layer with a list of arguments | +| [`tp-group-props-with-args`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | Expand a parameterized group with a list of arguments | +| [`tp-layer-arglist`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | Get a parameterized layer's parameter list | +| [`tp-describe-layer`](#tp-describe-layer---describe-a-layer) | Describe a layer's definition in a help buffer | | [`tp-undefine-layer`](#tp-undefine-layer--tp-undefine-group) | Remove layer definition | | [`tp-undefine-group`](#tp-undefine-layer--tp-undefine-group) | Remove group definition | | [`tp-layer-reset`](#tp-layer-reset) | Clear all layer/group definitions | @@ -439,8 +490,8 @@ A complete overview of all tp.el functions organized by category: #### Property Layer Placement Functions | Function | Description | |----------|-------------| -| [`tp-put-layer`](#tp-put-layer---set-layer-at-index) | Set layer at specific index position | -| [`tp-push-layer`](#tp-push-layer---push-layer-to-top) | Push layer to top of stack | +| [`tp-put-layer`](#tp-put-layer---set-layer-at-index) | Set layer at specific index position (optional NOERROR) | +| [`tp-push-layer`](#tp-push-layer---push-layer-to-top) | Push layer to top of stack (optional NOERROR) | #### Property Layer Deletion Functions | Function | Description | @@ -453,15 +504,22 @@ A complete overview of all tp.el functions organized by category: |----------|-------------| | [`tp-move-layer`](#tp-move-layer---move-layer-to-position) | Move a layer from one position to another | | [`tp-raise-layer`](#tp-raise-layer---move-layer-updown) | Move layer up/down by N positions | -| [`tp-rotate-layer`](#tp-rotate-layer---cycle-layers) | Cycle layers (top goes to bottom) | -| [`tp-pin-layer`](#tp-pin-layer---pin-layer-to-top) | Pin a layer to top (make visible) | +| [`tp-lower-layer`](#tp-lower-layer---mirror-of-tp-raise-layer) | Mirror of `tp-raise-layer`: move layer down/up by N positions | +| [`tp-rotate-layer`](#tp-rotate-layer---cycle-layers) | Cycle layers up or down by N steps | +| [`tp-pin-layer`](#tp-pin-layer---pin-layer-to-top) | Move a layer to the top (one-shot; later pushes can cover it) | | [`tp-switch-layer`](#tp-switch-layer---switch-two-layers) | Swap positions of two layers | +#### Property Layer Visibility Functions +| Function | Description | +|----------|-------------| +| [`tp-hide-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers) | Hide a layer without removing it from the stack | +| [`tp-show-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers) | Make a hidden layer render again | + #### Property Layer Merging Functions | Function | Description | |----------|-------------| -| [`tp-merge-layers`](#tp-merge-layers---merge-multiple-layers) | Merge specified layers into a new layer | -| [`tp-flatten-layers`](#tp-flatten-layers---flatten-all-layers) | Flatten all layers into a single layer | +| [`tp-merge-layers`](#tp-merge-layers---merge-multiple-layers) | Merge specified layers into a new layer (hidden layers contribute no props) | +| [`tp-flatten-layers`](#tp-flatten-layers---flatten-all-layers) | Flatten all layers into a single layer (hidden layers are discarded) | #### Property Layer Query Functions | Function | Description | @@ -469,7 +527,8 @@ A complete overview of all tp.el functions organized by category: | [`tp-layer-list`](#tp-layer-list---list-all-layers) | List all layer names in region | | [`tp-layer-count`](#tp-layer-count) | Count layers in region | | [`tp-layer-exists-p`](#tp-layer-exists-p) | Check if layer exists in region | -| [`tp-layer-top`](#tp-layer-top) | Get name of top (visible) layer | +| [`tp-layer-top`](#tp-layer-top) | Get name of top layer (in stack order, even when hidden) | +| [`tp-layer-stack-at`](#tp-layer-stack-at---full-stack-at-a-position) | Full ordered stack at one position as `(NAME . PROPS)` conses | | [`tp-region-layer-props`](#tp-region-layer-props---get-layer-properties-in-region) | Get properties for a specific layer in region | #### Property Layer Manipulation Functions @@ -481,8 +540,8 @@ A complete overview of all tp.el functions organized by category: #### Utility Functions | Function | Description | |----------|-------------| -| [`tp-intervals`](#tp-intervals---get-text-property-intervals) | Get all text property intervals in a region | -| [`tp-intervals-map`](#tp-intervals-map---apply-function-to-intervals) | Apply function to all intervals in a region | +| [`tp-intervals`](#tp-intervals---get-text-property-intervals) | Get all text property intervals in a region (optional ABSOLUTE coordinates) | +| [`tp-intervals-map`](#tp-intervals-map---apply-function-to-intervals) | Apply function to all intervals in a region (optional ABSOLUTE coordinates) | | [`tp-plist`](#tp-plist---get-all-properties-in-region) | Get all properties present in a region | | [`tp-empty-p`](#tp-empty-p---check-if-object-has-properties) | Check if object has no text properties | | [`tp-with-current-buffer`](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer) | Run body in a buffer with `inhibit-read-only` bound | @@ -493,10 +552,20 @@ A complete overview of all tp.el functions organized by category: | Function | Description | |----------|-------------| | [`tp-palette-alist`](#color-palette-system) | Registry of named palettes (variable) | -| [`define-tp-palette`](#color-palette-system) | Register or update a named palette | +| [`define-tp-palette`](#color-palette-system) | Register or update a named palette (alias: `tp-define-palette`) | +| [`tp-palette-color`](#color-palette-system) | Get a palette's `:fg` / `:bg` / `:border` color, theme-resolved | +| [`tp-palette-has-p`](#color-palette-system) | Test whether a palette (or one of its keys) is defined | | [`tp-palette-show`](#color-palette-system) | Show a gallery of all registered palettes | | [`tp-parse-color`](#color-palette-system) | Resolve a color spec for the current light/dark theme | +#### Reactive Lifecycle Functions +| Function | Description | +|----------|-------------| +| [`tp-with-batch-updates`](#batched-updates) | Apply several reactive variable changes as one update | +| [`tp-reactive-layer-buffers`](#layer-buffer-registry--lifecycle) | Buffers registered as showing a layer (or `unknown`) | +| [`tp-reactive-track-buffer`](#layer-buffer-registry--lifecycle) | Register a buffer after inserting an already-propertized string | +| [`tp-gc-anonymous-layers`](#layer-buffer-registry--lifecycle) | Collect anonymous layers no registered live buffer still shows | + --- ### Core Property Functions @@ -597,6 +666,8 @@ LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a grou :data '((my-color . "blue"))) (tp-set " " 'my-style) ;; => #(" " 0 1 (face (:foreground "blue") tp-name my-style)) +;; (the printed ORDER of properties may differ across Emacs +;; versions; the values are identical) ;; Merge multiple faces in a single call (duplicate properties auto-merged) (tp-set "emacs" @@ -994,7 +1065,7 @@ Remove a property or nested sub-property from a region or entire string. (tp-clear &optional START END OBJECT) ``` -Clear all text properties from a region. +Clear all text properties from a region. Returns nil. **Examples:** @@ -1023,8 +1094,8 @@ Clear all text properties from a region. #### `tp-match-set` - Match String ```elisp -(tp-match-set PATTERN PLIST &optional OBJECT) -(tp-match-set PATTERN LAYER-NAME &optional OBJECT) +(tp-match-set PATTERN PLIST &optional OBJECT START END) +(tp-match-set PATTERN LAYER-NAME &optional OBJECT START END) ``` Set properties on all occurrences of a string pattern. @@ -1032,6 +1103,11 @@ PATTERN can be a string (single pattern) or a list of strings (multiple patterns PLIST is a property list like `'(face bold help-echo "tip")`. LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`. OBJECT is a buffer or string; nil means current buffer. +START and END (new in 0.3.0) restrict matching to the `[START, END)` portion +of OBJECT, in native coordinates (0-based for strings, 1-based for buffers). +Matching behaves **as if OBJECT consisted only of that portion**, so no match +crosses the boundaries; reversed bounds are swapped. The same bounds are +accepted by all six `tp-match-*` / `tp-regexp-*` functions. **Examples:** @@ -1064,6 +1140,12 @@ OBJECT is a buffer or string; nil means current buffer. (insert "TODO: fix this. TODO: also this.") (tp-match-set "TODO" 'todo-style)) ;; => ((1 . 5) (17 . 21)) + +;; Restrict matching with START/END bounds - only the second TODO is in range +(with-temp-buffer + (insert "TODO one TODO two") + (tp-match-set "TODO" '(face warning) nil 5 18)) +;; => ((10 . 14)) ``` --- @@ -1077,10 +1159,13 @@ LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a grou OBJECT is a buffer or string; nil means current buffer. ```elisp -(tp-match-reset PATTERN PLIST &optional OBJECT) -(tp-match-reset PATTERN LAYER-NAME &optional OBJECT) +(tp-match-reset PATTERN PLIST &optional OBJECT START END) +(tp-match-reset PATTERN LAYER-NAME &optional OBJECT START END) ``` +START and END restrict matching to the `[START, END)` portion of OBJECT +(see [`tp-match-set`](#tp-match-set---match-string)). + **Examples:** ```elisp @@ -1118,10 +1203,13 @@ LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a grou OBJECT is a buffer or string; nil means current buffer. ```elisp -(tp-match-add PATTERN PLIST &optional OBJECT) -(tp-match-add PATTERN LAYER-NAME &optional OBJECT) +(tp-match-add PATTERN PLIST &optional OBJECT START END) +(tp-match-add PATTERN LAYER-NAME &optional OBJECT START END) ``` +START and END restrict matching to the `[START, END)` portion of OBJECT +(see [`tp-match-set`](#tp-match-set---match-string)). + **Examples:** ```elisp @@ -1153,8 +1241,8 @@ OBJECT is a buffer or string; nil means current buffer. #### `tp-regexp-set` - Match Regexp ```elisp -(tp-regexp-set PATTERN PLIST &optional OBJECT) -(tp-regexp-set PATTERN LAYER-NAME &optional OBJECT) +(tp-regexp-set PATTERN PLIST &optional OBJECT START END SUBEXP) +(tp-regexp-set PATTERN LAYER-NAME &optional OBJECT START END SUBEXP) ``` Set properties on all matches of a regular expression. @@ -1162,6 +1250,15 @@ PATTERN can be a string (single regexp) or a list of strings (multiple regexps). PLIST is a property list like `'(face bold help-echo "tip")`. LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a group defined by `define-tps`. OBJECT is a buffer or string; nil means current buffer. +START and END (new in 0.3.0) restrict matching to the `[START, END)` portion +of OBJECT, in native coordinates; matching behaves as if OBJECT consisted +only of that portion, and reversed bounds are swapped +(see [`tp-match-set`](#tp-match-set---match-string)). +SUBEXP (new in 0.3.0) names a capture group of PATTERN (1 = first group, as +in font-lock highlights): properties apply to that group of each match +instead of the whole match. A match in which the group does not participate +contributes nothing; a SUBEXP beyond the pattern's group count signals a +clear error. All three `tp-regexp-*` functions accept SUBEXP. **Examples:** @@ -1190,6 +1287,28 @@ OBJECT is a buffer or string; nil means current buffer. (insert "abc 123 def 456") (tp-regexp-set "[0-9]+" 'number-style)) ;; => ((5 . 8) (13 . 16)) + +;; SUBEXP - propertize only capture group 1 of each match +(tp-regexp-set "\\([0-9]+\\)px" '(face bold) "margin: 10px 4px" nil nil 1) +;; => #("margin: 10px 4px" 8 10 (face bold) 13 14 (face bold)) + +;; A match whose group does not participate contributes nothing: +;; "bar" matches the pattern, but group 1 only participates in "foo" +(tp-regexp-set "\\(foo\\)\\|bar" '(face bold) "foo bar" nil nil 1) +;; => #("foo bar" 0 3 (face bold)) + +;; SUBEXP beyond the pattern's group count signals a clear error +(tp-regexp-set "[0-9]+" '(face bold) "abc 123" nil nil 2) +;; error: Regexp "[0-9]+" has no group 2 + +;; START/END bounds: as if only that portion existed - the greedy a+ +;; matches exactly [1, 3) instead of the whole run +(tp-regexp-set "a+" '(face bold) "aaaa" 1 3) +;; => #("aaaa" 1 3 (face bold)) + +;; Reversed bounds are swapped +(tp-regexp-set "a+" '(face bold) "aaaa" 3 1) +;; => #("aaaa" 1 3 (face bold)) ``` --- @@ -1203,10 +1322,13 @@ LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a grou OBJECT is a buffer or string; nil means current buffer. ```elisp -(tp-regexp-reset PATTERN PLIST &optional OBJECT) -(tp-regexp-reset PATTERN LAYER-NAME &optional OBJECT) +(tp-regexp-reset PATTERN PLIST &optional OBJECT START END SUBEXP) +(tp-regexp-reset PATTERN LAYER-NAME &optional OBJECT START END SUBEXP) ``` +START/END bounds and the SUBEXP capture group work exactly as in +[`tp-regexp-set`](#tp-regexp-set---match-regexp). + **Examples:** ```elisp @@ -1245,10 +1367,13 @@ LAYER-NAME can be a symbol representing a layer defined by `define-tp` or a grou OBJECT is a buffer or string; nil means current buffer. ```elisp -(tp-regexp-add PATTERN PLIST &optional OBJECT) -(tp-regexp-add PATTERN LAYER-NAME &optional OBJECT) +(tp-regexp-add PATTERN PLIST &optional OBJECT START END SUBEXP) +(tp-regexp-add PATTERN LAYER-NAME &optional OBJECT START END SUBEXP) ``` +START/END bounds and the SUBEXP capture group work exactly as in +[`tp-regexp-set`](#tp-regexp-set---match-regexp). + **Examples:** ```elisp @@ -1282,21 +1407,28 @@ OBJECT is a buffer or string; nil means current buffer. #### `tp-search-forward` / `tp-search-backward` -```elisp -(tp-search-forward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) -(tp-search-backward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) -``` +> ⚠️ **Deprecated since 0.3.0.** These are raw wrappers for Emacs's +> `text-property-search-forward` / `text-property-search-backward` whose +> nil-PREDICATE default (match values that are non-nil and **not** `equal` +> to VALUE) contradicts the `equal`-matching used by the rest of the +> library. Use [`tp-forward` / `tp-backward`](#tp-forward--tp-backward) +> for tp's symmetric `equal`-matching search — they now expose PREDICATE +> and NOT-CURRENT too — or call the Emacs primitives directly for raw +> access. The wrappers keep working, but are marked obsolete (the byte +> compiler warns on new callers). -Raw wrappers for Emacs's `text-property-search-forward` and `text-property-search-backward`. -These are low-level search functions that work directly with prop-match objects. +```elisp +(tp-search-forward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) ; deprecated +(tp-search-backward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) ; deprecated +``` --- #### `tp-forward` / `tp-backward` ```elisp -(tp-forward PROPERTY &optional VALUE OBJECT N) -(tp-backward PROPERTY &optional VALUE OBJECT N) +(tp-forward PROPERTY &optional VALUE OBJECT N PREDICATE NOT-CURRENT) +(tp-backward PROPERTY &optional VALUE OBJECT N PREDICATE NOT-CURRENT) ``` Search forward/backward N times for text with PROPERTY. @@ -1308,10 +1440,16 @@ Search forward/backward N times for text with PROPERTY. - **`tp-backward` mirrors `tp-forward`**: the same equal-matching semantics, in the opposite direction. - **OBJECT** can be a buffer or string; nil defaults to current buffer. +- **PREDICATE** (new in 0.3.0) customizes matching: nil (the default) and t + both keep the 0.2.0 `equal`-matching contract **exactly**; a function is + called with `(VALUE PROP-VALUE)` and matches when it returns non-nil. +- **NOT-CURRENT** (new in 0.3.0), when non-nil, skips a matching region + containing point, mirroring the `text-property-search-*` primitives. + Buffer path only; strings have no point, so it is ignored there. - For buffers, returns the prop-match object from the last successful search. -- For strings, returns a list of (START END VALUE) for runs where PROPERTY - is present; VALUE nil means any value. `tp-backward` returns them from - end to start. +- 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. **Examples:** @@ -1360,6 +1498,38 @@ Search forward/backward N times for text with PROPERTY. (tp-set 12 17 '(marker t) my-string) (tp-forward 'marker nil my-string 2)) ;; => ((0 5 t) (12 17 t)) + +;; PREDICATE - match with a custom function instead of `equal' +;; (called with VALUE and the region's property value) +(with-temp-buffer + (insert "abcdef") + (tp-set 1 3 '(size 10)) + (tp-set 3 6 '(size 20)) + (goto-char 1) + (let ((match (tp-forward 'size 15 nil 1 + (lambda (target v) (and v (> v target)))))) + (list (prop-match-beginning match) (prop-match-end match)))) +;; => (3 6) ; the first run whose size exceeds 15 + +;; PREDICATE works on strings too (returns the first N matching runs) +(let ((str (copy-sequence "hello world"))) + (tp-set 0 5 '(size 10) str) + (tp-set 6 11 '(size 20) str) + (tp-forward 'size 15 str 2 (lambda (target v) (and v (> v target))))) +;; => ((6 11 20)) + +;; NOT-CURRENT - skip the matching region containing point +(with-temp-buffer + (insert "one two") + (tp-set 1 4 '(mark t)) + (tp-set 5 8 '(mark t)) + (let (a b) + (goto-char 2) ; inside the first mark region + (setq a (prop-match-beginning (tp-forward 'mark t))) + (goto-char 2) + (setq b (prop-match-beginning (tp-forward 'mark t nil 1 nil t))) + (list a b))) +;; => (2 5) ; without NOT-CURRENT the current region matches at point ``` --- @@ -1367,11 +1537,15 @@ Search forward/backward N times for text with PROPERTY. #### `tp-forward-do` / `tp-backward-do` ```elisp -(tp-forward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END) -(tp-backward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END) +(tp-forward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END PREDICATE NOT-CURRENT) +(tp-backward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END PREDICATE NOT-CURRENT) ``` -Search forward/backward for text with PROPERTY and apply FUNCTION **only to the last match**. +Search forward/backward TIMES times for text with PROPERTY and apply FUNCTION **only at the TIMES-th match**. + +Despite the `-do` suffix this is **not** a for-each — use +[`tp-search-map`](#tp-search-map---apply-function-to-matched-text) to apply +a function to *every* match. - **FUNCTION** receives `(TEXT &optional START END IDX)` where TEXT is the matched text, START and END are the positions of the match, and IDX is the 0-based match index. FUNCTION is called with as many of these arguments as it accepts. When FUNCTION returns a string, it replaces the matched text in the string or buffer. - **Replacements may change length in buffers** (the match is deleted and the replacement inserted). **Strings cannot change length in place**: a replacement of a different length signals an error; same-length replacements are applied in place. @@ -1380,6 +1554,9 @@ Search forward/backward for text with PROPERTY and apply FUNCTION **only to the - **OBJECT** can be a buffer or string; nil defaults to current buffer. - **TIMES** is the number of searches, defaulting to 1. The function searches TIMES times but only applies FUNCTION to the TIMES-th match. All-or-nothing: if fewer than TIMES matches exist, FUNCTION is not applied at all and the number of available matches is returned. - **START** and **END** define the search range; defaults are object start and end. +- **PREDICATE** and **NOT-CURRENT** (new in 0.3.0) work as in + [`tp-forward` / `tp-backward`](#tp-forward--tp-backward) and are applied + to each underlying search; the defaults keep the 0.2.0 behavior exactly. - Returns the number of successful matches. **Examples:** @@ -1399,7 +1576,9 @@ Search forward/backward for text with PROPERTY and apply FUNCTION **only to the (tp-set 12 17 '(marker t) my-string) (tp-forward-do #'upcase 'marker nil my-string 2 6 17) my-string) -;; => "hello world HELLO" ; Only 1 match in range 6-17 +;; => "hello world hello" ; only 1 match in range 6-17, so the +;; requested 2nd match does not exist: nothing is applied +;; (all-or-nothing; the call still returns the count, 1) ;; Using function with start and end parameters ;; The function receives position info; use upcase to keep same length @@ -1639,9 +1818,16 @@ Text property layers is a **unique feature** of tp.el that requires specific fun #### `define-tp` / `define-tps` - Define Custom Text Properties +> Since 0.3.0 the prefix-conforming aliases `tp-define-layer` (for +> `define-tp`), `tp-define-group` (for `define-tps`) and +> `tp-define-palette` (for `define-tp-palette`) are the canonical names +> going forward — they make the macros discoverable via `C-h f tp-...`. +> The historical names are permanent aliases and will never be removed; +> this README's examples keep using them. + ##### `define-tp` - Define Single Custom Text Property (Layer) -Define a custom text property. The name does not need to be quoted. The ARGLIST is **mandatory in every format**: `()` for non-parameterized layers (including the reactive keyword format), `(ARG)` for parameterized layers. Supports three formats: +Define a custom text property. The name does not need to be quoted. The ARGLIST is **mandatory in every format**: `()` for non-parameterized layers (including the reactive keyword format), `(ARG1 ARG2 ...)` with any number of parameter symbols for parameterized layers. Supports three formats: **Format 1 - Non-parameterized (empty argument list, simple properties):** @@ -1654,7 +1840,7 @@ Define a custom text property. The name does not need to be quoted. The ARGLIST (tp-set 0 5 '(tp-bold t) "emacs") ``` -**Format 2 - Parameterized (with single argument):** +**Format 2 - Parameterized (with one or more arguments):** ```elisp (define-tp tp-space (pixel) @@ -1665,6 +1851,43 @@ Define a custom text property. The name does not need to be quoted. The ARGLIST (tp-set 0 5 '(tp-space 2) "emacs") ``` +Since 0.3.0 the arglist may declare **any number of parameters**. The call +specs accept the arguments flat — `(LAYER ARG1 ... ARGN)` — or wrapped in +one list — `(LAYER (ARG1 ... ARGN))` — and both work in `tp-set` and +`tp-put-layer`: + +```elisp +(define-tp tp-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + +;; Whole-string form: arguments follow the layer name +(tp-set "hello" 'tp-colors "red" "blue") +;; => #("hello" 0 5 (face (:foreground "red" :background "blue"))) + +;; Region form, wrapped argument list plus extra properties +(let ((str (copy-sequence "hello"))) + (tp-set 0 5 '(tp-colors ("red" "blue") help-echo "tip") str) + (list (tp-at 0 'face str) (tp-at 0 'help-echo str))) +;; => ((:foreground "red" :background "blue") "tip") + +;; tp-put-layer spec +(with-temp-buffer + (insert "Hello World") + (tp-put-layer 1 10 '(tp-colors "white" "black") 0) + (tp-at 1 'face)) +;; => (:foreground "white" :background "black") + +;; Wrong-arity calls signal a clear error naming the layer and both counts +(tp-set "hello" 'tp-colors "red") +;; error: tp layer tp-colors takes 2 argument(s), got 1 +``` + +Parameterized groups (`define-tps`) accept multiple parameters the same +way; the `(GROUP ARG1 ... ARGN)` and `(GROUP (ARG1 ... ARGN))` specs work +in the `tp-set` family. Note: `$`-symbols in parameterized bodies resolve +to their variables' current values at expansion time — parameterized +layers are **not** reactive. + **Format 3 - With reactive features (:props, :data, :compute, :watch, :transform):** ```elisp @@ -1695,7 +1918,7 @@ takes a function. ##### `define-tps` - Define Custom Text Property Group (Layer Group) -Define multiple related custom text properties. The name does not need to be quoted. As with `define-tp`, the ARGLIST is **mandatory**: `()` for non-parameterized groups, `(ARG)` for parameterized ones. Properties in the group can be used individually or with the group name to set multiple layers. +Define multiple related custom text properties. The name does not need to be quoted. As with `define-tp`, the ARGLIST is **mandatory**: `()` for non-parameterized groups, `(ARG1 ARG2 ...)` for parameterized ones (any number of parameters since 0.3.0). Properties in the group can be used individually or with the group name to set multiple layers. **Format 1 - Non-parameterized (empty argument list):** @@ -1827,6 +2050,8 @@ The first layer in the definition is the top layer (visible by default). ;; => #("emacs" 0 5 (face (:foreground "orange") tp-name tp-test-l1 ;; tp-layers ((face (:foreground "red") tp-name tp-test-l2) ;; (face (:background "green") tp-name tp-test-l3)))) +;; (top-level property print order may differ across Emacs versions; +;; the tp-layers stack order itself is stable) ``` --- @@ -1872,6 +2097,91 @@ reactive engine uses it to locate and re-render their regions. --- +#### `tp-layer-props-with-args` / `tp-group-props-with-args` / `tp-layer-arglist` + +```elisp +(tp-layer-props-with-args LAYER-NAME ARGS &optional INCLUDE-TP-NAME) +(tp-group-props-with-args GROUP-NAME ARGS &optional INCLUDE-TP-NAME) +(tp-layer-arglist LAYER-NAME) +``` + +Introspection for **parameterized** layers and groups (new in 0.3.0): + +- **`tp-layer-props-with-args`** expands a parameterized layer with ARGS, + a list of values bound positionally to the layer's parameters. Extra + values are ignored; fewer values than parameters signal a wrong-arity + error. Returns a fresh copy (mutating it cannot corrupt the registry), + or nil for non-parameterized or undefined layers. The existing + single-argument `tp-layer-props-with-arg` (note the one-character name + difference) remains as a thin `(list ARG)` wrapper. +- **`tp-group-props-with-args`** is the group counterpart, returning the + list of expanded per-layer plists; `tp-group-props-with-arg` remains + as the single-argument convenience. +- **`tp-layer-arglist`** returns a copy of the layer's parameter list, + or nil when LAYER-NAME is not a parameterized layer. + +**Examples:** + +```elisp +(progn + (tp-layer-reset) + (define-tp tp-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + (tp-layer-props-with-args 'tp-colors '("red" "blue"))) +;; => (face (:foreground "red" :background "blue")) + +;; The parameter list itself +(tp-layer-arglist 'tp-colors) +;; => (fg bg) + +;; Groups expand to one plist per layer +(progn + (define-tps tp-badge (fg bg) + `(tp-colors ,fg ,bg) + '(face bold)) + (tp-group-props-with-args 'tp-badge '("white" "black"))) +;; => ((face (:foreground "white" :background "black")) (face bold)) + +;; Too few arguments signal the same clear arity error as tp-set +(tp-layer-props-with-args 'tp-colors '("red")) +;; error: tp layer tp-colors takes 2 argument(s), got 1 +``` + +--- + +#### `tp-describe-layer` - Describe a Layer + +```elisp +(tp-describe-layer NAME) ; interactive +``` + +Pop a help buffer describing layer NAME (with completion over all +registered layers when called interactively). The buffer shows the +storage format (flat / unified / parameterized / reactive), the raw +stored body, the expanded properties (or a placeholder for parameterized +layers, which need arguments), the parameter list, the reactive +variables the layer depends on, whether a transform is registered, and +the group that generated the layer, if any. + +```elisp +(progn + (tp-layer-reset) + (define-tp tp-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + (tp-describe-layer 'tp-colors)) +;; Pops a *Help* buffer: +;; tp-colors is a tp layer. +;; +;; Storage format: parameterized +;; Arguments: (fg bg) +;; Stored body: `(face (:foreground ,fg :background ,bg)) +;; Expanded props: parameterized layer: expand with `tp-layer-props-with-args' +;; Reactive deps: none +;; Transform: no +``` + +--- + #### `tp-undefine-layer` / `tp-undefine-group` ```elisp @@ -1954,14 +2264,30 @@ This is useful when you want to remove all reactive bindings but keep the layer ### Property Layer Placement +> ⚠️ **String forms of stack operations mutate in place.** Unlike `tp-set`, +> which returns a **new** propertized string, the string form of every stack +> mutator (`tp-put-layer`, `tp-push-layer`, `tp-pop-layer`, `tp-delete-layer`, +> `tp-move-layer`, `tp-raise-layer`, `tp-lower-layer`, `tp-rotate-layer`, +> `tp-pin-layer`, `tp-switch-layer`, `tp-hide-layer`, `tp-show-layer`, +> `tp-merge-layers`, `tp-flatten-layers`, `tp-add-to-layers`, +> `tp-add-to-all-layers`) modifies STRING **destructively**. Never pass a +> string literal or a shared string you do not own — use `copy-sequence` +> first. Unifying this with `tp-set`'s copy semantics is on the 0.4 ledger. + +**Return values (0.3.0):** `tp-put-layer` / `tp-push-layer` return OBJECT +when one was given (the string itself in string forms), else +`(START . END)`. Every other stack mutator returns the **number of property +runs it modified**; a missing layer name or index never signals — unmatched +runs are silently left alone, and a return value of 0 means nothing matched. + #### `tp-put-layer` - Set Layer at Index ```elisp ;; Buffer/string region -(tp-put-layer START END LAYER IDX OBJECT) +(tp-put-layer START END LAYER IDX OBJECT NOERROR) ;; Entire string -(tp-put-layer STRING LAYER IDX) +(tp-put-layer STRING LAYER IDX NOERROR) ``` Set layer(s) at a specific index position in the layer stack. @@ -1975,12 +2301,18 @@ LAYER accepts several specs: - a layer name defined with `define-tp`: `'highlight` - an inline property plist (no `define-tp` needed): `'(face bold help-echo "tip")` - a list of layer names (the first name ends up on top): `'(layer-a layer-b)` -- a parameterized layer call: `'(tp-color "red")` +- a parameterized layer call: `'(tp-color "red")` — multi-argument layers + work too: `'(tp-colors "white" "black")` **Stack model:** only the top layer's properties are the visible text properties; lower layers are stored in the `tp-layers` text property until they are raised, rotated, or flattened. +**NOERROR (new in 0.3.0):** a LAYER naming an undefined layer or group +normally signals an error. With NOERROR non-nil the call returns nil +instead and modifies nothing — handy when applying layers that may not be +defined yet. `tp-push-layer` accepts the same trailing NOERROR. + **Examples:** ```elisp @@ -2047,6 +2379,12 @@ they are raised, rotated, or flattened. (tp-put-layer 1 10 '(tp-color "red") 0) (tp-at 1 'face))) ;; => (:foreground "red") + +;; NOERROR - an undefined layer name returns nil instead of signaling +(with-temp-buffer + (insert "Hello World") + (tp-put-layer 1 10 'no-such-layer 0 nil t)) +;; => nil ; nothing modified ``` --- @@ -2055,13 +2393,16 @@ they are raised, rotated, or flattened. ```elisp ;; Buffer/string region -(tp-push-layer START END LAYER OBJECT) +(tp-push-layer START END LAYER OBJECT NOERROR) ;; Entire string -(tp-push-layer STRING LAYER) +(tp-push-layer STRING LAYER NOERROR) ``` Push a layer to the top of the stack (equivalent to `tp-put-layer ... 0`). +NOERROR (new in 0.3.0) works as in +[`tp-put-layer`](#tp-put-layer---set-layer-at-index): an undefined LAYER +returns nil instead of signaling. **Examples:** @@ -2313,17 +2654,72 @@ Raise a layer by N positions. Positive N moves toward top, negative moves toward --- -#### `tp-rotate-layer` - Cycle Layers +#### `tp-lower-layer` - Mirror of `tp-raise-layer` ```elisp ;; Buffer/string region -(tp-rotate-layer START END OBJECT) +(tp-lower-layer START END IDX/LAYER-NAME N OBJECT) ;; Entire string -(tp-rotate-layer STRING) +(tp-lower-layer STRING IDX/LAYER-NAME N) ``` -Rotate layers - top goes to bottom, next becomes visible. +Lower a layer by N positions (new in 0.3.0). The mirror image of +`tp-raise-layer`: positive N moves the layer down toward the bottom, +negative N moves it up. N defaults to 1, and the resulting position is +clamped to the stack. Returns the number of property runs modified. + +**Examples:** + +```elisp +;; Lower the top layer by one position +(progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(face italic)) + (define-tp layer3 () '(face underline)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + ;; Stack: layer3 (top), layer2, layer1 (bottom) + (tp-lower-layer 1 10 'layer3 1) + ;; Stack: layer2 (top), layer3, layer1 (bottom) + (list (tp-layer-top 1 10) (tp-layer-list 1 10)))) +;; => (layer2 (layer2 layer3 layer1)) +``` + +--- + +#### `tp-rotate-layer` - Cycle Layers + +```elisp +;; Buffer/string region (canonical order, OBJECT last - new in 0.3.0) +(tp-rotate-layer START END DIRECTION &optional COUNT OBJECT) + +;; Entire string +(tp-rotate-layer STRING DIRECTION COUNT) + +;; Buffer/string region (legacy order, kept working forever) +(tp-rotate-layer START END OBJECT) +``` + +Rotate layers by COUNT steps, preserving their relative order. + +- **DIRECTION** is `down` or nil to move the top layer to the bottom (the + historical behavior), or `up` to bring the bottom layer to the top; any + other value signals an error. +- **COUNT** is the number of rotation steps, defaulting to 1; a COUNT below + 1 rotates nothing. Hidden layers rotate with the rest of the stack. +- Returns the number of property runs modified. + +The two region orders are told apart by the third argument: the symbols +`up` / `down` are never valid OBJECTs, so `(tp-rotate-layer 1 5 'up)` +unambiguously selects the canonical `(START END DIRECTION [COUNT] +[OBJECT])` order — no nil OBJECT placeholder needed. Any other third +argument (a buffer, a string, or nil for the current buffer) selects the +legacy `(START END OBJECT [DIRECTION] [COUNT])` order, which keeps working. **Examples:** @@ -2342,6 +2738,37 @@ Rotate layers - top goes to bottom, next becomes visible. ;; Stack: base (top) -> highlight (bottom) (tp-layer-top 1 10))) ;; => base + +;; Canonical order: `up' brings the bottom layer to the top +(progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(face italic)) + (define-tp layer3 () '(face underline)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + ;; Stack: layer3 (top), layer2, layer1 (bottom) + (tp-rotate-layer 1 10 'up) + (tp-layer-list 1 10))) +;; => (layer1 layer3 layer2) + +;; COUNT rotates several steps at once +(progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(face italic)) + (define-tp layer3 () '(face underline)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + (tp-rotate-layer 1 10 'down 2) + (tp-layer-list 1 10))) +;; => (layer1 layer3 layer2) ``` --- @@ -2356,7 +2783,10 @@ Rotate layers - top goes to bottom, next becomes visible. (tp-pin-layer STRING IDX/LAYER-NAME) ``` -Move a specific layer to the top (make it visible). +Move a layer to the top of the stack. **One-shot**: despite the name, +nothing stays pinned — this is a single move to index 0, and nothing +prevents a later `tp-push-layer` or `tp-put-layer` from covering the moved +layer again. **Examples:** @@ -2411,6 +2841,111 @@ Swap positions of two layers. --- +### Property Layer Visibility + +#### `tp-hide-layer` / `tp-show-layer` - Hide and Show Layers + +```elisp +;; Buffer/string region +(tp-hide-layer START END NAME OBJECT) +(tp-show-layer START END NAME OBJECT) + +;; Entire string +(tp-hide-layer STRING NAME) +(tp-show-layer STRING NAME) +``` + +Hide a layer without removing it, and make it render again (new in 0.3.0). +NAME identifies the layer: a layer name symbol or an integer index into the +full stack, hidden layers included (0 = top, -1 = bottom). + +**The visibility model:** + +- A hidden layer **stays in the stack**: it still counts for + `tp-layer-count`, appears in `tp-layer-list` and `tp-layer-stack-at`, and + can be moved, raised, or lowered — but it does not render. The text shows + the properties of the topmost **non-hidden** layer instead. +- Hiding the currently visible top layer therefore reveals the next visible + layer below it. +- When **every** layer is hidden the text renders bare (only the + `tp-layers` bookkeeping property remains — not even `tp-name` renders) + while all layers stay queryable. +- A hidden layer **keeps receiving reactive updates** while hidden, so + `tp-show-layer` always reveals current values (see + [Layer-Buffer Registry & Lifecycle](#layer-buffer-registry--lifecycle)). +- `tp-flatten-layers` merges only visible layers, and `tp-merge-layers` + excludes hidden matched layers' properties — hiding can never leak (see + [Property Layer Merging](#property-layer-merging)). +- Hiddenness is stored as a `tp-hidden` flag inside the layer's plist in + `tp-layers` stack storage, so `tp-hidden` is a reserved property name + inside layers, like `tp-name`. + +Both functions return the number of property runs modified. A NAME matching +no layer never signals, and hiding an already-hidden layer (or showing a +visible one) is a silent no-op — 0 means nothing changed. + +**Examples:** + +```elisp +;; Hiding the top layer reveals the one below; the stack is intact +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (list :visible (tp-at 1 'tp-name) + :face (tp-at 1 'face) + :count (tp-layer-count 1 10) + :layers (tp-layer-list 1 10)))) +;; => (:visible base :face default :count 2 :layers (highlight base)) + +;; With every layer hidden the text renders bare +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-hide-layer 1 10 'base) + (list :face (tp-at 1 'face) :count (tp-layer-count 1 10)))) +;; => (:face nil :count 2) + +;; tp-show-layer restores the layer's rendering +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-show-layer 1 10 'highlight) + (tp-at 1 'face))) +;; => (:background "yellow") + +;; Return value: number of modified runs; a missing name is a silent 0 +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (list (tp-hide-layer 1 10 'base) + (tp-hide-layer 1 10 'base) ; already hidden + (tp-hide-layer 1 10 'nonexistent)))) ; no such layer +;; => (1 0 0) +``` + +--- + ### Property Layer Merging #### `tp-merge-layers` - Merge Multiple Layers @@ -2425,6 +2960,14 @@ Swap positions of two layers. Merge specified layers into a new layer. Earlier layers in the list take precedence. +**Hidden layers (0.3.0):** hidden matched layers are merged away with the +rest but contribute **no** properties to the merged layer, so a merge can +never render what was hidden. When *every* matched layer is hidden, the +merged layer keeps their merged properties but carries the `tp-hidden` flag +itself — the data is preserved without un-hiding anything, and +`tp-show-layer` on the merged layer renders it. Returns the number of +property runs modified (0 = no listed layer matched). + **Examples:** ```elisp @@ -2453,6 +2996,22 @@ Merge specified layers into a new layer. Earlier layers in the list take precede (tp-merge-layers 1 10 'merged '(0 1)) (tp-layer-count 1 10))) ;; => 1 + +;; A hidden layer's properties never leak into the merge +(progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(help-echo "tip")) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-hide-layer 1 10 'layer2) + (tp-merge-layers 1 10 'merged '(layer1 layer2)) + (list :face (tp-at 1 'face) + :help (tp-at 1 'help-echo) + :name (tp-at 1 'tp-name)))) +;; => (:face bold :help nil :name merged) ; layer2 was hidden ``` --- @@ -2469,6 +3028,13 @@ Merge specified layers into a new layer. Earlier layers in the list take precede Flatten all layers into a single layer with the given name. +**Hidden layers (0.3.0):** hidden layers are **discarded**, mirroring +image-editor flatten semantics — only the visible layers' properties merge +into the result, so flattening can never render what was hidden. When +*every* layer of a run is hidden, the run's properties are cleared entirely +(bare text), consistent with the all-hidden rendering of `tp-hide-layer`. +Returns the number of property runs modified (0 = no run had layers). + **Examples:** ```elisp @@ -2495,6 +3061,20 @@ Flatten all layers into a single layer with the given name. (tp-flatten-layers 1 10 nil) (tp-at 1 'tp-name))) ;; => nil + +;; Hidden layers are discarded by flatten +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-flatten-layers 1 10 'flat) + (list (tp-at 1 'face) (tp-at 1 'tp-name)))) +;; => (default flat) ; highlight's background is gone ``` --- @@ -2581,7 +3161,10 @@ Check if layer exists in region. (tp-layer-top START END &optional OBJECT) ``` -Get name of the top (visible) layer. +Get name of the top layer. The topmost layer is reported in **stack +order**, even when it is hidden (see +[`tp-hide-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers)); +use `tp-layer-stack-at` to distinguish hidden layers from visible ones. **Examples:** @@ -2600,6 +3183,63 @@ Get name of the top (visible) layer. --- +#### `tp-layer-stack-at` - Full Stack at a Position + +```elisp +(tp-layer-stack-at POS &optional OBJECT) +``` + +Return the full ordered layer stack at one position (new in 0.3.0), as a +list with one element per layer, topmost first, where each element is a +cons `(NAME . PROPS)`: + +- **NAME** is the layer's `tp-name` symbol, or nil for an unnamed layer. +- **PROPS** is the layer's property plist without its `tp-name` entry. A + hidden layer is distinguishable by a `tp-hidden` entry with value t in + PROPS; visible layers never carry one. + +Hidden layers are included at their stack position. Returns nil for bare +text. POS is in OBJECT's native coordinates (0-based for strings, 1-based +for buffers); OBJECT is a string, a buffer, or nil for the current buffer. + +**Examples:** + +```elisp +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-layer-stack-at 1))) +;; => ((highlight . (face (:background "yellow"))) +;; (base . (face default))) + +;; Hidden layers carry a `tp-hidden' entry in PROPS +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-layer-stack-at 1))) +;; => ((highlight . (tp-hidden t face (:background "yellow"))) +;; (base . (face default))) + +;; Bare text has no stack +(with-temp-buffer + (insert "Hello") + (tp-layer-stack-at 1)) +;; => nil +``` + +--- + #### `tp-add-to-layers` - Add Properties to Specific Layers ```elisp @@ -2615,7 +3255,9 @@ Add or merge properties to specific layers in a region or string. - **IDX-OR-LAYER-NAME-LIST** is a list of layer indices (integers) or layer names (symbols). For indices: 0 means top layer, -1 means bottom layer. - Properties are deeply merged into the specified layers (nested plists are merged, not replaced). - OBJECT defaults to current buffer for region form. -- For strings, returns a NEW string (original is not modified). For buffers, returns nil. +- Like the other stack mutators (and unlike `tp-set`), the string form + modifies STRING **in place** and returns that same mutated string. For + buffers, returns nil. **Examples:** @@ -2650,7 +3292,9 @@ Add or merge properties to all layers in a region or string. - Properties are deeply merged into all existing layers. - OBJECT defaults to current buffer for region form. -- For strings, returns a NEW string (original is not modified). For buffers, returns nil. +- Like the other stack mutators (and unlike `tp-set`), the string form + modifies STRING **in place** and returns that same mutated string. For + buffers, returns nil. **Examples:** @@ -2670,7 +3314,7 @@ Add or merge properties to all layers in a region or string. #### `tp-intervals` - Get Text Property Intervals ```elisp -(tp-intervals START END &optional OBJECT) +(tp-intervals START END &optional OBJECT ABSOLUTE) ``` Get all text property intervals from START to END in OBJECT. @@ -2678,8 +3322,12 @@ Get all text property intervals from START to END in OBJECT. - Returns a list of (START END PROPERTIES) for each interval, including gap intervals with no properties, whose PROPERTIES is nil. - For buffer input, START and END are 1-based buffer positions but the - returned positions are **0-based offsets relative to START**. For strings, - positions are absolute 0-based indices. + returned positions are by default **0-based offsets relative to START** + (the legacy convention). With ABSOLUTE non-nil (new in 0.3.0) they are + native 1-based buffer positions instead, directly reusable in other tp + calls (`tp-set`, `tp-remove`, ...) without offset arithmetic. For + strings, positions are always absolute 0-based indices; ABSOLUTE changes + nothing. - Uses `object-intervals` (requires Emacs 28.1+). - OBJECT can be a buffer or string; nil defaults to current buffer. @@ -2693,6 +3341,24 @@ Get all text property intervals from START to END in OBJECT. (tp-intervals 1 12)) ;; => ((0 5 (face bold)) (5 6 nil) (6 11 (face italic))) ;; positions are offsets from START; (5 6 nil) is the unpropertized gap + +;; ABSOLUTE - native buffer coordinates +(with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (tp-set 7 12 '(face italic)) + (tp-intervals 1 12 nil t)) +;; => ((1 6 (face bold)) (6 7 nil) (7 12 (face italic))) + +;; ABSOLUTE positions feed straight back into other tp calls +(with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (dolist (iv (tp-intervals 1 12 nil t)) + (when (eq (plist-get (nth 2 iv) 'face) 'bold) + (tp-add (nth 0 iv) (nth 1 iv) '(help-echo "bold text")))) + (tp-at 1 'help-echo)) +;; => "bold text" ``` --- @@ -2700,13 +3366,21 @@ Get all text property intervals from START to END in OBJECT. #### `tp-intervals-map` - Apply Function to Intervals ```elisp -(tp-intervals-map FUNCTION START END &optional OBJECT) +(tp-intervals-map FUNCTION START END &optional OBJECT ABSOLUTE) ``` Apply FUNCTION to all intervals between START and END in OBJECT. -- FUNCTION receives four arguments: interval-start, interval-end, top-props (visible layer properties), and below-props-lst (list of hidden layers). -- Intervals with no properties are visited too, with nil top-props (positions follow the same offset convention as `tp-intervals`). +- FUNCTION receives four arguments: interval-start, interval-end, + top-props (the directly rendered properties, with the `tp-layers` entry + removed), and below-props-lst (the `tp-layers` value: the stored layer + plists buried below the rendered top layer — while any layer is hidden + it holds the whole ordered stack; see + [`tp-layer-stack-at`](#tp-layer-stack-at---full-stack-at-a-position) for + the decoded view). +- Intervals with no properties are visited too, with nil top-props + (positions follow the same coordinate convention as `tp-intervals`, + including the ABSOLUTE argument, new in 0.3.0). - OBJECT can be a buffer or string; nil defaults to current buffer. - Returns list of function results (nil results are removed). @@ -2722,6 +3396,17 @@ Apply FUNCTION to all intervals between START and END in OBJECT. (list start end (plist-get props 'face))) 1 12)) ;; => ((0 5 bold) (5 6 nil) (6 11 italic)) + +;; ABSOLUTE - FUNCTION receives native buffer positions +(with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (tp-set 7 12 '(face italic)) + (tp-intervals-map + (lambda (start end props belows) + (list start end (plist-get props 'face))) + 1 12 nil t)) +;; => ((1 6 bold) (6 7 nil) (7 12 italic)) ``` --- @@ -2848,7 +3533,8 @@ parameterized `tp-palette` layer (as in `(tp-set "emacs" 'tp-palette 'info)`). - **`tp-palette-alist`** (variable) — alist of `(NAME . PLIST)` palette definitions; the single source of truth for palette lookups. Each PLIST maps `:fg`, `:bg`, and `:border` to colors. -- **`define-tp-palette`** — register (or update) a palette: +- **`define-tp-palette`** — register (or update) a palette (since 0.3.0 + also available as the prefix-conforming alias `tp-define-palette`): ```elisp (define-tp-palette my-brand @@ -2856,6 +3542,38 @@ parameterized `tp-palette` layer (as in `(tp-set "emacs" 'tp-palette 'info)`). :bg ("#ddf4ff" . "#1f3d5c")) ``` +- **`tp-palette-color`** (new in 0.3.0) — **the** palette accessor: get a + palette's `:fg` / `:bg` / `:border` color, resolved for the current + light/dark theme. Returns nil for a missing palette or key: + + ```elisp + (tp-palette-color 'info :fg) + ;; => "#0969da" on a light theme, "#58a6ff" on a dark theme + (tp-palette-color 'no-such-palette :fg) + ;; => nil + ``` + +- **`tp-palette-has-p`** (new in 0.3.0) — **the** palette predicate: with + just SYMBOL, test whether it names a registered palette; with KIND one of + `:fg` / `:bg` / `:border`, additionally require that key in its + definition (a defined key may still resolve to no color for the current + theme — use `tp-palette-color` when the resolved color matters): + + ```elisp + (list (tp-palette-has-p 'info) + (tp-palette-has-p 'info :border) + (tp-palette-has-p 'no-such-palette)) + ;; => (t t nil) + ``` + + The older per-key conveniences remain as compatible wrappers: + `tp-palette-fg-color` / `tp-palette-bg-color` / `tp-palette-border-color` + (fixed-KEY variants of `tp-palette-color`), `tp-palette-p` (nil-KIND + `tp-palette-has-p`), and the suffixed-name predicates `tp-palette-fg-p` / + `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p`, which + answer a different question: whether a *variant name* like `info-fg` + denotes a registered palette (the `tp-palette` layer's convention). + - **`tp-palette-show`** — interactive command that displays a gallery buffer of every registered palette and its `-fg` / `-bg` / `-fbg` / `-border` variants (`q` quits). @@ -3192,6 +3910,135 @@ Benefits of batched updates: - Improves performance when changing multiple variables - Ensures consistent state when multiple variables are interdependent +### Layer-Buffer Registry & Lifecycle + +Since 0.3.0 the reactive engine keeps a **layer→buffer registry**: every +buffer-mutating write path that stamps a layer (the `tp-set` family, the +stack mutators, the match/regexp appliers) registers the target buffer as +showing that layer, and a reactive update visits **only the registered +buffers** instead of scanning the whole `(buffer-list)`. Killed buffers are +pruned automatically. When a layer has no registry entry at all, one +**learning full scan** falls back to the old behavior and registers every +buffer where the layer is actually found. + +Updates reach a layer's regions even while the layer is **hidden** or +**buried** below other layers in a stack: the stored `tp-layers` entry is +updated in place, so `tp-show-layer` (or raising the layer) always reveals +current values. + +#### `tp-reactive-layer-buffers` - Inspect the Registry + +```elisp +(tp-reactive-layer-buffers LAYER-NAME) +``` + +Return the live buffers registered as showing LAYER-NAME — a list (possibly +empty, meaning "known: no buffer shows this layer") — or the symbol +`unknown` when the layer has no registry entry at all: + +```elisp +(progn + (tp-layer-reset) + (defvar reg-color "red") + (define-tp reg-layer () + :props '(face (:foreground $reg-color))) + (tp-reactive-layer-buffers 'reg-layer)) +;; => unknown ; never applied to any buffer yet + +(with-temp-buffer + (rename-buffer "demo-buffer" t) + (insert "Hello") + (tp-push-layer 1 6 'reg-layer) + (mapcar #'buffer-name (tp-reactive-layer-buffers 'reg-layer))) +;; => ("demo-buffer") +``` + +#### `tp-reactive-track-buffer` - Close the String-Insert Gap + +```elisp +(tp-reactive-track-buffer &optional BUFFER) ; interactive +``` + +**Known gap:** inserting an *already-propertized string* into a buffer +bypasses the buffer operations that register buffers, so that buffer is +missing from the registry until a learning full scan finds it. Call +`tp-reactive-track-buffer` after such an insert: it scans BUFFER (default: +the current buffer) for layer regions — rendered top layers as well as +layers buried or hidden inside `tp-layers` stack storage — registers the +buffer for each, and returns the layer names found in buffer order: + +```elisp +(let ((s (tp-set "hello" 'reg-layer))) ; propertized string, detached + (with-temp-buffer + (insert s) ; bypasses registration + (tp-reactive-track-buffer))) +;; => (reg-layer) ; buffer now registered for reg-layer +``` + +#### `tp-gc-anonymous-layers` - Collect Unused Anonymous Layers + +```elisp +(tp-gc-anonymous-layers) ; interactive +``` + +[Anonymous reactive layers](#anonymous-reactive-layers) are interned: an +`equal` props spec reuses its registry entry instead of minting a new layer +on every `tp-set`. `tp-gc-anonymous-layers` undefines every interned +anonymous layer that no registered live buffer still displays (buried and +hidden layers count as alive) and returns the collected layer names: + +```elisp +(defvar tmp-color "green") +(let ((buf (generate-new-buffer "*gc-demo*"))) + (with-current-buffer buf + (insert "Hello") + (tp-set 1 6 '(face (:foreground $tmp-color)))) ; anonymous layer + (kill-buffer buf) + (tp-gc-anonymous-layers)) +;; => (tp-anon-1) ; the collected names (the counter varies) +``` + +**Conservative `unknown` semantics:** a layer whose registry state is +`unknown` — never seen in any buffer through the registering paths, for +example referenced only by detached strings — is deliberately **kept**. A +layer becomes collectable only after it was registered for at least one +buffer and none of the registered buffers still shows it (e.g. all killed). +Call `tp-reactive-track-buffer` after inserting propertized strings so +their buffers are registered too. + +#### Minimal-Diff `tp-text` Re-Rendering + +Reactive `tp-text` replacements edit only the **differing span** of the old +and new text (inserting before deleting), so point and markers in unchanged +text keep their positions; point inside the edited span lands at the edit +start. An update to an **identical** value is a true no-op: no text edit, +no property churn, and the buffer-modified flag is untouched. + +```elisp +(progn + (tp-layer-reset) + (defvar counter-val "0") + (define-tp counter-label () + :props '(tp-text $counter-val)) + (with-temp-buffer + (insert "count: 0 items") + (tp-set 8 9 'counter-label) + (let ((m (copy-marker 10))) ; marker on the "i" of "items" + (setq counter-val "9") ; only the digit is edited + (list (buffer-substring-no-properties 1 (point-max)) + (char-after m))))) +;; => ("count: 9 items" ?i) ; the marker still points at its character + +;; Identical-value updates do not touch the buffer at all +(with-temp-buffer + (insert "count: 9 items") + (tp-set 8 9 'counter-label) + (set-buffer-modified-p nil) + (setq counter-val "9") ; same text as displayed + (buffer-modified-p)) +;; => nil +``` + ### Debug Mode tp.el provides a debug mode to help understand reactive update flow: diff --git a/README_CN.md b/README_CN.md index 6dbecc6..0e0699e 100644 --- a/README_CN.md +++ b/README_CN.md @@ -61,6 +61,8 @@ - [属性层定义](#属性层定义) - [define-tp / define-tps](#define-tp--define-tps---定义自定义文本属性) - [tp-layer-props / tp-group-props](#tp-layer-props--tp-group-props) + - [tp-layer-props-with-args / tp-group-props-with-args / tp-layer-arglist](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) + - [tp-describe-layer](#tp-describe-layer---描述属性层) - [tp-undefine-layer / tp-undefine-group](#tp-undefine-layer--tp-undefine-group) - [tp-layer-reset](#tp-layer-reset) - [tp-reactive-reset](#tp-reactive-reset) @@ -73,9 +75,12 @@ - [属性层移动](#属性层移动) - [tp-move-layer](#tp-move-layer---移动属性层到指定位置) - [tp-raise-layer](#tp-raise-layer---上移下移属性层) + - [tp-lower-layer](#tp-lower-layer---tp-raise-layer-的镜像) - [tp-rotate-layer](#tp-rotate-layer---轮换属性层) - [tp-pin-layer](#tp-pin-layer---将属性层置顶) - [tp-switch-layer](#tp-switch-layer---交换两个属性层) + - [属性层可见性](#属性层可见性) + - [tp-hide-layer / tp-show-layer](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) - [属性层合并](#属性层合并) - [tp-merge-layers](#tp-merge-layers---合并多个属性层) - [tp-flatten-layers](#tp-flatten-layers---扁平化所有属性层) @@ -84,6 +89,7 @@ - [tp-layer-count](#tp-layer-count) - [tp-layer-exists-p](#tp-layer-exists-p) - [tp-layer-top](#tp-layer-top) + - [tp-layer-stack-at](#tp-layer-stack-at---获取某位置的完整层栈) - [tp-add-to-layers](#tp-add-to-layers---向特定属性层添加属性) - [tp-add-to-all-layers](#tp-add-to-all-layers---向所有属性层添加属性) - [实用工具函数](#实用工具函数) @@ -106,6 +112,7 @@ - [API 中的层名解析](#api-中的层名解析) - [响应式层组](#响应式层组) - [批量更新](#批量更新) + - [层-缓冲区注册表与生命周期](#层-缓冲区注册表与生命周期) - [调试模式](#调试模式) - [重置响应式状态](#重置响应式状态) - [完整示例：主题感知文本](#完整示例主题感知文本) @@ -184,6 +191,42 @@ ``` - ✅ **统一对象支持**：同一个函数同时支持字符串和缓冲区，无需记忆不同的 API +**只需记住一条规则**：当第一个参数是**字符串**时，调用作用于整个字符串； +当第一个参数是**数字**时，调用作用于 OBJECT 的 `[START, END)` 区域 —— 而 +OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和层栈函数都遵循 +这条规则。 + +匹配/搜索家族（`tp-match-*`、`tp-regexp-*`、`tp-search-map`、 +`tp-forward-do`/`tp-backward-do`）刻意采用了**第二种约定**：PATTERN +（或 FUNCTION）和 PLIST 在前，然后是 OBJECT，最后才是可选的 START/END +边界。对这些函数来说，作用于整个对象才是常见用法，因此 OBJECT 位于范围 +参数之前而不是之后。 + +**返回值约定**（自 0.3.0 起）： + +| 函数家族 | 返回值 | +|---|---| +| `tp-set` / `tp-reset` / `tp-add` | 缓冲区/区域形式返回 `(START . END)`；整字符串形式返回一个**新**字符串 | +| `tp-remove` | 缓冲区形式返回 nil；整字符串形式返回一个**新**字符串 | +| `tp-clear` | nil | +| `tp-match-*` / `tp-regexp-*` | 缓冲区返回 `(START . END)` 匹配列表；字符串返回一个**新**字符串 | +| 栈修改函数（delete/pop/move/raise/lower/rotate/pin/switch/hide/show/merge/flatten） | 被修改的属性区段数量（0 = 没有匹配任何层） | +| `tp-put-layer` / `tp-push-layer` | 给定 OBJECT 时返回 OBJECT（字符串形式返回该字符串本身），否则返回 `(START . END)` | +| `tp-add-to-layers` / `tp-add-to-all-layers` | 字符串形式返回该字符串本身（**就地**修改）；缓冲区返回 nil | + +**命名空间地图**：接受*层名*参数的 `tp-layer-NAME` 函数 +（`tp-layer-props`、`tp-layer-arglist` 等）查询的是层**注册表**（层定 +义）；接受*位置*参数的函数 —— START END（`tp-layer-list`、 +`tp-layer-count`、`tp-layer-top` 等）或单个 POS（`tp-layer-stack-at`） +—— 查询的是实际文本上的层**栈**。 + +**命名约定**：`tp-define-layer` / `tp-define-group` / +`tp-define-palette` 是今后符合前缀规范的规范名称（可通过 +`C-h f tp-...` 发现）；`define-tp` / `define-tps` / `define-tp-group` / +`define-tp-palette` 是永久别名，永远不会被移除（本 README 的示例仍使用 +历史名称）。`tp-search-forward` / `tp-search-backward` 自 0.3.0 起已废 +弃 —— 参见[搜索和导航函数](#tp-search-forward--tp-search-backward)。 + ### 三种属性操作语义 原生 API 只有简单的设置和获取，tp.el 提供了三种清晰的操作语义： @@ -254,9 +297,10 @@ - ✅ **丰富的属性层操作**： - 放置：`tp-put-layer`（指定位置）、`tp-push-layer`（顶部） - 删除：`tp-delete-layer`（按名称/索引）、`tp-pop-layer`（顶层） - - 移动：`tp-raise-layer`（上下移动）、`tp-rotate-layer`（轮换）、`tp-pin-layer`（置顶）、`tp-switch-layer`（交换） + - 移动：`tp-raise-layer` / `tp-lower-layer`（上下移动）、`tp-rotate-layer`（轮换）、`tp-pin-layer`（一次性置顶）、`tp-switch-layer`（交换） + - 可见性：`tp-hide-layer` / `tp-show-layer`（隐藏属性层而不移除它） - 合并：`tp-merge-layers`（合并指定层）、`tp-flatten-layers`（扁平化所有层） -- ✅ **属性层查询**：`tp-layer-list`、`tp-layer-count`、`tp-layer-exists-p`、`tp-layer-top` +- ✅ **属性层查询**：`tp-layer-list`、`tp-layer-count`、`tp-layer-exists-p`、`tp-layer-top`、`tp-layer-stack-at` ```elisp ;; 属性层使用示例 @@ -299,6 +343,7 @@ - ✅ **:data 附加状态**：定义不直接用于属性但可以触发更新的额外响应式变量 - ✅ **:compute 计算属性**：创建从其他响应式变量派生值的计算属性（类似 Vue 的 computed） - ✅ **:watch 副作用监听**：当响应式变量改变时执行回调函数（类似 Vue 的 watch） +- ✅ **定向更新（0.3.0）**：层→缓冲区注册表使更新只访问展示受影响层的缓冲区；`tp-text` 重渲染只编辑差异区段（point 和标记保持原位）；`tp-reactive-track-buffer` / `tp-gc-anonymous-layers` 管理层的生命周期 —— 参见[层-缓冲区注册表与生命周期](#层-缓冲区注册表与生命周期) ```elisp ;; 定义一个带响应式属性的层 @@ -327,8 +372,8 @@ ### 增强的搜索与导航 - ✅ **范围搜索**：`tp-search` 返回所有匹配区间的列表 -- ✅ **N次搜索**：`tp-forward`/`tp-backward` 支持向前/向后搜索N次 -- ✅ **搜索并执行**：`tp-forward-do`/`tp-backward-do` 搜索并对匹配文本执行函数 +- ✅ **N次搜索**：`tp-forward`/`tp-backward` 支持向前/向后搜索N次，并支持可选的 PREDICATE 匹配和 NOT-CURRENT +- ✅ **搜索并执行**：`tp-forward-do`/`tp-backward-do` 搜索 N 次并在第 N 个匹配处应用函数 - ✅ **批量转换**：`tp-search-map` 对所有匹配应用转换函数 ```elisp @@ -403,32 +448,37 @@ tp.el 所有函数按类别组织的完整概览： #### 模式匹配函数 | 函数 | 描述 | |------|------| -| [`tp-match-set`](#tp-match-set---匹配字符串) | 在字符串匹配处设置属性 | -| [`tp-match-reset`](#tp-match-reset---匹配并重置) | 在字符串匹配处重置所有属性 | -| [`tp-match-add`](#tp-match-add---匹配并添加) | 在字符串匹配处添加/合并属性 | -| [`tp-regexp-set`](#tp-regexp-set---匹配正则表达式) | 在正则匹配处设置属性 | -| [`tp-regexp-reset`](#tp-regexp-reset---正则匹配并重置) | 在正则匹配处重置所有属性 | -| [`tp-regexp-add`](#tp-regexp-add---正则匹配并添加) | 在正则匹配处添加/合并属性 | +| [`tp-match-set`](#tp-match-set---匹配字符串) | 在字符串匹配处设置属性（可选边界） | +| [`tp-match-reset`](#tp-match-reset---匹配并重置) | 在字符串匹配处重置所有属性（可选边界） | +| [`tp-match-add`](#tp-match-add---匹配并添加) | 在字符串匹配处添加/合并属性（可选边界） | +| [`tp-regexp-set`](#tp-regexp-set---匹配正则表达式) | 在正则匹配处设置属性（可选边界和捕获组） | +| [`tp-regexp-reset`](#tp-regexp-reset---正则匹配并重置) | 在正则匹配处重置所有属性（可选边界和捕获组） | +| [`tp-regexp-add`](#tp-regexp-add---正则匹配并添加) | 在正则匹配处添加/合并属性（可选边界和捕获组） | #### 搜索和导航函数 | 函数 | 描述 | |------|------| -| [`tp-search-forward`](#tp-search-forward--tp-search-backward) | text-property-search-forward 的原始包装 | -| [`tp-search-backward`](#tp-search-forward--tp-search-backward) | text-property-search-backward 的原始包装 | -| [`tp-forward`](#tp-forward--tp-backward) | 向前搜索 N 次具有属性的文本（支持缓冲区和字符串） | -| [`tp-backward`](#tp-forward--tp-backward) | 向后搜索 N 次具有属性的文本（支持缓冲区和字符串） | -| [`tp-forward-do`](#tp-forward-do--tp-backward-do) | 向前搜索并对最后一个匹配应用函数（支持起始和结束范围） | -| [`tp-backward-do`](#tp-forward-do--tp-backward-do) | 向后搜索并对最后一个匹配应用函数（支持起始和结束范围） | +| [`tp-search-forward`](#tp-search-forward--tp-search-backward) | **已废弃（0.3.0）** —— 请使用 [`tp-forward`](#tp-forward--tp-backward) 或 Emacs 原语 | +| [`tp-search-backward`](#tp-search-forward--tp-search-backward) | **已废弃（0.3.0）** —— 请使用 [`tp-backward`](#tp-forward--tp-backward) 或 Emacs 原语 | +| [`tp-forward`](#tp-forward--tp-backward) | 向前搜索 N 次具有属性的文本（可选谓词匹配） | +| [`tp-backward`](#tp-forward--tp-backward) | 向后搜索 N 次具有属性的文本（可选谓词匹配） | +| [`tp-forward-do`](#tp-forward-do--tp-backward-do) | 向前搜索 N 次，在第 N 个匹配处应用函数 | +| [`tp-backward-do`](#tp-forward-do--tp-backward-do) | 向后搜索 N 次，在第 N 个匹配处应用函数 | | [`tp-search`](#tp-search---搜索所有匹配) | 在范围或字符串中搜索所有匹配的属性 | | [`tp-search-map`](#tp-search-map---对匹配文本应用函数) | 对所有匹配的文本应用函数（支持起始和结束范围） | #### 属性层定义函数 | 函数 | 描述 | |------|------| -| [`define-tp`](#define-tp--define-tps---定义自定义文本属性) | 定义自定义文本属性（层），支持参数化 | -| [`define-tps`](#define-tp--define-tps---定义自定义文本属性) | 定义自定义文本属性组（层组），支持参数化 | +| [`define-tp`](#define-tp--define-tps---定义自定义文本属性) | 定义自定义文本属性（层），支持可选参数 | +| [`define-tps`](#define-tp--define-tps---定义自定义文本属性) | 定义自定义文本属性组（层组），支持可选参数 | +| [`tp-define-layer` / `tp-define-group`](#define-tp--define-tps---定义自定义文本属性) | `define-tp` / `define-tps` 的前缀规范别名 | | [`tp-layer-props`](#tp-layer-props--tp-group-props) | 获取属性层的属性 | | [`tp-group-props`](#tp-layer-props--tp-group-props) | 获取属性层组中所有属性层的属性 | +| [`tp-layer-props-with-args`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | 用参数列表展开参数化属性层 | +| [`tp-group-props-with-args`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | 用参数列表展开参数化属性层组 | +| [`tp-layer-arglist`](#tp-layer-props-with-args--tp-group-props-with-args--tp-layer-arglist) | 获取参数化属性层的参数列表 | +| [`tp-describe-layer`](#tp-describe-layer---描述属性层) | 在帮助缓冲区中描述属性层的定义 | | [`tp-undefine-layer`](#tp-undefine-layer--tp-undefine-group) | 移除属性层定义 | | [`tp-undefine-group`](#tp-undefine-layer--tp-undefine-group) | 移除属性层组定义 | | [`tp-layer-reset`](#tp-layer-reset) | 清除所有属性层/属性层组定义 | @@ -437,8 +487,8 @@ tp.el 所有函数按类别组织的完整概览： #### 属性层放置函数 | 函数 | 描述 | |------|------| -| [`tp-put-layer`](#tp-put-layer---在指定位置设置属性层) | 在指定索引位置设置属性层 | -| [`tp-push-layer`](#tp-push-layer---推送属性层到顶部) | 将属性层推到堆栈顶部 | +| [`tp-put-layer`](#tp-put-layer---在指定位置设置属性层) | 在指定索引位置设置属性层（可选 NOERROR） | +| [`tp-push-layer`](#tp-push-layer---推送属性层到顶部) | 将属性层推到堆栈顶部（可选 NOERROR） | #### 属性层删除函数 | 函数 | 描述 | @@ -451,15 +501,22 @@ tp.el 所有函数按类别组织的完整概览： |------|------| | [`tp-move-layer`](#tp-move-layer---移动属性层到指定位置) | 将属性层从一个位置移动到另一个位置 | | [`tp-raise-layer`](#tp-raise-layer---上移下移属性层) | 将属性层上移/下移 N 个位置 | -| [`tp-rotate-layer`](#tp-rotate-layer---轮换属性层) | 轮换属性层（顶层移到底部） | -| [`tp-pin-layer`](#tp-pin-layer---将属性层置顶) | 将属性层置顶（使其可见） | +| [`tp-lower-layer`](#tp-lower-layer---tp-raise-layer-的镜像) | `tp-raise-layer` 的镜像：将属性层下移/上移 N 个位置 | +| [`tp-rotate-layer`](#tp-rotate-layer---轮换属性层) | 向上或向下轮换属性层 N 步 | +| [`tp-pin-layer`](#tp-pin-layer---将属性层置顶) | 将属性层移到顶部（一次性；之后的 push 仍可能覆盖它） | | [`tp-switch-layer`](#tp-switch-layer---交换两个属性层) | 交换两个属性层的位置 | +#### 属性层可见性函数 +| 函数 | 描述 | +|------|------| +| [`tp-hide-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) | 隐藏属性层而不将其从栈中移除 | +| [`tp-show-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) | 让隐藏的属性层重新渲染 | + #### 属性层合并函数 | 函数 | 描述 | |------|------| -| [`tp-merge-layers`](#tp-merge-layers---合并多个属性层) | 将指定属性层合并为新属性层 | -| [`tp-flatten-layers`](#tp-flatten-layers---扁平化所有属性层) | 将所有属性层扁平化为单一属性层 | +| [`tp-merge-layers`](#tp-merge-layers---合并多个属性层) | 将指定属性层合并为新属性层（隐藏层不贡献属性） | +| [`tp-flatten-layers`](#tp-flatten-layers---扁平化所有属性层) | 将所有属性层扁平化为单一属性层（隐藏层被丢弃） | #### 属性层查询函数 | 函数 | 描述 | @@ -467,7 +524,8 @@ tp.el 所有函数按类别组织的完整概览： | [`tp-layer-list`](#tp-layer-list---列出所有属性层) | 列出区域中的所有属性层名称 | | [`tp-layer-count`](#tp-layer-count) | 计算区域中的属性层数量 | | [`tp-layer-exists-p`](#tp-layer-exists-p) | 检查区域中是否存在某属性层 | -| [`tp-layer-top`](#tp-layer-top) | 获取顶层（可见）属性层的名称 | +| [`tp-layer-top`](#tp-layer-top) | 获取顶层属性层的名称（按栈序，即使它被隐藏） | +| [`tp-layer-stack-at`](#tp-layer-stack-at---获取某位置的完整层栈) | 以 `(NAME . PROPS)` cons 形式返回某位置的完整有序层栈 | | [`tp-region-layer-props`](#tp-region-layer-props---获取区域中的层属性) | 获取区域中特定层的属性 | #### 属性层操作函数 @@ -479,8 +537,8 @@ tp.el 所有函数按类别组织的完整概览： #### 实用工具函数 | 函数 | 描述 | |------|------| -| [`tp-intervals`](#tp-intervals---获取文本属性区间) | 获取区域中的所有文本属性区间 | -| [`tp-intervals-map`](#tp-intervals-map---对区间应用函数) | 对区域中的所有区间应用函数 | +| [`tp-intervals`](#tp-intervals---获取文本属性区间) | 获取区域中的所有文本属性区间（可选 ABSOLUTE 坐标） | +| [`tp-intervals-map`](#tp-intervals-map---对区间应用函数) | 对区域中的所有区间应用函数（可选 ABSOLUTE 坐标） | | [`tp-plist`](#tp-plist---获取区域中的所有属性) | 获取区域中存在的所有属性 | | [`tp-empty-p`](#tp-empty-p---检查对象是否有属性) | 检查对象是否没有文本属性 | | [`tp-with-current-buffer`](#tp-with-current-buffer--tp-pop-to-buffer--tp-switch-to-buffer) | 在绑定 `inhibit-read-only` 的情况下在缓冲区中执行 body | @@ -491,10 +549,20 @@ tp.el 所有函数按类别组织的完整概览： | 函数 | 描述 | |------|------| | [`tp-palette-alist`](#调色板系统) | 具名调色板注册表（变量） | -| [`define-tp-palette`](#调色板系统) | 注册或更新一个具名调色板 | +| [`define-tp-palette`](#调色板系统) | 注册或更新一个具名调色板（别名：`tp-define-palette`） | +| [`tp-palette-color`](#调色板系统) | 获取调色板的 `:fg` / `:bg` / `:border` 颜色，按主题解析 | +| [`tp-palette-has-p`](#调色板系统) | 测试调色板（或其某个键）是否已定义 | | [`tp-palette-show`](#调色板系统) | 展示所有已注册调色板的画廊 | | [`tp-parse-color`](#调色板系统) | 按当前亮色/暗色主题解析颜色规格 | +#### 响应式生命周期函数 +| 函数 | 描述 | +|------|------| +| [`tp-with-batch-updates`](#批量更新) | 将多个响应式变量更改合并为一次更新 | +| [`tp-reactive-layer-buffers`](#层-缓冲区注册表与生命周期) | 注册为展示某层的缓冲区（或 `unknown`） | +| [`tp-reactive-track-buffer`](#层-缓冲区注册表与生命周期) | 插入已带属性的字符串后注册缓冲区 | +| [`tp-gc-anonymous-layers`](#层-缓冲区注册表与生命周期) | 回收已无注册的存活缓冲区展示的匿名层 | + --- ### 核心属性函数 @@ -587,6 +655,7 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或 :data '((my-color . "blue"))) (tp-set " " 'my-style) ;; => #(" " 0 1 (face (:foreground "blue") tp-name my-style)) +;; （属性的打印顺序在不同 Emacs 版本间可能不同，值本身一致） ;; 单次调用中合并多个 face（重复属性自动合并） (tp-set "emacs" @@ -981,7 +1050,7 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或 (tp-clear &optional START END OBJECT) ``` -清除区域中的所有文本属性。 +清除区域中的所有文本属性。返回 nil。 **示例：** @@ -1010,8 +1079,8 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或 #### `tp-match-set` - 匹配字符串 ```elisp -(tp-match-set PATTERN PLIST &optional OBJECT) -(tp-match-set PATTERN LAYER-NAME &optional OBJECT) +(tp-match-set PATTERN PLIST &optional OBJECT START END) +(tp-match-set PATTERN LAYER-NAME &optional OBJECT START END) ``` 在所有字符串模式匹配处设置属性。 @@ -1019,6 +1088,10 @@ PATTERN 可以是字符串（单个模式）或字符串列表（多个模式） PLIST 是属性列表，如 `'(face bold help-echo "tip")`。 LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。 OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 +START 和 END（0.3.0 新增）将匹配限制在 OBJECT 的 `[START, END)` 部分， +使用原生坐标（字符串从 0 开始，缓冲区从 1 开始）。匹配的行为**如同 +OBJECT 只由这一部分组成**，因此匹配不会跨越边界；颠倒的边界会被交换。 +全部六个 `tp-match-*` / `tp-regexp-*` 函数都接受同样的边界参数。 **示例：** @@ -1051,6 +1124,12 @@ OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 (insert "TODO: fix this. TODO: also this.") (tp-match-set "TODO" 'todo-style)) ;; => ((1 . 5) (17 . 21)) + +;; 用 START/END 边界限制匹配 - 只有第二个 TODO 在范围内 +(with-temp-buffer + (insert "TODO one TODO two") + (tp-match-set "TODO" '(face warning) nil 5 18)) +;; => ((10 . 14)) ``` --- @@ -1064,10 +1143,13 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或 OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 ```elisp -(tp-match-reset PATTERN PLIST &optional OBJECT) -(tp-match-reset PATTERN LAYER-NAME &optional OBJECT) +(tp-match-reset PATTERN PLIST &optional OBJECT START END) +(tp-match-reset PATTERN LAYER-NAME &optional OBJECT START END) ``` +START 和 END 将匹配限制在 OBJECT 的 `[START, END)` 部分 +（参见 [`tp-match-set`](#tp-match-set---匹配字符串)）。 + **示例：** ```elisp @@ -1105,10 +1187,13 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或 OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 ```elisp -(tp-match-add PATTERN PLIST &optional OBJECT) -(tp-match-add PATTERN LAYER-NAME &optional OBJECT) +(tp-match-add PATTERN PLIST &optional OBJECT START END) +(tp-match-add PATTERN LAYER-NAME &optional OBJECT START END) ``` +START 和 END 将匹配限制在 OBJECT 的 `[START, END)` 部分 +（参见 [`tp-match-set`](#tp-match-set---匹配字符串)）。 + **示例：** ```elisp @@ -1140,8 +1225,8 @@ OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 #### `tp-regexp-set` - 匹配正则表达式 ```elisp -(tp-regexp-set PATTERN PLIST &optional OBJECT) -(tp-regexp-set PATTERN LAYER-NAME &optional OBJECT) +(tp-regexp-set PATTERN PLIST &optional OBJECT START END SUBEXP) +(tp-regexp-set PATTERN LAYER-NAME &optional OBJECT START END SUBEXP) ``` 在所有正则表达式匹配处设置属性。 @@ -1149,6 +1234,13 @@ PATTERN 可以是字符串（单个正则）或字符串列表（多个正则） PLIST 是属性列表，如 `'(face bold help-echo "tip")`。 LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或通过 `define-tps` 定义的属性组名称。 OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 +START 和 END（0.3.0 新增）将匹配限制在 OBJECT 的 `[START, END)` 部分， +使用原生坐标；匹配的行为如同 OBJECT 只由这一部分组成，颠倒的边界会被 +交换（参见 [`tp-match-set`](#tp-match-set---匹配字符串)）。 +SUBEXP（0.3.0 新增）指定 PATTERN 的一个捕获组（1 = 第一个组，与 +font-lock 高亮的约定一致）：属性应用于每个匹配中的该捕获组，而不是整个 +匹配。捕获组未参与的匹配不贡献任何内容；SUBEXP 超出模式的捕获组数量时 +会发出明确的错误信号。全部三个 `tp-regexp-*` 函数都接受 SUBEXP。 **示例：** @@ -1177,6 +1269,28 @@ OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 (insert "abc 123 def 456") (tp-regexp-set "[0-9]+" 'number-style)) ;; => ((5 . 8) (13 . 16)) + +;; SUBEXP - 只对每个匹配的捕获组 1 设置属性 +(tp-regexp-set "\\([0-9]+\\)px" '(face bold) "margin: 10px 4px" nil nil 1) +;; => #("margin: 10px 4px" 8 10 (face bold) 13 14 (face bold)) + +;; 捕获组未参与的匹配不贡献任何内容： +;; "bar" 匹配该模式，但捕获组 1 只在 "foo" 中参与 +(tp-regexp-set "\\(foo\\)\\|bar" '(face bold) "foo bar" nil nil 1) +;; => #("foo bar" 0 3 (face bold)) + +;; SUBEXP 超出模式的捕获组数量时发出明确的错误信号 +(tp-regexp-set "[0-9]+" '(face bold) "abc 123" nil nil 2) +;; error: Regexp "[0-9]+" has no group 2 + +;; START/END 边界：如同只有这一部分存在 - 贪婪的 a+ +;; 恰好匹配 [1, 3) 而不是整段字符 +(tp-regexp-set "a+" '(face bold) "aaaa" 1 3) +;; => #("aaaa" 1 3 (face bold)) + +;; 颠倒的边界会被交换 +(tp-regexp-set "a+" '(face bold) "aaaa" 3 1) +;; => #("aaaa" 1 3 (face bold)) ``` --- @@ -1190,10 +1304,13 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或 OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 ```elisp -(tp-regexp-reset PATTERN PLIST &optional OBJECT) -(tp-regexp-reset PATTERN LAYER-NAME &optional OBJECT) +(tp-regexp-reset PATTERN PLIST &optional OBJECT START END SUBEXP) +(tp-regexp-reset PATTERN LAYER-NAME &optional OBJECT START END SUBEXP) ``` +START/END 边界和 SUBEXP 捕获组的用法与 +[`tp-regexp-set`](#tp-regexp-set---匹配正则表达式) 完全相同。 + **示例：** ```elisp @@ -1232,10 +1349,13 @@ LAYER-NAME 可以是通过 `define-tp` 定义的自定义文本属性名称或 OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 ```elisp -(tp-regexp-add PATTERN PLIST &optional OBJECT) -(tp-regexp-add PATTERN LAYER-NAME &optional OBJECT) +(tp-regexp-add PATTERN PLIST &optional OBJECT START END SUBEXP) +(tp-regexp-add PATTERN LAYER-NAME &optional OBJECT START END SUBEXP) ``` +START/END 边界和 SUBEXP 捕获组的用法与 +[`tp-regexp-set`](#tp-regexp-set---匹配正则表达式) 完全相同。 + **示例：** ```elisp @@ -1269,21 +1389,27 @@ OBJECT 是缓冲区或字符串；nil 表示当前缓冲区。 #### `tp-search-forward` / `tp-search-backward` -```elisp -(tp-search-forward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) -(tp-search-backward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) -``` +> ⚠️ **自 0.3.0 起已废弃。**这两个函数是 Emacs 的 +> `text-property-search-forward` / `text-property-search-backward` 的原 +> 始包装，其 nil-PREDICATE 默认行为（匹配非 nil 且与 VALUE **不** +> `equal` 的值）与本库其余部分使用的 `equal` 匹配相矛盾。请使用 +> [`tp-forward` / `tp-backward`](#tp-forward--tp-backward) 获得 tp 对称 +> 的 `equal` 匹配搜索 —— 它们现在也暴露了 PREDICATE 和 NOT-CURRENT —— +> 或者直接调用 Emacs 原语进行底层访问。这两个包装仍然可用，但已被标记 +> 为过时（字节编译器会对新的调用发出警告）。 -Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的原始包装。 -这些是直接使用 prop-match 对象的底层搜索函数。 +```elisp +(tp-search-forward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) ; deprecated +(tp-search-backward PROPERTY &optional VALUE PREDICATE NOT-CURRENT) ; deprecated +``` --- #### `tp-forward` / `tp-backward` ```elisp -(tp-forward PROPERTY &optional VALUE OBJECT N) -(tp-backward PROPERTY &optional VALUE OBJECT N) +(tp-forward PROPERTY &optional VALUE OBJECT N PREDICATE NOT-CURRENT) +(tp-backward PROPERTY &optional VALUE OBJECT N PREDICATE NOT-CURRENT) ``` 向前/向后搜索 N 次具有 PROPERTY 的文本。 @@ -1295,9 +1421,16 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 - **`tp-backward` 与 `tp-forward` 对称**：相同的 equal 匹配语义， 方向相反。 - **OBJECT** 可以是缓冲区或字符串；nil 默认为当前缓冲区。 +- **PREDICATE**（0.3.0 新增）自定义匹配方式：nil（默认值）和 t 都 + **完全**保持 0.2.0 的 `equal` 匹配契约；传入函数时以 `(VALUE PROP-VALUE)` + 调用，返回非 nil 即视为匹配。 +- **NOT-CURRENT**（0.3.0 新增）非 nil 时跳过包含 point 的匹配区段，与 + `text-property-search-*` 原语的行为一致。仅缓冲区路径有效；字符串没 + 有 point，因此在字符串上会被忽略。 - 对于缓冲区，返回最后一次成功搜索的 prop-match 对象。 -- 对于字符串，返回 PROPERTY 存在的各区段的 (START END VALUE) 列表； - VALUE 为 nil 表示匹配任意值。`tp-backward` 按从末尾到开头的顺序返回。 +- 对于字符串，返回**前 N 个** PROPERTY 匹配区段的 (START END VALUE) + 列表，从位置 0 开始计数（与 point 无关）；VALUE 为 nil 表示匹配任意 + 值。`tp-backward` 按从末尾到开头的顺序返回。 **示例：** @@ -1346,6 +1479,38 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 (tp-set 12 17 '(marker t) my-string) (tp-forward 'marker nil my-string 2)) ;; => ((0 5 t) (12 17 t)) + +;; PREDICATE - 用自定义函数代替 `equal' 进行匹配 +;; （调用参数为 VALUE 和该区段的属性值） +(with-temp-buffer + (insert "abcdef") + (tp-set 1 3 '(size 10)) + (tp-set 3 6 '(size 20)) + (goto-char 1) + (let ((match (tp-forward 'size 15 nil 1 + (lambda (target v) (and v (> v target)))))) + (list (prop-match-beginning match) (prop-match-end match)))) +;; => (3 6) ; 第一个 size 超过 15 的区段 + +;; PREDICATE 也适用于字符串（返回前 N 个匹配区段） +(let ((str (copy-sequence "hello world"))) + (tp-set 0 5 '(size 10) str) + (tp-set 6 11 '(size 20) str) + (tp-forward 'size 15 str 2 (lambda (target v) (and v (> v target))))) +;; => ((6 11 20)) + +;; NOT-CURRENT - 跳过包含 point 的匹配区段 +(with-temp-buffer + (insert "one two") + (tp-set 1 4 '(mark t)) + (tp-set 5 8 '(mark t)) + (let (a b) + (goto-char 2) ; 位于第一个 mark 区段内 + (setq a (prop-match-beginning (tp-forward 'mark t))) + (goto-char 2) + (setq b (prop-match-beginning (tp-forward 'mark t nil 1 nil t))) + (list a b))) +;; => (2 5) ; 不带 NOT-CURRENT 时当前区段在 point 处即匹配 ``` --- @@ -1353,11 +1518,14 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 #### `tp-forward-do` / `tp-backward-do` ```elisp -(tp-forward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END) -(tp-backward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END) +(tp-forward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END PREDICATE NOT-CURRENT) +(tp-backward-do FUNCTION PROPERTY &optional VALUE OBJECT TIMES START END PREDICATE NOT-CURRENT) ``` -在 OBJECT 的 START 到 END 范围内，向前/向后搜索匹配 PROPERTY 属性（值为 VALUE）的部分，**仅对最后一次匹配执行 FUNCTION 函数**。 +向前/向后搜索 TIMES 次具有 PROPERTY 的文本，**仅在第 TIMES 个匹配处应用 FUNCTION**。 + +尽管带有 `-do` 后缀，它并**不是** for-each —— 要对*每个*匹配应用函数， +请使用 [`tp-search-map`](#tp-search-map---对匹配文本应用函数)。 - **FUNCTION** 的参数是 `(TEXT &optional START END IDX)`，其中 TEXT 是此次匹配到的文本，START 和 END 为开始结束的位置，IDX 是从 0 开始的匹配索引。FUNCTION 会按其实际接受的参数个数被调用。当 FUNCTION 返回字符串时，它将替换字符串或缓冲区中的匹配文本。 - **在缓冲区中替换文本可以改变长度**（先删除匹配文本，再插入替换文本）。**字符串无法就地改变长度**：长度不同的替换会发出错误信号；长度相同的替换会就地应用。 @@ -1366,6 +1534,9 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 - **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。 - **TIMES** 表示向前/向后搜索几次，默认搜索一次。该函数会搜索 TIMES 次，但仅对第 TIMES 个匹配应用 FUNCTION。要么全有要么全无：当匹配数量不足 TIMES 时，完全不应用 FUNCTION，仅返回实际找到的匹配数量。 - **START** 和 **END** 默认为 OBJECT 的起始和结束位置。 +- **PREDICATE** 和 **NOT-CURRENT**（0.3.0 新增）的用法与 + [`tp-forward` / `tp-backward`](#tp-forward--tp-backward) 相同，并被应 + 用到每一次底层搜索；默认值完全保持 0.2.0 的行为。 - 返回成功匹配的数量。 **示例：** @@ -1385,7 +1556,9 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 (tp-set 12 17 '(marker t) my-string) (tp-forward-do #'upcase 'marker nil my-string 2 6 17) my-string) -;; => "hello world HELLO" ; 范围 6-17 内仅有 1 个匹配 +;; => "hello world hello" ; 范围 6-17 内仅有 1 个匹配，请求的 +;; 第 2 个匹配不存在：不做任何应用（要么全有要么全无； +;; 调用仍返回实际匹配数 1） ;; 使用带有 start 和 end 参数的函数 ;; 函数接收位置信息；使用 upcase 保持相同长度 @@ -1623,9 +1796,15 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 #### `define-tp` / `define-tps` - 定义自定义文本属性 +> 自 0.3.0 起，符合前缀规范的别名 `tp-define-layer`（对应 +> `define-tp`）、`tp-define-group`（对应 `define-tps`）和 +> `tp-define-palette`（对应 `define-tp-palette`）是今后的规范名称 —— +> 它们让这些宏可以通过 `C-h f tp-...` 被发现。历史名称是永久别名，永远 +> 不会被移除；本 README 的示例仍继续使用它们。 + ##### `define-tp` - 定义单个自定义文本属性（层） -定义自定义文本属性，名称无需单引号引用。**所有格式中参数列表都是必需的**：无参数层（包括响应式关键字格式）用 `()`，参数化层用 `(ARG)`。支持三种格式： +定义自定义文本属性，名称无需单引号引用。**所有格式中参数列表都是必需的**：无参数层（包括响应式关键字格式）用 `()`，参数化层用 `(ARG1 ARG2 ...)`，可包含任意数量的参数符号。支持三种格式： **格式一 - 无参数（空参数列表，简单属性）：** @@ -1638,7 +1817,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 (tp-set 0 5 '(tp-bold t) "emacs") ``` -**格式二 - 有参数（带单个参数）：** +**格式二 - 有参数（带一个或多个参数）：** ```elisp (define-tp tp-space (pixel) @@ -1649,6 +1828,42 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 (tp-set 0 5 '(tp-space 2) "emacs") ``` +自 0.3.0 起，参数列表可以声明**任意数量的参数**。调用规格既接受平铺的 +参数 —— `(LAYER ARG1 ... ARGN)` —— 也接受包在一个列表中的参数 —— +`(LAYER (ARG1 ... ARGN))` —— 两种写法在 `tp-set` 和 `tp-put-layer` 中 +都有效： + +```elisp +(define-tp tp-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + +;; 整字符串形式：参数跟在层名后面 +(tp-set "hello" 'tp-colors "red" "blue") +;; => #("hello" 0 5 (face (:foreground "red" :background "blue"))) + +;; 区域形式，包装的参数列表外加额外属性 +(let ((str (copy-sequence "hello"))) + (tp-set 0 5 '(tp-colors ("red" "blue") help-echo "tip") str) + (list (tp-at 0 'face str) (tp-at 0 'help-echo str))) +;; => ((:foreground "red" :background "blue") "tip") + +;; tp-put-layer 规格 +(with-temp-buffer + (insert "Hello World") + (tp-put-layer 1 10 '(tp-colors "white" "black") 0) + (tp-at 1 'face)) +;; => (:foreground "white" :background "black") + +;; 参数个数不符的调用会发出明确的错误信号，指出层名和两个数量 +(tp-set "hello" 'tp-colors "red") +;; error: tp layer tp-colors takes 2 argument(s), got 1 +``` + +参数化层组（`define-tps`）以同样的方式接受多个参数； +`(GROUP ARG1 ... ARGN)` 和 `(GROUP (ARG1 ... ARGN))` 规格在 `tp-set` +家族中都有效。注意：参数化 body 中的 `$` 符号在展开时解析为其变量的当 +前值 —— 参数化层**不是**响应式的。 + **格式三 - 响应式特性（支持 :props、:data、:compute、:watch、:transform）：** ```elisp @@ -1678,7 +1893,7 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 ##### `define-tps` - 定义自定义文本属性组（层组） -定义多个相关的自定义文本属性，名称无需单引号引用。与 `define-tp` 一样，**参数列表是必需的**：无参数层组用 `()`，参数化层组用 `(ARG)`。属性组中定义的文本属性可以单独使用，也可以使用组名称来设置多层。 +定义多个相关的自定义文本属性，名称无需单引号引用。与 `define-tp` 一样，**参数列表是必需的**：无参数层组用 `()`，参数化层组用 `(ARG1 ARG2 ...)`（自 0.3.0 起支持任意数量的参数）。属性组中定义的文本属性可以单独使用，也可以使用组名称来设置多层。 **格式一 - 无参数（空参数列表）：** @@ -1813,6 +2028,8 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 ;; => #("emacs" 0 5 (face (:foreground "orange") tp-name tp-test-l1 ;; tp-layers ((face (:foreground "red") tp-name tp-test-l2) ;; (face (:background "green") tp-name tp-test-l3)))) +;; （顶层属性的打印顺序在不同 Emacs 版本间可能不同， +;; tp-layers 栈内顺序本身是稳定的） ``` --- @@ -1859,6 +2076,87 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 --- +#### `tp-layer-props-with-args` / `tp-group-props-with-args` / `tp-layer-arglist` + +```elisp +(tp-layer-props-with-args LAYER-NAME ARGS &optional INCLUDE-TP-NAME) +(tp-group-props-with-args GROUP-NAME ARGS &optional INCLUDE-TP-NAME) +(tp-layer-arglist LAYER-NAME) +``` + +针对**参数化**属性层和属性层组的自省函数（0.3.0 新增）： + +- **`tp-layer-props-with-args`** 用 ARGS 展开参数化属性层，ARGS 是按位 + 置绑定到层参数的值列表。多余的值会被忽略；值的数量少于参数数量时会发 + 出参数个数不符的错误信号。返回一个全新的副本（修改它不会破坏注册 + 表）；对无参数或未定义的层返回 nil。原有的单参数 + `tp-layer-props-with-arg`（注意名称只差一个字符）保留为一个薄薄的 + `(list ARG)` 包装。 +- **`tp-group-props-with-args`** 是层组版本，返回展开后的逐层 plist 列 + 表；`tp-group-props-with-arg` 保留为单参数便捷形式。 +- **`tp-layer-arglist`** 返回层参数列表的副本；当 LAYER-NAME 不是参数 + 化层时返回 nil。 + +**示例：** + +```elisp +(progn + (tp-layer-reset) + (define-tp tp-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + (tp-layer-props-with-args 'tp-colors '("red" "blue"))) +;; => (face (:foreground "red" :background "blue")) + +;; 参数列表本身 +(tp-layer-arglist 'tp-colors) +;; => (fg bg) + +;; 层组展开为每层一个 plist +(progn + (define-tps tp-badge (fg bg) + `(tp-colors ,fg ,bg) + '(face bold)) + (tp-group-props-with-args 'tp-badge '("white" "black"))) +;; => ((face (:foreground "white" :background "black")) (face bold)) + +;; 参数太少时发出与 tp-set 相同的明确错误信号 +(tp-layer-props-with-args 'tp-colors '("red")) +;; error: tp layer tp-colors takes 2 argument(s), got 1 +``` + +--- + +#### `tp-describe-layer` - 描述属性层 + +```elisp +(tp-describe-layer NAME) ; interactive +``` + +弹出一个帮助缓冲区，描述属性层 NAME（交互式调用时可在所有已注册层中补 +全）。该缓冲区会展示存储格式（flat / unified / parameterized / +reactive）、原始存储的 body、展开后的属性（参数化层需要参数，因此显示 +占位说明）、参数列表、该层依赖的响应式变量、是否注册了 transform，以及 +生成该层的层组（如果有）。 + +```elisp +(progn + (tp-layer-reset) + (define-tp tp-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + (tp-describe-layer 'tp-colors)) +;; 弹出一个 *Help* 缓冲区: +;; tp-colors is a tp layer. +;; +;; Storage format: parameterized +;; Arguments: (fg bg) +;; Stored body: `(face (:foreground ,fg :background ,bg)) +;; Expanded props: parameterized layer: expand with `tp-layer-props-with-args' +;; Reactive deps: none +;; Transform: no +``` + +--- + #### `tp-undefine-layer` / `tp-undefine-group` ```elisp @@ -1942,14 +2240,29 @@ Emacs 的 `text-property-search-forward` 和 `text-property-search-backward` 的 ### 属性层放置 +> ⚠️ **栈操作的字符串形式会就地修改字符串。**与返回**新**属性字符串的 +> `tp-set` 不同，每一个栈修改函数（`tp-put-layer`、`tp-push-layer`、 +> `tp-pop-layer`、`tp-delete-layer`、`tp-move-layer`、`tp-raise-layer`、 +> `tp-lower-layer`、`tp-rotate-layer`、`tp-pin-layer`、 +> `tp-switch-layer`、`tp-hide-layer`、`tp-show-layer`、 +> `tp-merge-layers`、`tp-flatten-layers`、`tp-add-to-layers`、 +> `tp-add-to-all-layers`）的字符串形式都会**破坏性地**修改 STRING。绝 +> 不要传入字符串字面量或不属于你的共享字符串 —— 请先用 +> `copy-sequence`。将这一行为与 `tp-set` 的复制语义统一已列入 0.4 计划。 + +**返回值（0.3.0）：**`tp-put-layer` / `tp-push-layer` 在给定 OBJECT 时 +返回 OBJECT（字符串形式返回该字符串本身），否则返回 `(START . END)`。 +其余每个栈修改函数都返回**被修改的属性区段数量**；层名或索引不存在时 +从不发出错误信号 —— 未匹配的区段被静默跳过，返回 0 表示没有任何匹配。 + #### `tp-put-layer` - 在指定位置设置属性层 ```elisp ;; 缓冲区/字符串区域 -(tp-put-layer START END LAYER IDX OBJECT) +(tp-put-layer START END LAYER IDX OBJECT NOERROR) ;; 整个字符串 -(tp-put-layer STRING LAYER IDX) +(tp-put-layer STRING LAYER IDX NOERROR) ``` 在属性层堆栈的指定索引位置设置属性层。 @@ -1963,11 +2276,17 @@ LAYER 接受以下几种形式： - 用 `define-tp` 定义的层名：`'highlight` - 内联属性 plist（无需 `define-tp`）：`'(face bold help-echo "tip")` - 层名列表（第一个层名位于顶部）：`'(layer-a layer-b)` -- 参数化层调用：`'(tp-color "red")` +- 参数化层调用：`'(tp-color "red")` —— 多参数层同样可用： + `'(tp-colors "white" "black")` **栈模型：**只有顶层的属性是可见的文本属性；下层被保存在 `tp-layers` 文本属性中，直到被上移、轮换或扁平化。 +**NOERROR（0.3.0 新增）：**LAYER 指向未定义的层或层组时，通常会发出错 +误信号。NOERROR 非 nil 时，调用改为返回 nil 且不做任何修改 —— 在应用 +可能尚未定义的层时非常方便。`tp-push-layer` 接受同样的末尾 NOERROR 参 +数。 + **示例：** ```elisp @@ -2034,6 +2353,12 @@ LAYER 接受以下几种形式： (tp-put-layer 1 10 '(tp-color "red") 0) (tp-at 1 'face))) ;; => (:foreground "red") + +;; NOERROR - 未定义的层名返回 nil 而不发出错误信号 +(with-temp-buffer + (insert "Hello World") + (tp-put-layer 1 10 'no-such-layer 0 nil t)) +;; => nil ; 没有任何修改 ``` --- @@ -2042,13 +2367,16 @@ LAYER 接受以下几种形式： ```elisp ;; 缓冲区/字符串区域 -(tp-push-layer START END LAYER OBJECT) +(tp-push-layer START END LAYER OBJECT NOERROR) ;; 整个字符串 -(tp-push-layer STRING LAYER) +(tp-push-layer STRING LAYER NOERROR) ``` 将属性层推到堆栈顶部（相当于 `tp-put-layer ... 0`）。 +NOERROR（0.3.0 新增）的用法与 +[`tp-put-layer`](#tp-put-layer---在指定位置设置属性层) 相同：未定义的 +LAYER 返回 nil 而不发出错误信号。 **示例：** @@ -2300,17 +2628,69 @@ LAYER 接受以下几种形式： --- -#### `tp-rotate-layer` - 轮换属性层 +#### `tp-lower-layer` - `tp-raise-layer` 的镜像 ```elisp ;; 缓冲区/字符串区域 -(tp-rotate-layer START END OBJECT) +(tp-lower-layer START END IDX/LAYER-NAME N OBJECT) ;; 整个字符串 -(tp-rotate-layer STRING) +(tp-lower-layer STRING IDX/LAYER-NAME N) ``` -轮换属性层 - 顶层移到底部，下一层变为可见。 +将属性层下移 N 个位置（0.3.0 新增）。它是 `tp-raise-layer` 的镜像：正 +数 N 向底部移动，负数 N 向顶部移动。N 默认为 1，最终位置会被钳制在栈的 +范围内。返回被修改的属性区段数量。 + +**示例：** + +```elisp +;; 将顶层下移一个位置 +(progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(face italic)) + (define-tp layer3 () '(face underline)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + ;; 堆栈: layer3 (顶), layer2, layer1 (底) + (tp-lower-layer 1 10 'layer3 1) + ;; 堆栈: layer2 (顶), layer3, layer1 (底) + (list (tp-layer-top 1 10) (tp-layer-list 1 10)))) +;; => (layer2 (layer2 layer3 layer1)) +``` + +--- + +#### `tp-rotate-layer` - 轮换属性层 + +```elisp +;; 缓冲区/字符串区域（规范顺序，OBJECT 在最后 - 0.3.0 新增） +(tp-rotate-layer START END DIRECTION &optional COUNT OBJECT) + +;; 整个字符串 +(tp-rotate-layer STRING DIRECTION COUNT) + +;; 缓冲区/字符串区域（历史顺序，永远保持可用） +(tp-rotate-layer START END OBJECT) +``` + +将属性层轮换 COUNT 步，保持它们的相对顺序。 + +- **DIRECTION** 为 `down` 或 nil 时将顶层移到底部（历史行为），为 + `up` 时将底层带到顶部；其他值会发出错误信号。 +- **COUNT** 是轮换的步数，默认为 1；COUNT 小于 1 时不做任何轮换。隐藏 + 层随栈中其他层一起轮换。 +- 返回被修改的属性区段数量。 + +两种区域顺序通过第三个参数区分：符号 `up` / `down` 永远不是合法的 +OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的 +`(START END DIRECTION [COUNT] [OBJECT])` 顺序 —— 无需 nil OBJECT 占位。 +第三个参数为其他值（缓冲区、字符串，或表示当前缓冲区的 nil）时选中历 +史的 `(START END OBJECT [DIRECTION] [COUNT])` 顺序，后者继续可用。 **示例：** @@ -2329,6 +2709,37 @@ LAYER 接受以下几种形式： ;; 堆栈: base (顶) -> highlight (底) (tp-layer-top 1 10))) ;; => base + +;; 规范顺序：`up' 将底层带到顶部 +(progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(face italic)) + (define-tp layer3 () '(face underline)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + ;; 堆栈: layer3 (顶), layer2, layer1 (底) + (tp-rotate-layer 1 10 'up) + (tp-layer-list 1 10))) +;; => (layer1 layer3 layer2) + +;; COUNT 一次轮换多步 +(progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(face italic)) + (define-tp layer3 () '(face underline)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + (tp-rotate-layer 1 10 'down 2) + (tp-layer-list 1 10))) +;; => (layer1 layer3 layer2) ``` --- @@ -2343,7 +2754,9 @@ LAYER 接受以下几种形式： (tp-pin-layer STRING IDX/LAYER-NAME) ``` -将特定属性层移到顶部（使其可见）。 +将属性层移到栈顶。**一次性操作**：尽管名字里有 pin，但没有任何东西会 +保持"钉住"状态 —— 这只是一次移动到索引 0 的操作，之后的 +`tp-push-layer` 或 `tp-put-layer` 仍然可以覆盖被移动的层。 **示例：** @@ -2398,6 +2811,105 @@ LAYER 接受以下几种形式： --- +### 属性层可见性 + +#### `tp-hide-layer` / `tp-show-layer` - 隐藏与显示属性层 + +```elisp +;; 缓冲区/字符串区域 +(tp-hide-layer START END NAME OBJECT) +(tp-show-layer START END NAME OBJECT) + +;; 整个字符串 +(tp-hide-layer STRING NAME) +(tp-show-layer STRING NAME) +``` + +隐藏属性层而不移除它，以及让它重新渲染（0.3.0 新增）。NAME 标识属性 +层：层名符号，或指向完整栈（包含隐藏层）的整数索引（0 = 顶层，-1 = +底层）。 + +**可见性模型：** + +- 隐藏层**仍留在栈中**：它仍计入 `tp-layer-count`，出现在 + `tp-layer-list` 和 `tp-layer-stack-at` 中，也可以被移动、上移或下移 + —— 但它不渲染。文本改为展示最顶部**未隐藏**层的属性。 +- 因此隐藏当前可见的顶层会显露它下面的下一个可见层。 +- 当**所有**层都被隐藏时，文本以裸文本渲染（只剩 `tp-layers` 这个簿记 + 属性 —— 连 `tp-name` 也不渲染），同时所有层仍然可查询。 +- 隐藏层在隐藏期间**持续接收响应式更新**，因此 `tp-show-layer` 总是显 + 露最新的值（参见[层-缓冲区注册表与生命周期](#层-缓冲区注册表与生命周期)）。 +- `tp-flatten-layers` 只合并可见层，`tp-merge-layers` 排除隐藏的匹配层 + 的属性 —— 隐藏的内容绝不会泄漏（参见[属性层合并](#属性层合并)）。 +- 隐藏状态以 `tp-hidden` 标志的形式存储在 `tp-layers` 栈存储内该层的 + plist 中，因此 `tp-hidden` 与 `tp-name` 一样是层内部的保留属性名。 + +两个函数都返回被修改的属性区段数量。NAME 不匹配任何层时从不发出错误信 +号，隐藏一个已隐藏的层（或显示一个可见的层）是静默的空操作 —— 返回 0 +表示没有任何变化。 + +**示例：** + +```elisp +;; 隐藏顶层会显露下面的层；栈保持完整 +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (list :visible (tp-at 1 'tp-name) + :face (tp-at 1 'face) + :count (tp-layer-count 1 10) + :layers (tp-layer-list 1 10)))) +;; => (:visible base :face default :count 2 :layers (highlight base)) + +;; 所有层都隐藏时文本以裸文本渲染 +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-hide-layer 1 10 'base) + (list :face (tp-at 1 'face) :count (tp-layer-count 1 10)))) +;; => (:face nil :count 2) + +;; tp-show-layer 恢复该层的渲染 +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-show-layer 1 10 'highlight) + (tp-at 1 'face))) +;; => (:background "yellow") + +;; 返回值：被修改的区段数量；名称不存在时静默返回 0 +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (list (tp-hide-layer 1 10 'base) + (tp-hide-layer 1 10 'base) ; 已经隐藏 + (tp-hide-layer 1 10 'nonexistent)))) ; 没有这个层 +;; => (1 0 0) +``` + +--- + ### 属性层合并 #### `tp-merge-layers` - 合并多个属性层 @@ -2412,6 +2924,12 @@ LAYER 接受以下几种形式： 将指定的属性层合并为一个新属性层。列表中靠前的属性层优先级更高。 +**隐藏层（0.3.0）：**隐藏的匹配层会和其他层一起被合并掉，但**不**向合 +并层贡献任何属性，因此合并绝不会渲染出被隐藏的内容。当*所有*匹配层都 +被隐藏时，合并层保留它们合并后的属性，但自身携带 `tp-hidden` 标志 —— +数据被保留而没有取消任何隐藏，对合并层执行 `tp-show-layer` 即可渲染 +它。返回被修改的属性区段数量（0 = 列出的层都没有匹配）。 + **示例：** ```elisp @@ -2440,6 +2958,22 @@ LAYER 接受以下几种形式： (tp-merge-layers 1 10 'merged '(0 1)) (tp-layer-count 1 10))) ;; => 1 + +;; 隐藏层的属性绝不会泄漏进合并结果 +(progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(help-echo "tip")) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-hide-layer 1 10 'layer2) + (tp-merge-layers 1 10 'merged '(layer1 layer2)) + (list :face (tp-at 1 'face) + :help (tp-at 1 'help-echo) + :name (tp-at 1 'tp-name)))) +;; => (:face bold :help nil :name merged) ; layer2 被隐藏了 ``` --- @@ -2456,6 +2990,12 @@ LAYER 接受以下几种形式： 将所有属性层扁平化为一个具有给定名称的单一属性层。 +**隐藏层（0.3.0）：**隐藏层会被**丢弃**，与图像编辑器的扁平化语义一致 +—— 只有可见层的属性会合并进结果，因此扁平化绝不会渲染出被隐藏的内容。 +当某个区段的*所有*层都被隐藏时，该区段的属性会被完全清除（裸文本）， +与 `tp-hide-layer` 的全隐藏渲染行为一致。返回被修改的属性区段数量 +（0 = 没有区段带有属性层）。 + **示例：** ```elisp @@ -2482,6 +3022,20 @@ LAYER 接受以下几种形式： (tp-flatten-layers 1 10 nil) (tp-at 1 'tp-name))) ;; => nil + +;; 扁平化会丢弃隐藏层 +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-flatten-layers 1 10 'flat) + (list (tp-at 1 'face) (tp-at 1 'tp-name)))) +;; => (default flat) ; highlight 的背景色消失了 ``` --- @@ -2568,7 +3122,9 @@ LAYER 接受以下几种形式： (tp-layer-top START END &optional OBJECT) ``` -获取顶层（可见）属性层的名称。 +获取顶层属性层的名称。最顶部的层按**栈序**报告，即使它被隐藏（参见 +[`tp-hide-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层)）； +要区分隐藏层和可见层，请使用 `tp-layer-stack-at`。 **示例：** @@ -2587,6 +3143,61 @@ LAYER 接受以下几种形式： --- +#### `tp-layer-stack-at` - 获取某位置的完整层栈 + +```elisp +(tp-layer-stack-at POS &optional OBJECT) +``` + +返回某一位置上完整的有序层栈（0.3.0 新增），列表中每层一个元素，最顶 +层在前，每个元素是一个 cons `(NAME . PROPS)`： + +- **NAME** 是层的 `tp-name` 符号，无名层为 nil。 +- **PROPS** 是层的属性 plist，其中不含 `tp-name` 条目。隐藏层可通过 + PROPS 中值为 t 的 `tp-hidden` 条目辨认；可见层永远不携带该条目。 + +隐藏层按其栈位置包含在内。裸文本返回 nil。POS 使用 OBJECT 的原生坐标 +（字符串从 0 开始，缓冲区从 1 开始）；OBJECT 是字符串、缓冲区，或表示 +当前缓冲区的 nil。 + +**示例：** + +```elisp +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-layer-stack-at 1))) +;; => ((highlight . (face (:background "yellow"))) +;; (base . (face default))) + +;; 隐藏层在 PROPS 中携带 `tp-hidden' 条目 +(progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-layer-stack-at 1))) +;; => ((highlight . (tp-hidden t face (:background "yellow"))) +;; (base . (face default))) + +;; 裸文本没有层栈 +(with-temp-buffer + (insert "Hello") + (tp-layer-stack-at 1)) +;; => nil +``` + +--- + #### `tp-add-to-layers` - 向特定属性层添加属性 ```elisp @@ -2602,7 +3213,8 @@ LAYER 接受以下几种形式： - **IDX-OR-LAYER-NAME-LIST** 是层索引（整数）或层名称（符号）的列表。对于索引：0 表示顶层，-1 表示底层。 - 属性被深度合并到指定的层中（嵌套的 plist 被合并，而非替换）。 - OBJECT 在区域形式中默认为当前缓冲区。 -- 对于字符串，返回一个新的字符串（原始字符串不变）。对于缓冲区，返回 nil。 +- 与其他栈修改函数一样（且与 `tp-set` 不同），字符串形式会**就地**修 + 改 STRING 并返回这个被修改的字符串本身。对于缓冲区，返回 nil。 **示例：** @@ -2637,7 +3249,8 @@ LAYER 接受以下几种形式： - 属性被深度合并到所有现有层中。 - OBJECT 在区域形式中默认为当前缓冲区。 -- 对于字符串，返回一个新的字符串（原始字符串不变）。对于缓冲区，返回 nil。 +- 与其他栈修改函数一样（且与 `tp-set` 不同），字符串形式会**就地**修 + 改 STRING 并返回这个被修改的字符串本身。对于缓冲区，返回 nil。 **示例：** @@ -2657,15 +3270,18 @@ LAYER 接受以下几种形式： #### `tp-intervals` - 获取文本属性区间 ```elisp -(tp-intervals START END &optional OBJECT) +(tp-intervals START END &optional OBJECT ABSOLUTE) ``` 从 OBJECT 中获取 START 到 END 之间的所有文本属性区间。 - 返回每个区间的 (START END PROPERTIES) 列表，包括没有属性的 间隙区间，其 PROPERTIES 为 nil。 -- 对于缓冲区输入，START 和 END 是从 1 开始的缓冲区位置，但返回的位置是 - **相对于 START 的 0 基偏移量**。对于字符串，位置是绝对的 0 基索引。 +- 对于缓冲区输入，START 和 END 是从 1 开始的缓冲区位置，但返回的位置 + 默认是**相对于 START 的 0 基偏移量**（历史约定）。ABSOLUTE 非 nil + 时（0.3.0 新增），返回的位置改为原生的 1 基缓冲区位置，可以不做偏移 + 运算直接用于其他 tp 调用（`tp-set`、`tp-remove` 等）。对于字符串， + 位置始终是绝对的 0 基索引；ABSOLUTE 不改变任何行为。 - 使用 `object-intervals`（需要 Emacs 28.1+）。 - OBJECT 可以是缓冲区或字符串；nil 默认为当前缓冲区。 @@ -2679,6 +3295,24 @@ LAYER 接受以下几种形式： (tp-intervals 1 12)) ;; => ((0 5 (face bold)) (5 6 nil) (6 11 (face italic))) ;; 位置是相对 START 的偏移量；(5 6 nil) 是无属性的间隙 + +;; ABSOLUTE - 原生缓冲区坐标 +(with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (tp-set 7 12 '(face italic)) + (tp-intervals 1 12 nil t)) +;; => ((1 6 (face bold)) (6 7 nil) (7 12 (face italic))) + +;; ABSOLUTE 位置可直接回馈给其他 tp 调用 +(with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (dolist (iv (tp-intervals 1 12 nil t)) + (when (eq (plist-get (nth 2 iv) 'face) 'bold) + (tp-add (nth 0 iv) (nth 1 iv) '(help-echo "bold text")))) + (tp-at 1 'help-echo)) +;; => "bold text" ``` --- @@ -2686,13 +3320,18 @@ LAYER 接受以下几种形式： #### `tp-intervals-map` - 对区间应用函数 ```elisp -(tp-intervals-map FUNCTION START END &optional OBJECT) +(tp-intervals-map FUNCTION START END &optional OBJECT ABSOLUTE) ``` 对 OBJECT 中 START 到 END 之间的所有区间应用 FUNCTION。 -- FUNCTION 接收四个参数：interval-start、interval-end、top-props（可见层属性）和 below-props-lst（隐藏层列表）。 -- 没有属性的区间也会被访问，此时 top-props 为 nil（位置遵循与 `tp-intervals` 相同的偏移量约定）。 +- FUNCTION 接收四个参数：interval-start、interval-end、top-props（直 + 接渲染的属性，其中的 `tp-layers` 条目已被移除）和 below-props-lst + （`tp-layers` 的值：埋在被渲染顶层之下的层 plist 存储 —— 当任何层被 + 隐藏时它保存整个有序层栈；解码后的视图参见 + [`tp-layer-stack-at`](#tp-layer-stack-at---获取某位置的完整层栈)）。 +- 没有属性的区间也会被访问，此时 top-props 为 nil（位置遵循与 + `tp-intervals` 相同的坐标约定，包括 0.3.0 新增的 ABSOLUTE 参数）。 - OBJECT 可以是缓冲区或字符串；nil 默认为当前缓冲区。 - 返回函数结果列表（nil 结果被移除）。 @@ -2708,6 +3347,17 @@ LAYER 接受以下几种形式： (list start end (plist-get props 'face))) 1 12)) ;; => ((0 5 bold) (5 6 nil) (6 11 italic)) + +;; ABSOLUTE - FUNCTION 接收原生缓冲区位置 +(with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (tp-set 7 12 '(face italic)) + (tp-intervals-map + (lambda (start end props belows) + (list start end (plist-get props 'face))) + 1 12 nil t)) +;; => ((1 6 bold) (6 7 nil) (7 12 italic)) ``` --- @@ -2832,7 +3482,8 @@ LAYER 接受以下几种形式： - **`tp-palette-alist`**（变量）— `(NAME . PLIST)` 形式的调色板定义 alist；调色板查询的唯一数据源。每个 PLIST 将 `:fg`、`:bg` 和 `:border` 映射到颜色。 -- **`define-tp-palette`** — 注册（或更新）一个调色板： +- **`define-tp-palette`** — 注册（或更新）一个调色板（自 0.3.0 起也可 + 使用符合前缀规范的别名 `tp-define-palette`）： ```elisp (define-tp-palette my-brand @@ -2840,6 +3491,37 @@ LAYER 接受以下几种形式： :bg ("#ddf4ff" . "#1f3d5c")) ``` +- **`tp-palette-color`**（0.3.0 新增）— **首选的**调色板访问器：获取调 + 色板的 `:fg` / `:bg` / `:border` 颜色，按当前亮色/暗色主题解析。调色 + 板或键不存在时返回 nil： + + ```elisp + (tp-palette-color 'info :fg) + ;; => 亮色主题下为 "#0969da"，暗色主题下为 "#58a6ff" + (tp-palette-color 'no-such-palette :fg) + ;; => nil + ``` + +- **`tp-palette-has-p`**（0.3.0 新增）— **首选的**调色板谓词：只传 + SYMBOL 时测试它是否命名了一个已注册的调色板；KIND 为 `:fg` / `:bg` / + `:border` 之一时，还要求其定义中含有该键（已定义的键在当前主题下仍 + 可能解析不出颜色 —— 在意解析后颜色时请使用 `tp-palette-color`）： + + ```elisp + (list (tp-palette-has-p 'info) + (tp-palette-has-p 'info :border) + (tp-palette-has-p 'no-such-palette)) + ;; => (t t nil) + ``` + + 旧的按键便捷函数保留为兼容包装：`tp-palette-fg-color` / + `tp-palette-bg-color` / `tp-palette-border-color`（`tp-palette-color` + 的固定 KEY 变体）、`tp-palette-p`（KIND 为 nil 的 + `tp-palette-has-p`），以及带后缀名的谓词 `tp-palette-fg-p` / + `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p` —— 它 + 们回答的是另一个问题：像 `info-fg` 这样的*变体名*是否表示一个已注册 + 的调色板（`tp-palette` 层使用的约定）。 + - **`tp-palette-show`** — 交互式命令，显示一个画廊缓冲区，展示每个已 注册调色板及其 `-fg` / `-bg` / `-fbg` / `-border` 变体（按 `q` 退出）。 - **`tp-parse-color`** — 按当前主题解析颜色规格。接受普通颜色字符串、 @@ -3175,6 +3857,127 @@ LAYER 接受以下几种形式： - 提高同时更改多个变量时的性能 - 当多个变量相互依赖时确保状态一致 +### 层-缓冲区注册表与生命周期 + +自 0.3.0 起，响应式引擎维护一个**层→缓冲区注册表**：每条修改缓冲区并 +盖上层标记的写入路径（`tp-set` 家族、栈修改函数、match/regexp 应用函 +数）都会把目标缓冲区注册为展示该层，而一次响应式更新只访问**已注册的 +缓冲区**，不再扫描整个 `(buffer-list)`。被杀死的缓冲区会被自动清理。 +当某个层完全没有注册表条目时，会退回到旧行为做一次**学习性全量扫描**， +并把实际发现该层的每个缓冲区都注册上。 + +即使层被**隐藏**或**埋**在栈中其他层之下，更新也能到达它的区域：存储 +在 `tp-layers` 中的条目会被就地更新，因此 `tp-show-layer`（或上移该 +层）总是显露最新的值。 + +#### `tp-reactive-layer-buffers` - 查看注册表 + +```elisp +(tp-reactive-layer-buffers LAYER-NAME) +``` + +返回注册为展示 LAYER-NAME 的存活缓冲区 —— 一个列表（可能为空，表示 +"已知：没有缓冲区展示该层"）—— 或者符号 `unknown`，表示该层完全没有注 +册表条目： + +```elisp +(progn + (tp-layer-reset) + (defvar reg-color "red") + (define-tp reg-layer () + :props '(face (:foreground $reg-color))) + (tp-reactive-layer-buffers 'reg-layer)) +;; => unknown ; 还从未被应用到任何缓冲区 + +(with-temp-buffer + (rename-buffer "demo-buffer" t) + (insert "Hello") + (tp-push-layer 1 6 'reg-layer) + (mapcar #'buffer-name (tp-reactive-layer-buffers 'reg-layer))) +;; => ("demo-buffer") +``` + +#### `tp-reactive-track-buffer` - 补齐字符串插入的缺口 + +```elisp +(tp-reactive-track-buffer &optional BUFFER) ; interactive +``` + +**已知缺口：**向缓冲区插入一个*已经带属性的字符串*会绕过注册缓冲区的 +缓冲区操作，因此在一次学习性全量扫描找到它之前，该缓冲区不在注册表中。 +在这类插入之后调用 `tp-reactive-track-buffer`：它会扫描 BUFFER（默认 +为当前缓冲区）中的层区域 —— 既包括被渲染的顶层，也包括埋在或隐藏在 +`tp-layers` 栈存储中的层 —— 为每个层注册该缓冲区，并按缓冲区顺序返回 +找到的层名： + +```elisp +(let ((s (tp-set "hello" 'reg-layer))) ; 带属性的字符串，游离状态 + (with-temp-buffer + (insert s) ; 绕过了注册 + (tp-reactive-track-buffer))) +;; => (reg-layer) ; 缓冲区现已为 reg-layer 注册 +``` + +#### `tp-gc-anonymous-layers` - 回收未使用的匿名层 + +```elisp +(tp-gc-anonymous-layers) ; interactive +``` + +[匿名响应式层](#匿名响应式层)是被驻留（intern）的：`equal` 相同的属性 +规格会复用其注册表条目，而不是在每次 `tp-set` 时铸造一个新层。 +`tp-gc-anonymous-layers` 取消定义所有已无注册的存活缓冲区仍在展示的驻 +留匿名层（被埋住和被隐藏的层都算作存活），并返回被回收的层名： + +```elisp +(defvar tmp-color "green") +(let ((buf (generate-new-buffer "*gc-demo*"))) + (with-current-buffer buf + (insert "Hello") + (tp-set 1 6 '(face (:foreground $tmp-color)))) ; 匿名层 + (kill-buffer buf) + (tp-gc-anonymous-layers)) +;; => (tp-anon-1) ; 被回收的层名（计数器数字会变化） +``` + +**保守的 `unknown` 语义：**注册表状态为 `unknown` 的层 —— 从未通过任 +何注册路径出现在任何缓冲区中，例如只被游离字符串引用 —— 会被刻意 +**保留**。一个层只有在至少为一个缓冲区注册过、且所有已注册的缓冲区都不再 +展示它（例如全部被杀死）之后才可回收。在插入带属性的字符串后请调用 +`tp-reactive-track-buffer`，让它们所在的缓冲区也被注册。 + +#### 最小差异的 `tp-text` 重渲染 + +响应式 `tp-text` 替换只编辑新旧文本的**差异区段**（先插入后删除），因 +此位于未变化文本中的 point 和标记保持原位；位于被编辑区段内的 point +落在编辑起点。值完全相同的更新是真正的空操作：不编辑文本、不搅动属 +性，也不触碰缓冲区的修改标志。 + +```elisp +(progn + (tp-layer-reset) + (defvar counter-val "0") + (define-tp counter-label () + :props '(tp-text $counter-val)) + (with-temp-buffer + (insert "count: 0 items") + (tp-set 8 9 'counter-label) + (let ((m (copy-marker 10))) ; 标记在 "items" 的 "i" 上 + (setq counter-val "9") ; 只有数字被编辑 + (list (buffer-substring-no-properties 1 (point-max)) + (char-after m))))) +;; => ("count: 9 items" ?i) ; 标记仍指向它原来的字符 + +;; 值相同的更新完全不触碰缓冲区 +(with-temp-buffer + (insert "count: 9 items") + (tp-set 8 9 'counter-label) + (set-buffer-modified-p nil) + (setq counter-val "9") ; 与显示的文本相同 + (buffer-modified-p)) +;; => nil +``` + ### 调试模式 tp.el 提供调试模式来帮助理解响应式更新流程： diff --git a/docs/ARCHITECTURE.md b/docs/ARCHITECTURE.md index f9c5d06..a988dab 100644 --- a/docs/ARCHITECTURE.md +++ b/docs/ARCHITECTURE.md @@ -2,7 +2,7 @@ 本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。 -自 0.2.0 起，原来的单文件 tp.el 已拆分为九个分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。各模块的变更缘由见 [CHANGELOG.md](../CHANGELOG.md)。 +自 0.2.0 起，原来的单文件 tp.el 已拆分为九个分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。0.3.0 进一步收紧了模块边界：`tp-text` 处理链下沉至 tp-ops、批量更新上收至 tp-render、层栈存储编解码与匿名层机制归位 tp-layer，钩子变量从四个减少到两个。各变更的缘由见 [CHANGELOG.md](../CHANGELOG.md)。 ## 目录 @@ -10,14 +10,15 @@ - [模块分层](#模块分层) - [tp-core.el：基础工具](#tp-coreel基础工具) - [tp-reactive.el：响应式基础设施](#tp-reactiveel响应式基础设施) - - [tp-layer.el：层定义与解析](#tp-layerel层定义与解析) - - [tp-ops.el：核心属性操作](#tp-opsel核心属性操作) + - [tp-layer.el：层定义、解析与层栈存储](#tp-layerel层定义解析与层栈存储) + - [tp-ops.el：核心属性操作与 tp-text 处理链](#tp-opsel核心属性操作与-tp-text-处理链) - [tp-search.el：模式匹配与搜索](#tp-searchel模式匹配与搜索) - [tp-render.el：响应式渲染引擎](#tp-renderel响应式渲染引擎) - [tp-stack.el：属性层栈操作](#tp-stackel属性层栈操作) - [tp-palette.el：调色板数据](#tp-paletteel调色板数据) - [tp-builtins.el：内置层与辅助工具](#tp-builtinsel内置层与辅助工具) - [钩子变量：唯一许可的反向调用](#钩子变量唯一许可的反向调用) +- [可变状态清单](#可变状态清单) - [函数调用关系图](#函数调用关系图) - [设计原则](#设计原则) @@ -32,6 +33,20 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search → tp-render → tp-stack → tp-palette → tp-builtins ``` +注意加载顺序是依赖顺序的**上界**：并非每个模块都依赖它前面的全部模块。各模块实际 `require` 的 tp- 模块如下（逐一核对自源码头部）： + +| 模块 | require 的 tp- 模块 | +|------|--------------------| +| tp-core | —（仅 cl-lib、dash、seq） | +| tp-reactive | tp-core | +| tp-layer | tp-core、tp-reactive | +| tp-ops | tp-core、tp-reactive、tp-layer | +| tp-search | tp-core、tp-reactive、tp-layer、tp-ops | +| tp-render | tp-core、tp-reactive、tp-layer、tp-ops、tp-search | +| tp-stack | tp-core、tp-reactive、tp-layer（**不依赖 tp-ops / tp-search / tp-render**） | +| tp-palette | —（不依赖任何 tp- 模块，仅 subr-x） | +| tp-builtins | tp-core、tp-layer、tp-ops、tp-palette | + ``` ┌────────────────────────────────────────────────────────────────┐ │ tp.el —— 总入口，按序 require 全部模块 │ @@ -41,25 +56,28 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search │ tp-palette-show、显示缓冲辅助宏 │ ├────────────────────────────────────────────────────────────────┤ │ tp-palette.el 明/暗主题调色板数据、tp-parse-color │ +│ （独立叶模块，不依赖任何 tp- 模块） │ ├────────────────────────────────────────────────────────────────┤ -│ tp-stack.el 层栈操作（push/pop/move/merge/flatten …） │ +│ tp-stack.el 层栈操作（push/pop/move/hide/show/merge …） │ ├────────────────────────────────────────────────────────────────┤ -│ tp-render.el 响应式重渲染引擎 ──┐ │ -├──────────────────────────────────── │ ─────────────────────────┤ -│ tp-search.el tp-match-*/tp-regexp-*、tp-search、导航 │ -├──────────────────────────────────── │ ─────────────────────────┤ -│ tp-ops.el tp-set/reset/add/get/at/remove/clear │ -│ ◁╌╌ tp--tp-text-handler-function ╌╌╌╌┤ │ -├──────────────────────────────────── │ ─────────────────────────┤ -│ tp-layer.el define-tp/define-tps、层注册表与解析 │ -│ ◁╌╌ tp--layer-refresh-function ╌╌╌╌╌╌┤ │ -├──────────────────────────────────── │ ─────────────────────────┤ -│ tp-reactive.el 响应式依赖注册表、变量监听、批量队列 │ -│ ◁╌╌ tp--reactive-update-function ╌╌╌╌┤ │ -│ ◁╌╌ tp--reactive-flush-function ╌╌╌╌╌┘ │ +│ tp-render.el 响应式重渲染引擎、最小差异 tp-text 编辑、 │ +│ 批量更新（tp-with-batch-updates + flush）──┐ │ +├─────────────────────────────────────────────────────────── │ ──┤ +│ tp-search.el tp-match-*/tp-regexp-*、tp-search、导航 │ │ +├─────────────────────────────────────────────────────────── │ ──┤ +│ tp-ops.el tp-set/reset/add/get/at/remove/clear、 │ │ +│ tp-text 处理链（0.3.0 起在此，直接调用） │ │ +├─────────────────────────────────────────────────────────── │ ──┤ +│ tp-layer.el define-tp/define-tps、层注册表与解析、 │ │ +│ 层栈存储编解码、匿名层机制与 GC │ │ +│ ◁╌╌ tp--layer-refresh-function ╌╌╌╌╌╌╌╌╌╌┤ │ +├─────────────────────────────────────────────────────────── │ ──┤ +│ tp-reactive.el 响应式依赖注册表、变量监听、批量队列、 │ │ +│ 层→缓冲区注册表 │ │ +│ ◁╌╌ tp--reactive-update-function ╌╌╌╌╌╌╌╌╌┘ │ ├────────────────────────────────────────────────────────────────┤ │ tp-core.el 区间遍历、plist/face 合并引擎、 │ -│ 调试日志、$var 符号工具 │ +│ 调试日志、$var 符号工具（无可变状态） │ └────────────────────────────────────────────────────────────────┘ 实线层级：上层模块调用下层模块（require 依赖）。 @@ -67,7 +85,7 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search 由 tp-render.el 在加载时安装实现（见下文）。 ``` -早期文档把"响应式系统"画在高级 API 之下、却又让它向上调用 `tp-search-map`，与自身的分层原则矛盾。现在这一矛盾已在代码层面消除：需要向上调用的逻辑全部收拢进 `tp-render.el`（位于 `tp-search.el` 之上，可以直接调用它）；下层模块（tp-reactive、tp-layer、tp-ops）通过**钩子变量**触发渲染，自身不依赖任何上层模块。 +需要"向上调用"的逻辑全部收拢在 `tp-render.el`（位于 `tp-search.el` 之上，可以直接调用它）。0.2.0 时这类反向调用靠四个钩子变量实现；0.3.0 把其中两个消除在了代码层面——`tp-text` 处理链整体下沉进 tp-ops（`tp-set` 等直接调用，不再需要 `tp--tp-text-handler-function`；只加载到 tp-ops 的部分加载也能得到可用的 `tp-text` 文本替换），批量刷新整体上收进 tp-render（`tp--flush-batch-updates` 直接调用 `tp--reactive-flush-entry`，不再需要 `tp--reactive-flush-function`）。剩下的两个钩子对应真正源自下层的事件：变量监听器触发（tp-reactive）与层重定义触发（tp-layer）。 --- @@ -75,14 +93,14 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search ### tp-core.el：基础工具 -最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。 +最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。0.3.0 起 tp-core **不再持有任何可变状态**（匿名层计数器已迁至 tp-layer；仅剩 `tp-debug-mode` / `tp-debug-echo` 两个 defcustom 用户选项）。 #### 区间操作 | 函数 | 描述 | 主要调用者 | |------|------|--------| -| `tp-intervals` | 获取区域内文本属性区间列表（裁剪到 [START, END)） | tp-intervals-map, tp-get | -| `tp-intervals-map` | 对区间应用函数 | 多个属性/层操作函数 | -| `tp--map-intervals` | 共享的裁剪式区间遍历引擎 | tp-intervals-map, tp-ops/tp-stack 的区域操作 | +| `tp-intervals` | 获取区域内文本属性区间列表（裁剪到 [START, END)；可选 ABSOLUTE 参数返回缓冲区原生坐标，默认仍为相对坐标） | tp-intervals-map, tp-get | +| `tp-intervals-map` | 对区间应用函数（同样支持 ABSOLUTE） | 多个属性/层操作函数 | +| `tp--map-intervals` | 共享的裁剪式区间遍历引擎 | tp-intervals-map, tp-ops/tp-stack 的区域操作, tp-reactive 的缓冲区扫描 | | `tp-plist` | 获取区域中合并后的所有属性 | 用户 API | | `tp-empty-p` | 检查对象是否没有文本属性 | 用户 API | @@ -94,6 +112,7 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search | `tp--merge-face-values` | 合并两个 face 值 | 合并引擎内部 | | `tp--merge-duplicate-keys` | 合并 plist 中的重复键 | tp--parse-args | | `tp--parse-face-list` | 解析 face 列表 | 合并引擎内部 | +| `tp--merge-string-props-into-plist` | 将字符串内嵌属性并入 plist | tp-ops 的 tp-text 处理链 | | `tp--get-nested` | 按路径获取嵌套属性值 | tp-get, tp-at | `tp-face-properties`（常量，`'(face font-lock-face mouse-face)`）定义参与 face 感知合并的属性家族。 @@ -122,98 +141,139 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search ### tp-reactive.el：响应式基础设施 -只依赖 tp-core。维护响应式依赖注册表、变量监听器与批量更新队列；**不包含任何渲染逻辑**，重渲染通过钩子变量委托给 tp-render.el。 +只依赖 tp-core。维护响应式依赖注册表、变量监听器、批量更新队列与 0.3.0 新增的**层→缓冲区注册表**；**不包含任何渲染逻辑**，重渲染通过钩子变量委托给 tp-render.el。批量更新的队列（`tp--batch-update-pending`、`tp--queue-batch-update`）定义在这里，但 `tp-with-batch-updates` 宏与刷新逻辑自 0.3.0 起位于 tp-render.el。 #### 依赖注册与管理 | 函数/变量 | 描述 | |------|------| | `tp-reactive-deps` | 变量 → 依赖它的层及属性 的注册表 | | `tp--register-reactive-deps` | 注册响应式依赖 | -| `tp--unregister-reactive-deps` | 取消注册依赖（含 watchers/computed/data） | +| `tp--unregister-reactive-deps` | 取消注册依赖（含 watchers/computed/data，并移除该层的缓冲区注册表条目） | | `tp--layer-has-reactive-deps-p` | 层是否有响应式依赖 | | `tp--register-layer-watchers` / `tp--unregister-layer-watchers` | 注册/清除 `:watch` 回调 | | `tp--register-layer-computed` / `tp--unregister-layer-computed` | 注册/清除 `:compute` 计算属性 | | `tp--register-layer-data` / `tp--unregister-layer-data` | 注册/清除 `:data` 变量 | | `tp--apply-initial-computed` | 计算 `:compute` 的初始值 | | `tp--ensure-reactive-variables` | 确保 `$var` 对应的变量已定义 | -| `tp-reactive-reset` | 重置全部响应式注册表 | +| `tp-reactive-reset` | 重置全部响应式注册表（含批量队列与层→缓冲区注册表） | -#### 变量监听与批量更新 -| 函数/宏 | 描述 | +#### 层→缓冲区注册表（0.3.0） +响应式更新不再全量扫描 `(buffer-list)`：每条会写入 `tp-name` 的缓冲区路径（tp-set 家族、栈变更函数、match/regexp 应用器）都把目标缓冲区登记到注册表，更新时只访问登记过的缓冲区。 + +| 函数/变量 | 描述 | +|------|------| +| `tp--layer-buffers` | 哈希表（`:test equal`）：层名 → 展示该层的缓冲区列表。键存在但值为空表示"已知：无缓冲区展示该层"，与键不存在（`unknown`）严格区分 | +| `tp-reactive--register-layer-buffer` | 幂等登记（公开写入口，tp-ops/tp-search/tp-stack 各自的注册助手最终都调用它）；首次使用时安装 `kill-buffer-hook` 清理器 | +| `tp-reactive-layer-buffers` | 查询某层的已登记存活缓冲区，或返回符号 `unknown`；惰性剔除已死缓冲区 | +| `tp-reactive--buffer-layer-names` | 栈感知的缓冲区扫描：直接 `tp-name` 与 `tp-layers` 栈存储内的层（被覆盖或被隐藏）都算在场。`tp-reactive-track-buffer` 与匿名层 GC 的存活检查共用它 | +| `tp-reactive-track-buffer` | 交互命令：扫描缓冲区并登记其中的全部层。用于弥补"插入已带属性的字符串"绕过登记路径的已知缺口 | +| `tp-reactive--prune-killed-buffer` / `tp-reactive--install-kill-buffer-hook` | kill-buffer 时从注册表剔除死缓冲区（条目保留为空列表，即"已知：无"） | + +对 `unknown` 层，tp-render 的更新走一次**学习性**全扫描并登记实际找到的缓冲区；一处都没找到的层刻意保持 `unknown`，以便之后经非登记路径（如字符串插入）出现时仍能被下次扫描发现。 + +#### 变量监听与批量队列 +| 函数 | 描述 | |------|------| | `tp--reactive-variable-watcher` | `add-variable-watcher` 回调；调用 `:watch` 后经 `tp--reactive-update-function` 委托重渲染 | | `tp--invoke-layer-watchers` | 调用层的 `:watch` 回调 | -| `tp-with-batch-updates` | 批量更新宏 | -| `tp--queue-batch-update` | 将更新加入待处理队列 | -| `tp--flush-batch-updates` | 刷新队列，经 `tp--reactive-flush-function` 委托重渲染 | +| `tp--queue-batch-update` | 将更新加入待处理队列 `tp--batch-update-pending`（刷新在 tp-render） | -钩子变量：`tp--reactive-update-function`、`tp--reactive-flush-function`（定义于此，由 tp-render.el 安装）。 +钩子变量：`tp--reactive-update-function`（定义于此，由 tp-render.el 安装）。 --- -### tp-layer.el：层定义与解析 +### tp-layer.el：层定义、解析与层栈存储 -依赖 tp-core、tp-reactive。提供 `define-tp` / `define-tps` 宏、层注册表、层名解析，以及层栈的数据结构原语。 +依赖 tp-core、tp-reactive。提供 `define-tp` / `define-tps` 宏、层注册表、层名解析，以及 0.3.0 归位至此的**层栈存储编解码**与**匿名层完整生命周期**（铸造、驻留、注销、GC）。 #### 层定义 | 函数/宏 | 描述 | 依赖 | |---------|------|------| -| `define-tp` | 定义单个自定义文本属性（层） | tp--define-layer-internal | -| `define-tps` | 定义自定义文本属性组（层组）；别名 `define-tp-group` | tp--define-layer-group-internal | +| `define-tp` | 定义单个自定义文本属性（层）；别名 `tp-define-layer` | tp--define-layer-internal | +| `define-tps` | 定义自定义文本属性组（层组）；别名 `define-tp-group`、`tp-define-group` | tp--define-layer-group-internal | | `tp--define-layer-internal` | 层定义的运行时实现 | tp--parse-define-layer-args, tp--collect-reactive-symbols, tp--ensure-reactive-variables, tp--register-*, tp--layer-refresh | | `tp--parse-define-layer-args` | 解析 `:props` / `:data` / `:compute` / `:watch` / `:transform` | - | | `tp--parse-layer-group-element` | 解析层组元素 | tp--layer-group-element-format | | `tp--define-layer-from-parsed` | 从解析结果定义层 | （与 define-tp 类似的依赖） | | `tp--check-layer-cycle` | 检测循环层引用并报错 | tp--layer-expansion-stack | -| `tp--anonymous-layer-name-for` | 匿名响应式层的驻留（`equal` 的 props 复用注册项） | - | + +0.3.0 起参数化层/层组的 ARGLIST 可以声明**任意个**参数（此前仅限一个）；`(LAYER ARG1 ... ARGN)` 与包裹形式 `(LAYER (ARG1 ... ARGN))` 在 `tp-set` 与 `tp-put-layer` 规格中均可用，实参数量不匹配会报出点名该层与两个数量的清晰错误。 #### 注册表与查询 | 函数/变量 | 描述 | |------|------| | `tp-layer-alist` / `tp-layer-groups` / `tp-layer-transforms` | 层、层组、转换函数注册表 | +| `tp--group-generated-layers` | 层组 → 其定义生成的层 的注册表（组重定义/注销时随之清理） | | `tp--set-layer-props` / `tp--set-group-layers` | 写入注册表 | | `tp-layer-props` / `tp-group-props` | 获取层/层组属性（`&optional INCLUDE-TP-NAME`，默认不含 `tp-name`；返回副本） | -| `tp-layer-props-with-arg` / `tp-group-props-with-arg` | 参数化层/层组的属性求值 | +| `tp-layer-props-with-arg` / `tp-group-props-with-arg` | 单参数形式（0.3.0 起是 -with-args 的薄封装） | +| `tp-layer-props-with-args` / `tp-group-props-with-args` | 多参数形式：ARGS 按位置绑定到层参数 | +| `tp-layer-arglist` | 返回参数化层的形参表副本（非参数化层返回 nil） | | `tp-layer-parameterized-p` / `tp-group-parameterized-p` | 是否参数化 | -| `tp-layer-reset` | 重置层系统 | -| `tp-undefine-layer` / `tp-undefine-group` | 删除层/层组（含其响应式依赖与转换） | +| `tp-describe-layer` | 交互命令：在 help 缓冲区展示层的存储格式、形参表、原始定义体、展开属性、响应式依赖、transform 与所属层组（数据采集在 `tp--describe-layer-data`） | +| `tp-layer-reset` | 重置层系统（连带调用 `tp-reactive-reset`；见[可变状态清单](#可变状态清单)） | +| `tp-undefine-layer` / `tp-undefine-group` | 删除层/层组（含其响应式依赖、转换与匿名层注册表条目） | #### 属性解析 | 函数 | 描述 | 依赖 | |------|------|------| -| `tp--resolve-props` | 解析属性（展开层名、`$var`、注册依赖） | tp-layer-props, tp--collect-reactive-symbols, tp--resolve-reactive-symbols, tp--register-reactive-deps | +| `tp--resolve-props` | 解析属性（展开层名、多参数规格、`$var`、注册依赖、驻留匿名层） | tp-layer-props(-with-args), tp--collect-reactive-symbols, tp--resolve-reactive-symbols, tp--anonymous-layer-name-for, tp--register-reactive-deps | | `tp--expand-layer-in-plist` | 展开 plist 中的层名键 | tp--is-layer-name-p | -| `tp--expand-layer-to-props-list` | 层名展开为属性列表 | tp--check-layer-cycle | -#### 层栈数据结构原语 +#### 匿名层机制与 GC（0.3.0 归位/新增） +| 函数/变量 | 描述 | +|------|------| +| `tp--anonymous-layer-counter` | 匿名层名计数器。**刻意不被任何 reset 清零**：脱离缓冲区的字符串可能仍携带旧的 `tp-anon-N` 属性值，计数器单调递增保证新铸名字永不与之混淆 | +| `tp--generate-anonymous-layer-name` | 生成唯一的 `tp-anon-N` 符号 | +| `tp--anonymous-layer-registry` | 匿名响应式层驻留表：`equal` 的 props 规格复用既有注册项 | +| `tp--anonymous-layer-name-for` | 驻留查询/铸造入口 | +| `tp--buffer-has-layer-region-p` | 栈感知的存活检查：直接 `tp-name` 或 `tp-layers` 内（被覆盖/被隐藏）皆算存活 | +| `tp-gc-anonymous-layers` | 交互命令：回收已无任何已登记存活缓冲区展示的匿名层；注册表状态为 `unknown` 的层（可能仅被游离字符串引用）保守保留 | + +#### 层栈存储编解码 +层栈在原始文本属性上的编码/解码知识集中在这里，tp-stack（栈操作）与 tp-render（响应式写穿）都向下调用它，互不 require。 + | 函数 | 描述 | |------|------| -| `tp--normalize-layer-spec` | 规范化层规格 | -| `tp--get-layer-stack` | 获取位置的层栈 | -| `tp--build-layer-props` | 从层列表构建属性 | -| `tp--layer-stack-to-list` | 将层栈转换为列表 | +| `tp--normalize-layer-spec` | 规范化层规格（含多参数 `(LAYER ARG1 ... ARGN)`） | +| `tp--build-layer-props` / `tp--layer-stack-to-list` | 旧式编解码原语（无隐藏层语义） | +| `tp--stack-hidden-p` | 层 plist 是否带 `tp-hidden` 标志 | +| `tp--stack-props-to-list` | 原始属性 → 有序层列表（顶层在前，含隐藏层）。有隐藏层时 `tp-layers` 持有完整栈，直接属性只是最顶可见层的渲染缓存 | +| `tp--stack-build-props` | 有序层列表 → 原始属性。单层栈不携带 `tp-layers`；含隐藏层时切换为"完整栈 + 渲染缓存"存储模式（全部隐藏时不渲染任何层属性） | | `tp--get-layer-by-idx-or-name` | 通过索引或名称查找层 | 钩子变量：`tp--layer-refresh-function`（定义于此，由 tp-render.el 安装为 `tp--update-layer-regions`）；`tp--layer-refresh` 是它的调用入口，层重定义后经它触发已应用区域的重渲染。 --- -### tp-ops.el：核心属性操作 +### tp-ops.el：核心属性操作与 tp-text 处理链 -依赖 tp-core、tp-layer。面向用户的核心属性读写函数，直接调用 Emacs 原生文本属性 API。 +依赖 tp-core、tp-reactive、tp-layer。面向用户的核心属性读写函数，直接调用 Emacs 原生文本属性 API。0.3.0 起 `tp-text` 处理链从 tp-render 下沉至此，`tp-set` 等**同模块直接调用**它（不再经钩子变量）——因此只加载到 tp-ops 的部分加载也能得到可用的 `tp-text` 文本替换。 #### 参数解析 | 函数 | 描述 | 调用者 | |------|------|--------| -| `tp--parse-args` | 解析灵活的调用格式（整串/区域/层名） | tp-set, tp-reset, tp-add | +| `tp--parse-args` | 解析灵活的调用格式（整串/区域/层名/多参数层） | tp-set, tp-reset, tp-add | | `tp--apply-props-to-string` | 字符串路径的属性应用 | tp-set, tp-reset, tp-add | +| `tp--ops-register-layer-buffer` | 应用带 `tp-name` 的属性到缓冲区后，登记到层→缓冲区注册表 | tp-set, tp-reset, tp-add | + +#### tp-text 处理链（0.3.0 自 tp-render 迁入） +| 函数 | 描述 | +|------|------| +| `tp--handle-tp-text-property` | `tp-text` 属性的总入口：初始化/替换文本、双向同步响应式变量 | +| `tp--tp-text-replace` | 执行文本替换（缓冲区与字符串两条路径） | +| `tp--tp-text-transform` | 应用层的 `:transform`（首次渲染同样生效） | +| `tp--find-tp-text-reactive-var` | 找到层 `tp-text` 绑定的响应式变量 | +| `tp--merge-embedded-props` | 合并 tp-text 字符串内嵌属性与外部属性 | +| `tp--apply-reactive-text-props` | 把结果属性应用到替换文本（值未变的区段跳过写入，保持 buffer-modified 状态） | +| `tp--put-text-property-unless-equal` | 仅在值确实变化时写属性 | #### 设置属性 | 函数 | 描述 | 依赖 | 被依赖 | |------|------|------|--------| -| `tp-set` | 设置文本属性（保留其他属性） | tp--parse-args, tp--handle-tp-text | tp-match-set, 层操作 | -| `tp-reset` | 完全替换所有文本属性 | tp--parse-args, tp--handle-tp-text | tp-match-reset | -| `tp-add` | 深度合并属性 | tp--parse-args, tp--deep-merge-plist, tp--prepend-face | tp-match-add | +| `tp-set` | 设置文本属性（保留其他属性） | tp--parse-args, tp--handle-tp-text-property, tp--ops-register-layer-buffer | tp-match-set, 层操作 | +| `tp-reset` | 完全替换所有文本属性 | 同上 | tp-match-reset | +| `tp-add` | 深度合并属性 | 同上 + tp--deep-merge-plist, tp--prepend-face | tp-match-add | #### 获取属性 | 函数 | 描述 | 依赖 | 被依赖 | @@ -226,39 +286,39 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search | 函数 | 描述 | 依赖 | 被依赖 | |------|------|------|--------| | `tp-remove` | 移除属性或子属性 | tp--remove-property, tp--remove-sub, tp--remove-*-from-string | 用户 API | -| `tp-clear` | 清除所有属性 | - | 用户 API | - -钩子变量：`tp--tp-text-handler-function`（定义于此，由 tp-render.el 安装为 `tp--handle-tp-text-property`）；`tp--handle-tp-text` 是它的调用入口，未安装时 `tp-text` 属性按普通属性处理。 +| `tp-clear` | 清除所有属性（显式返回 nil） | - | 用户 API | --- ### tp-search.el：模式匹配与搜索 -依赖 tp-core、tp-layer、tp-ops。提供模式匹配式属性应用、属性搜索与导航。 +依赖 tp-core、tp-reactive、tp-layer、tp-ops（0.3.0 新增 tp-reactive 依赖：应用器写入缓冲区后经 `tp--search-register-layer-buffer` 登记层→缓冲区注册表）。提供模式匹配式属性应用、属性搜索与导航。 #### 模式匹配 | 函数 | 描述 | 依赖 | |------|------|------| -| `tp-match-set` / `tp-match-reset` / `tp-match-add` | 在字符串匹配处设置/重置/合并属性 | tp--match-apply | -| `tp-regexp-set` / `tp-regexp-reset` / `tp-regexp-add` | 在正则匹配处设置/重置/合并属性 | tp--regexp-apply | +| `tp-match-set` / `tp-match-reset` / `tp-match-add` | 在字符串匹配处设置/重置/合并属性；0.3.0 起接受 START/END 界限（视同只存在该部分；颠倒的界限自动交换） | tp--match-apply | +| `tp-regexp-set` / `tp-regexp-reset` / `tp-regexp-add` | 在正则匹配处设置/重置/合并属性；0.3.0 起额外接受 SUBEXP（属性作用于每个匹配的该捕获组；超出组数报清晰错误） | tp--regexp-apply | | `tp--match-apply` / `tp--regexp-apply` | 字面/正则匹配的入口（含多模式支持） | tp--pattern-apply | -| `tp--pattern-apply` / `tp--pattern-apply-single` | 共享的模式匹配引擎（空模式/零宽模式安全） | tp-set/tp-reset/tp-add 风格的 apply-fn | -| `tp--deep-merge-apply` / `tp--reset-apply` | 传给引擎的合并/重置回调 | tp--deep-merge-plist 等 | +| `tp--pattern-apply` / `tp--pattern-apply-single` | 共享的模式匹配引擎（空模式/零宽模式安全；承载 START/END/SUBEXP） | tp-set/tp-reset/tp-add 风格的 apply-fn | +| `tp--deep-merge-apply` / `tp--reset-apply` | 传给引擎的合并/重置回调（缓冲区路径顺带登记注册表） | tp--deep-merge-plist, tp--search-register-layer-buffer | +| `tp--search-register-layer-buffer` | 登记助手，转发到 `tp-reactive--register-layer-buffer` | tp-reactive | #### 搜索和导航 | 函数 | 描述 | 依赖 | |------|------|------| -| `tp-search-forward` | 向前搜索属性 | text-property-search-forward | -| `tp-search-backward` | 向后搜索属性 | tp--property-search-backward | -| `tp--property-search-backward` | 带等值谓词的向后搜索（与向前语义对称） | text-property-search-backward | -| `tp-forward` | 向前搜索 N 次并移动点 | tp-search-forward | -| `tp-backward` | 向后搜索 N 次并移动点 | tp-search-backward | +| `tp-forward` | 向前搜索 N 次并移动点；0.3.0 起接受 PREDICATE 与 NOT-CURRENT（默认保持 0.2.0 的对称 `equal` 匹配契约） | text-property-search-forward | +| `tp-backward` | 向后搜索 N 次并移动点（与向前语义对称，同样新增 PREDICATE/NOT-CURRENT） | tp--property-search-backward | +| `tp--property-search-backward` | 带谓词的向后搜索引擎 | text-property-search-backward | +| `tp--property-match-p` | 谓词归一化（nil/t → `equal`；函数 → `(funcall PRED VALUE PROP-VALUE)`） | - | +| `tp--string-property-matches` | 字符串路径的按段匹配收集器 | - | | `tp-search` | 收集所有匹配区间 | tp-intervals 等 | +| `tp-search-forward` / `tp-search-backward` | **已废弃（0.3.0，make-obsolete）**：裸封装原语，nil-PREDICATE 默认语义与库内 `equal` 匹配相悖；请改用 `tp-forward` / `tp-backward`，或直接用 Emacs 原语 | text-property-search-* | #### 遍历与替换 | 函数 | 描述 | 依赖 | |------|------|------| -| `tp-forward-do` / `tp-backward-do` | 向前/向后搜索并对匹配执行函数 | tp--forward-do / tp--backward-do | +| `tp-forward-do` / `tp-backward-do` | 向前/向后搜索并在第 TIMES 个匹配处执行函数（同样透传 PREDICATE/NOT-CURRENT） | tp--forward-do / tp--backward-do | | `tp--forward-do` / `tp--backward-do` | 单方向遍历的内部实现 | tp--replace-match-text | | `tp-search-map` | 对所有匹配应用函数（FUNCTION 接收 TEXT &optional START END IDX） | tp--search-do | | `tp--search-do` | 搜索遍历的内部实现 | tp--replace-match-text | @@ -268,51 +328,64 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search ### tp-render.el：响应式渲染引擎 -依赖 tp-core、tp-reactive、tp-layer、tp-ops、tp-search。这是唯一"知道"渲染如何进行的模块：它可以直接调用 `tp-search-map`、`tp-add` 等前置模块的函数，并在加载末尾把自己的入口函数**安装**进下层模块预留的钩子变量。 +依赖 tp-core、tp-reactive、tp-layer、tp-ops、tp-search。这是唯一"知道"渲染如何进行的模块：它直接调用 `tp-search-map`、`tp--tp-text-transform`、`tp--apply-reactive-text-props`（后两者位于 tp-ops——这条 require 是真实的下行调用，不只是加载顺序），并在加载末尾把自己的入口函数**安装**进下层模块预留的两个钩子变量。0.3.0 起批量更新宏与刷新逻辑也位于此。 + +#### 缓冲区遍历（0.3.0：注册表驱动） +| 函数 | 描述 | 依赖 | +|------|------|------| +| `tp--render-visit-buffer` | 单缓冲区访问接缝（测试可包裹它统计访问次数） | tp-with-current-buffer | +| `tp--map-layer-buffers` | 在可能展示该层的缓冲区中执行更新：WHERE 为缓冲区（setq-local）时只走它；否则查注册表只访问已登记缓冲区；`unknown` 层回退为一次学习性 `(buffer-list)` 全扫描并登记实际命中的缓冲区 | tp-reactive-layer-buffers, tp--buffer-has-layer-region-p | #### 重渲染 | 函数 | 描述 | 依赖 | |------|------|------| -| `tp--update-layer-regions` | 重渲染携带某层的所有文本区域（替换该层自己的属性键，保留其他来源属性） | tp--layer-render-props, tp-search-map | +| `tp--update-layer-regions` | 重渲染携带某层的所有文本区域（替换该层自己的属性键，保留其他来源属性），并**写穿**到 `tp-layers` 栈存储 | tp--layer-render-props, tp-search-map, tp--write-layer-through-stack-storage | +| `tp--write-layer-through-stack-storage` | 把新属性写进栈存储里该层的条目（被覆盖或被隐藏的副本也保持最新，`tp-show-layer` 后渲染当前值而非陈旧快照；值未变的段不触碰缓冲区） | tp--stack-props-to-list, tp--stack-build-props [tp-layer] | +| `tp--merge-props-into-stack-entry` | 更新栈条目的键，保留其 `tp-hidden` 标志与栈位置 | - | | `tp--update-layer-computed` | 更新 `:compute` 计算属性（nil 值可正常传播） | tp--resolve-reactive-symbols, tp--set-layer-props | | `tp--layer-render-props` / `tp--layer-reactive-props` | 求取层的渲染属性 | tp-layer-props | #### 响应式文本（tp-text） | 函数 | 描述 | 依赖 | |------|------|------| -| `tp--handle-tp-text-property` | 处理 `tp-text` 属性（文本替换） | tp--tp-text-replace | -| `tp--update-reactive-text` | 变量变化后更新响应式文本 | tp--replace-reactive-text-in-buffer | -| `tp--replace-reactive-text-in-buffer` | 在缓冲区中替换响应式文本 | - | -| `tp--tp-text-transform` | 应用 `:transform` 转换（首次渲染同样生效） | tp-layer-transforms | +| `tp--update-reactive-text` | 变量变化后更新响应式文本 | tp--replace-reactive-text-in-buffer, tp--map-layer-buffers | +| `tp--replace-reactive-text-in-buffer` | 在缓冲区中替换响应式文本（0.3.0：**最小差异编辑**——修剪公共前后缀只编辑差异区段，且先插入后删除，未变文本内的点位与标记不动；文本相同的更新完全不触碰缓冲区） | tp--edit-region-minimal-diff | +| `tp--edit-region-minimal-diff` | 最小差异编辑原语 | - | +| `tp--pos-holds-layer-in-storage-only-p` | 某位置的层是否只存在于栈存储（隐藏/被覆盖，跳过可见文本替换） | - | + +#### 批量更新（0.3.0 自 tp-reactive 迁入） +| 函数/宏 | 描述 | +|------|------| +| `tp-with-batch-updates` | 批量更新宏：BODY 内的多次变量修改合并为一次刷新（队列变量仍在 tp-reactive，宏向下 let 绑定它们） | +| `tp--flush-batch-updates` | 刷新队列，按层去重后**直接调用** `tp--reactive-flush-entry`（不再经钩子） | +| `tp--reactive-flush-entry` | 单条刷新的工作函数（属性更新或 tp-text 替换） | #### 引擎入口与钩子安装 | 函数 | 描述 | |------|------| -| `tp--reactive-apply-update` | 变量变化的完整处理：更新 computed、合并层定义、重渲染或入批量队列（嵌套写入经队列而非递归）。安装为 `tp--reactive-update-function` | -| `tp--reactive-flush-entry` | 批量队列刷新时的重渲染入口。安装为 `tp--reactive-flush-function` | +| `tp--reactive-apply-update` | 变量变化的完整处理：更新 computed、合并层定义、重渲染或入批量队列（嵌套写入经队列而非递归）。尾部刷新置于 `unwind-protect` 清理段中，重渲染抛错也不会把队列条目困死。安装为 `tp--reactive-update-function` | -加载末尾执行安装： +加载末尾执行安装（与源码逐字一致）： ```elisp (setq tp--reactive-update-function #'tp--reactive-apply-update) -(setq tp--reactive-flush-function #'tp--reactive-flush-entry) -(setq tp--tp-text-handler-function #'tp--handle-tp-text-property) -(setq tp--layer-refresh-function #'tp--update-layer-regions) +(setq tp--layer-refresh-function #'tp--update-layer-regions) ``` --- ### tp-stack.el：属性层栈操作 -依赖 tp-core、tp-layer、tp-ops。所有栈变更函数建立在共享的裁剪式区域遍历之上，区域操作不会影响 [START, END) 之外的文本。 +依赖 tp-core、tp-reactive、tp-layer——**不依赖 tp-ops**（0.2.0 的幻影依赖已在 0.3.0 移除，独立字节编译无警告）。所有栈变更函数建立在共享的裁剪式区域遍历之上，区域操作不会影响 [START, END) 之外的文本；栈的存储编解码在 tp-layer（向下调用）。0.3.0 起所有栈变更函数**返回实际修改的属性段数量**（0 表示无匹配；`tp-put-layer`/`tp-push-layer` 例外，仍返回 OBJECT 或 `(START . END)`），每次改写后经 `tp--stack-register-layers` 登记层→缓冲区注册表。字符串形式**原地修改**字符串（与 `tp-set` 的复制语义不同，各函数 docstring 均有警示）。 #### 内部助手 | 函数 | 描述 | 依赖 | |------|------|------| | `tp--parse-layer-args` | 解析层操作的灵活参数 | - | -| `tp--stack-map-region` | 按区间遍历区域内层栈的共享引擎 | tp--map-intervals 风格遍历 | -| `tp--stack-build-props` | 从层列表构建栈属性（单层栈不携带 `tp-layers`） | - | -| `tp--put-layer-specs` | 展开层规格（层名/内联 plist/层名列表/参数化/层组） | tp--normalize-layer-spec, tp-group-props(-with-arg) | +| `tp--plist-remove` | 返回去掉某键的 plist 副本 | - | +| `tp--stack-map-region` | 按区间遍历区域内层栈的共享引擎（解码经 tp--stack-props-to-list，含隐藏层） | tp--map-intervals [tp-core], tp--stack-props-to-list [tp-layer] | +| `tp--stack-register-layers` | 把新栈中每个带 `tp-name` 的层（含被覆盖与隐藏的）登记到缓冲区注册表 | tp-reactive--register-layer-buffer [tp-reactive] | +| `tp--put-layer-specs` | 展开层规格（层名/内联 plist/层名列表/参数化/层组） | tp--normalize-layer-spec, tp-group-props(-with-arg) [tp-layer] | | `tp--move-layer-in-stack` | 在栈中移动层 | tp--get-layer-by-idx-or-name | | `tp--raise-layer-in-stack` | 在栈中上下移动层 | tp--move-layer-in-stack | | `tp--switch-layers-in-stack` | 交换两个层的位置 | tp--get-layer-by-idx-or-name | @@ -320,25 +393,29 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search #### 层操作（公开 API） | 函数 | 描述 | 依赖 | |------|------|------| -| `tp-put-layer` | 在指定索引放置层（区域局部） | tp--put-layer-specs, tp--stack-map-region | -| `tp-push-layer` | 将层推到顶部 | tp-put-layer | +| `tp-put-layer` | 在指定索引放置层（区域局部；0.3.0 新增尾参 NOERROR：未定义层名返回 nil 而非报错） | tp--put-layer-specs, tp--stack-map-region | +| `tp-push-layer` | 将层推到顶部（同样支持 NOERROR） | tp-put-layer | | `tp-delete-layer` | 删除层 | tp--stack-map-region | | `tp-pop-layer` | 弹出顶层 | tp-delete-layer | | `tp-move-layer` | 移动层到指定位置 | tp--move-layer-in-stack, tp--stack-map-region | -| `tp-raise-layer` | 上移/下移层 | tp--raise-layer-in-stack, tp--stack-map-region | -| `tp-rotate-layer` | 轮换层 | tp-move-layer | -| `tp-pin-layer` | 将层置顶 | tp-move-layer | +| `tp-raise-layer` | 上移层 | tp--raise-layer-in-stack, tp--stack-map-region | +| `tp-lower-layer` | 下移层（0.3.0 新增，tp-raise-layer 的镜像） | tp--raise-layer-in-stack, tp--stack-map-region | +| `tp-rotate-layer` | 轮换层（0.3.0：规范顺序 `(START END DIRECTION [COUNT] [OBJECT])`，凭 `up`/`down` 符号无歧义分派；旧顺序永久兼容；单趟栈旋转实现） | tp--stack-map-region | +| `tp-pin-layer` | 将层一次性移到栈顶（不阻止后续 push 覆盖） | tp-move-layer | | `tp-switch-layer` | 交换两个层 | tp--switch-layers-in-stack, tp--stack-map-region | -| `tp-merge-layers` | 合并多个层（显式 nil 值保留） | tp--merge-layer-props, tp--stack-map-region | -| `tp-flatten-layers` | 扁平化所有层 | tp--merge-layer-props, tp--stack-map-region | +| `tp-hide-layer` | 隐藏层（0.3.0 新增）：层留在栈中、继续接收响应式更新但不渲染；隐藏可见顶层则显露下一可见层；全部隐藏时文本仅剩 `tp-layers` 记账属性 | tp--stack-map-region, tp--stack-build-props [tp-layer] | +| `tp-show-layer` | 取消隐藏（0.3.0 新增） | 同上 | +| `tp-merge-layers` | 合并多个层（显式 nil 值保留；隐藏的匹配层不贡献属性，全部匹配层均隐藏时合并结果保持隐藏） | tp--merge-layer-props, tp--stack-map-region | +| `tp-flatten-layers` | 扁平化所有层（只合并可见层；全部隐藏时得到裸文本） | tp--merge-layer-props, tp--stack-map-region | #### 层查询 | 函数 | 描述 | 依赖 | |------|------|------| -| `tp-layer-list` | 列出所有层名称 | tp--stack-map-region | -| `tp-layer-count` | 计算层数量 | tp--stack-map-region | +| `tp-layer-list` | 列出所有层名称（含隐藏层） | tp--stack-map-region | +| `tp-layer-count` | 计算层数量（含隐藏层） | tp--stack-map-region | | `tp-layer-exists-p` | 检查层是否存在 | tp-layer-list | -| `tp-layer-top` | 获取顶层名称（覆盖整个请求区域） | tp--stack-map-region | +| `tp-layer-top` | 获取顶层名称（覆盖整个请求区域；按栈序报告最顶层，即使它被隐藏） | tp--stack-map-region | +| `tp-layer-stack-at` | 单个位置的完整有序层栈：`(NAME . PROPS)` 列表，顶层在前，隐藏层以 PROPS 中的 `tp-hidden t` 标识（0.3.0 新增） | tp--stack-props-to-list [tp-layer] | | `tp-region-layer-props` | 获取区域中特定层的属性 | tp--stack-map-region | #### 层属性操作 @@ -351,16 +428,18 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search ### tp-palette.el：调色板数据 -只依赖 tp-core（及 subr-x）。明/暗主题双值调色板系统，`tp-palette-alist` 是唯一数据源。 +**不依赖任何 tp- 模块**（仅 subr-x），是独立的叶模块。明/暗主题双值调色板系统，`tp-palette-alist` 是唯一数据源。 | 函数/宏/变量 | 描述 | |------|------| -| `define-tp-palette` | 定义调色板（重定义立即生效） | +| `define-tp-palette` | 定义调色板（重定义立即生效）；别名 `tp-define-palette` | | `tp-palette-alist` | 调色板注册表（唯一数据源） | | `tp-parse-color` | 解析颜色规格（支持 `("light" . "dark")` 及单边 cons） | | `tp-theme-dark-p` / `tp-theme-light-p` | 当前主题判断 | -| `tp-palette-fg-color` / `tp-palette-bg-color` / `tp-palette-border-color` | 取前景/背景/边框色 | -| `tp-palette-p` / `tp-palette-fg-p` / `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p` | 调色板谓词 | +| `tp-palette-color` | 通用的主题解析取色器（0.3.0 新增的首选查询入口） | +| `tp-palette-has-p` | 谓词整合入口：KIND 取 `:fg`/`:bg`/`:border`/nil（0.3.0 新增） | +| `tp-palette-fg-color` / `tp-palette-bg-color` / `tp-palette-border-color` | 取前景/背景/边框色（兼容便捷函数） | +| `tp-palette-p` / `tp-palette-fg-p` / `tp-palette-bg-p` / `tp-palette-fbg-p` / `tp-palette-border-p` | 调色板谓词（兼容便捷函数） | | `tp-palette-pure` | 取纯色值 | --- @@ -374,20 +453,46 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search | 内置层 | `tp-palette`、`tp-fg`、`tp-bg`、`tp-button`、`tp-underline`、`tp-delete`、`tp-link`、`tp-space`、`tp-headline`、`tp-action` 等（`define-tp` 定义；`tp-link` 的颜色在应用时解析，主题切换即时生效） | | `tp-pop-to-buffer` / `tp-switch-to-buffer` | 显示带属性文本的缓冲辅助宏（q 绑定在缓冲区局部 minor-mode keymap 中） | | `tp-palette-show` | 展示所有调色板 | -| `tp-suffix-symbol` | 符号加后缀助手 | +| `tp--suffix-symbol` | 符号加后缀助手（0.3.0 起转为私有；`tp-suffix-symbol` 保留为废弃兼容别名） | --- ## 钩子变量：唯一许可的反向调用 -分层规则的唯一例外是四个**钩子变量**：下层模块声明变量并在需要时 `funcall`，实现由 tp-render.el 在加载时安装。这样下层模块不必 `require` 上层模块，依赖图保持严格单向；而在未加载 tp-render 时，下层模块依然可用（钩子为 nil 时优雅降级）。 +分层规则的唯一例外是两个**钩子变量**：下层模块声明变量并在需要时 `funcall`，实现由 tp-render.el 在加载时安装。这样下层模块不必 `require` 上层模块，依赖图保持严格单向；而在未加载 tp-render 时，下层模块依然可用（钩子为 nil 时优雅降级：层可以定义与应用，只是没有自动重渲染）。 | 钩子变量 | 声明于 | 安装的实现（tp-render.el） | 用途 | |----------|--------|---------------------------|------| | `tp--reactive-update-function` | tp-reactive.el | `tp--reactive-apply-update` | 变量监听器触发的重计算与重渲染 | -| `tp--reactive-flush-function` | tp-reactive.el | `tp--reactive-flush-entry` | 批量更新队列刷新时的重渲染 | | `tp--layer-refresh-function` | tp-layer.el | `tp--update-layer-regions` | 层重定义后刷新已应用区域 | -| `tp--tp-text-handler-function` | tp-ops.el | `tp--handle-tp-text-property` | `tp-set` 等操作中处理 `tp-text` 属性 | + +0.2.0 时钩子有四个；0.3.0 删掉了其中两个，代之以真实的模块内/下行调用： + +- `tp--tp-text-handler-function`（原声明于 tp-ops）：整条 `tp-text` 处理链移入 tp-ops，`tp-set` 等直接调用 `tp--handle-tp-text-property`。副产品：只加载 tp-ops 的部分加载也能完成 `tp-text` 文本替换。 +- `tp--reactive-flush-function`（原声明于 tp-reactive）：`tp-with-batch-updates` 与 `tp--flush-batch-updates` 移入 tp-render，刷新直接调用 `tp--reactive-flush-entry`。副产品：部分加载下批量刷新不再被静默丢弃，而是诚实地报 void-function。 + +留下的两个钩子对应真正**源自下层的事件**（变量被 set、层被重定义），无法在不打破分层的前提下改写为下行调用。 + +--- + +## 可变状态清单 + +各模块持有的可变运行时状态及其清理入口（0.3.0 全面核对）： + +| 模块 | 状态 | 描述 | 清理 | +|------|------|------|------| +| tp-core | —— | **无可变状态**（仅 `tp-debug-mode`/`tp-debug-echo` 两个用户选项；调试日志写入 *tp-debug* 缓冲区，由 `tp-debug-clear` 清除） | - | +| tp-reactive | `tp-reactive-deps` | 变量 → 依赖层 注册表 | `tp-reactive-reset` | +| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` | `:watch` / `:compute` / `:data` 注册表 | `tp-reactive-reset` | +| tp-reactive | `tp--batch-update-pending` | 批量更新队列（0.3.0 起也被 reset 清空，防止残留条目对新定义的层重放） | `tp-reactive-reset` | +| tp-reactive | `tp--layer-buffers` | 层→缓冲区注册表（哈希表，0.3.0 新增） | `tp-reactive-reset`（clrhash）；单层条目随 `tp-undefine-layer`/层重定义移除；死缓冲区经 kill-buffer-hook 与惰性访问剔除 | +| tp-reactive | `tp--batch-update-active` / `tp--reactive-updating` | 动态标志（let 绑定，非持久状态） | 随作用域退出 | +| tp-layer | `tp-layer-alist` / `tp-layer-groups` / `tp-layer-transforms` | 层、层组、转换注册表 | `tp-layer-reset` | +| tp-layer | `tp--group-generated-layers` | 层组生成的层 | `tp-layer-reset` | +| tp-layer | `tp--anonymous-layer-registry` | 匿名层驻留表 | `tp-layer-reset`；单条随 `tp-undefine-layer` / `tp-gc-anonymous-layers` | +| tp-layer | `tp--anonymous-layer-counter` | 匿名层名计数器——**刻意不清零**（任何 reset 都不动它）：游离字符串上残留的 `tp-anon-N` 名字永远不能与新铸层重名 | 从不 | + +`tp-reactive-reset` 移除全部变量监听器并清空上表 tp-reactive 各行；`tp-layer-reset` 先调用 `tp-reactive-reset`，再清空 tp-layer 各注册表（计数器除外）。 --- @@ -401,26 +506,31 @@ tp-set [tp-ops] ├── tp--parse-args [tp-ops] │ ├── tp--merge-duplicate-keys [tp-core] │ └── tp--resolve-props [tp-layer] - │ ├── tp-layer-props + │ ├── tp-layer-props / tp-layer-props-with-args [tp-layer] │ ├── tp--collect-reactive-symbols [tp-core] │ ├── tp--resolve-reactive-symbols [tp-core] + │ ├── tp--anonymous-layer-name-for [tp-layer]（$var 匿名层驻留） │ └── tp--register-reactive-deps [tp-reactive] - ├── tp--handle-tp-text [tp-ops] - │ ╌╌▷ tp--handle-tp-text-property [tp-render]（经钩子） + ├── tp--handle-tp-text-property [tp-ops]（0.3.0 起同模块直接调用，不再经钩子） + │ └── tp--tp-text-transform / tp--tp-text-replace [tp-ops] ├── tp--apply-props-to-string [tp-ops]（整串形式，返回新字符串） - └── set-text-properties / put-text-property（Emacs 原生，区域形式） + ├── set-text-properties / put-text-property（Emacs 原生，区域形式） + └── tp--ops-register-layer-buffer [tp-ops]（缓冲区目标） + └── tp-reactive--register-layer-buffer [tp-reactive] ``` ### tp-add 调用链 ``` tp-add [tp-ops] ├── tp--parse-args [tp-ops] - ├── tp--handle-tp-text [tp-ops] ╌╌▷ tp--handle-tp-text-property [tp-render] + ├── tp--handle-tp-text-property [tp-ops]（直接调用） ├── text-properties-at（Emacs 原生） ├── tp--prepend-face [tp-core]（face 家族属性） │ └── tp--deep-merge-plist [tp-core] ├── tp--deep-merge-plist [tp-core]（其他嵌套属性） - └── put-text-property（Emacs 原生） + ├── put-text-property（Emacs 原生） + └── tp--ops-register-layer-buffer [tp-ops] + └── tp-reactive--register-layer-buffer [tp-reactive] ``` ### define-tp 调用链 @@ -429,7 +539,7 @@ define-tp [tp-layer]（宏） └── tp--define-layer-internal [tp-layer] ├── tp--parse-define-layer-args [tp-layer] ├── tp--collect-reactive-symbols [tp-core] - ├── tp--unregister-reactive-deps [tp-reactive] + ├── tp--unregister-reactive-deps [tp-reactive]（连带移除旧的缓冲区注册表条目） ├── tp--ensure-reactive-variables [tp-reactive] ├── tp--register-layer-data [tp-reactive] │ └── add-variable-watcher（Emacs 原生） @@ -455,8 +565,11 @@ tp-push-layer [tp-stack] │ │ └── tp-layer-props [tp-layer] │ └── tp-group-props / tp-group-props-with-arg [tp-layer] └── tp--stack-map-region [tp-stack]（裁剪到 [START, END)） - ├── tp--stack-build-props [tp-stack] - └── set-text-properties（Emacs 原生） + ├── tp--stack-props-to-list [tp-layer]（解码既有栈，含隐藏层） + ├── tp--stack-build-props [tp-layer]（编码新栈/渲染缓存） + ├── set-text-properties（Emacs 原生） + └── tp--stack-register-layers [tp-stack] + └── tp-reactive--register-layer-buffer [tp-reactive] ``` ### 响应式更新调用链 @@ -470,15 +583,27 @@ tp-push-layer [tp-stack] │ └── tp--set-layer-props [tp-layer] ├── tp--set-layer-props [tp-layer]（深合并回层定义；setq-local 不写全局） ├── tp--update-layer-regions [tp-render]（属性更新） - │ └── tp-search-map [tp-search] - │ └── put-text-property + │ └── tp--map-layer-buffers [tp-render] + │ │（只访问注册表登记的缓冲区；unknown 层回退为 + │ │ 一次学习性全扫描并登记命中缓冲区） + │ ├── tp-reactive-layer-buffers [tp-reactive] + │ ├── tp--buffer-has-layer-region-p [tp-layer]（回退路径） + │ └── 每缓冲区： + │ ├── tp-search-map [tp-search] → put-text-property + │ └── tp--write-layer-through-stack-storage [tp-render] + │ └── tp--stack-props-to-list / + │ tp--stack-build-props [tp-layer] + │ （隐藏/被覆盖的层副本同步刷新） └── tp--update-reactive-text [tp-render]（tp-text 文本替换） └── tp--replace-reactive-text-in-buffer [tp-render] + └── tp--edit-region-minimal-diff [tp-render] + （最小差异、先插入后删除；文本相同则完全不动缓冲区） -批量模式（tp-with-batch-updates）/ 更新中的嵌套写入： +批量模式（tp-with-batch-updates [tp-render]）/ 更新中的嵌套写入： └── tp--queue-batch-update [tp-reactive]（入队，不递归） - └── tp--flush-batch-updates [tp-reactive]（退出批量时） - └── ╌╌▷ tp--reactive-flush-entry [tp-render]（经钩子） + └── tp--flush-batch-updates [tp-render]（退出批量/最外层更新结束时； + 置于 unwind-protect 清理段，重渲染抛错也会排空队列） + └── tp--reactive-flush-entry [tp-render]（0.3.0 起同模块直接调用，不再经钩子） ├── tp--update-layer-regions └── tp--update-reactive-text ``` @@ -487,9 +612,9 @@ tp-push-layer [tp-stack] ## 设计原则 -1. **严格分层**：模块只允许 `require` 并调用排在它前面的模块，字节编译器强制检查依赖顺序 -2. **钩子反转**：唯一许可的"向上调用"是四个钩子变量（`tp--tp-text-handler-function`、`tp--reactive-update-function`、`tp--reactive-flush-function`、`tp--layer-refresh-function`），由 tp-render.el 统一安装实现 -3. **单一职责**：每个模块（和函数）只负责一件事 -4. **复用优先**：共享引擎（`tp--map-intervals`、`tp--stack-map-region`、`tp--pattern-apply`、`tp--replace-match-text`）承载重复逻辑，高层函数复用而非复制 -5. **统一接口**：所有核心属性函数支持相同的调用约定（整串/区域形式、层名、`$var`） -6. **响应式解耦**：tp-reactive/tp-layer/tp-ops 不依赖渲染引擎；不加载 tp-render 时钩子为 nil，各模块优雅降级 +1. **严格分层**：模块只允许 `require` 并调用排在它前面的模块，字节编译器强制检查依赖顺序；且只声明真实存在的依赖（0.3.0 移除了 tp-stack→tp-ops 的幻影依赖，tp-palette 不依赖任何 tp- 模块） +2. **钩子反转**：唯一许可的"向上调用"是两个钩子变量（`tp--reactive-update-function`、`tp--layer-refresh-function`），由 tp-render.el 统一安装实现；能改写为下行调用的反转（tp-text 链、批量刷新）已在 0.3.0 改写掉 +3. **单一职责**：每个模块（和函数）只负责一件事；一个子系统的完整生命周期住在一个模块里（匿名层的铸造/驻留/注销/GC 全在 tp-layer，层栈存储格式知识全在 tp-layer 的编解码器） +4. **复用优先**：共享引擎（`tp--map-intervals`、`tp--stack-map-region`、`tp--pattern-apply`、`tp--replace-match-text`、`tp-reactive--buffer-layer-names`）承载重复逻辑，高层函数复用而非复制 +5. **统一接口**：所有核心属性函数支持相同的调用约定（整串/区域形式、层名、`$var`、多参数层） +6. **响应式解耦**：tp-reactive/tp-layer/tp-ops 不依赖渲染引擎；不加载 tp-render 时钩子为 nil，各模块优雅降级（`tp-text` 替换自 0.3.0 起随 tp-ops 即可用）；重渲染只访问层→缓冲区注册表登记的缓冲区，未知层才回退全扫描 diff --git a/tp-builtins-tests.el b/tp-builtins-tests.el index eb748bf..8912b86 100644 --- a/tp-builtins-tests.el +++ b/tp-builtins-tests.el @@ -234,5 +234,68 @@ tp-builtins restores the shipped layer definitions." (should-not (tp-parse-color nil)) (should-error (tp-parse-color 42))) +;;; API-CONC-01: the two palette primaries + +(ert-deftest tp-builtins-test-palette-color-generic-accessor () + "tp-palette-color is the theme-resolving generic accessor." + (tp-builtins-test--with-background-mode 'light + (should (equal (tp-palette-color 'info :fg) "#0969da")) + (should (equal (tp-palette-color 'info :fg) + (tp-palette-fg-color 'info))) + (should (equal (tp-palette-color 'info :bg) + (tp-palette-bg-color 'info))) + (should (equal (tp-palette-color 'info :border) + (tp-palette-border-color 'info))) + (should-not (tp-palette-color 'no-such-palette :fg)) + ;; heatmap-g0 defines only :fg. + (should-not (tp-palette-color 'heatmap-g0 :bg))) + (tp-builtins-test--with-background-mode 'dark + (should (equal (tp-palette-color 'info :fg) "#58a6ff")))) + +(ert-deftest tp-builtins-test-palette-has-p () + "tp-palette-has-p tests palette registration and per-key presence." + (should (tp-palette-has-p 'info)) + (should (tp-palette-has-p 'info :fg)) + (should (tp-palette-has-p 'info :bg)) + (should (tp-palette-has-p 'info :border)) + (should (tp-palette-has-p 'heatmap-g0 :fg)) + (should-not (tp-palette-has-p 'heatmap-g0 :bg)) + (should-not (tp-palette-has-p 'heatmap-g0 :border)) + (should-not (tp-palette-has-p 'no-such-palette)) + (should-not (tp-palette-has-p 'no-such-palette :fg)) + ;; Unlike the suffix predicates, has-p takes the palette name + ;; itself, not a NAME-fg variant symbol. + (should-not (tp-palette-has-p 'info-fg)) + (should (tp-palette-fg-p 'info-fg))) + +;;; DOC-STR-02: tp-suffix-symbol privatized behind an obsolete alias + +(ert-deftest tp-builtins-test-suffix-symbol-obsolete-alias () + "tp-suffix-symbol keeps working as an obsolete compatibility alias." + (should (eq (tp--suffix-symbol 'info "-fg") 'info-fg)) + (should (eq (with-suppressed-warnings ((obsolete tp-suffix-symbol)) + (tp-suffix-symbol 'info "-fg")) + 'info-fg)) + (should (eq (car (get 'tp-suffix-symbol 'byte-obsolete-info)) + 'tp--suffix-symbol))) + +;;; API-NAME-02: prefix-conforming tp-define-palette alias + +(ert-deftest tp-builtins-test-define-palette-alias () + "tp-define-palette is a working macro alias of define-tp-palette." + (unwind-protect + (progn + (tp-define-palette tp-test-alias-palette + :fg ("#111111" . "#eeeeee")) + (should (tp-palette-p 'tp-test-alias-palette)) + (tp-builtins-test--with-background-mode 'light + (should (equal (tp-palette-fg-color 'tp-test-alias-palette) + "#111111"))) + (tp-builtins-test--with-background-mode 'dark + (should (equal (tp-palette-fg-color 'tp-test-alias-palette) + "#eeeeee")))) + (setq tp-palette-alist + (assq-delete-all 'tp-test-alias-palette tp-palette-alist)))) + (provide 'tp-builtins-tests) ;;; tp-builtins-tests.el ends here diff --git a/tp-builtins.el b/tp-builtins.el index 1976cdf..c89dcf7 100644 --- a/tp-builtins.el +++ b/tp-builtins.el @@ -90,11 +90,25 @@ its window." `(face (,@(when border-color (list :box (list :color border-color)))))) (_ (error "Invalid palette: %S" palette))))) -(defun tp-suffix-symbol (symbol string) +(defun tp--suffix-symbol (symbol string) + "Intern the symbol named by SYMBOL's name with STRING appended. +For example (tp--suffix-symbol \\='info \"-fg\") returns `info-fg'. +A generic helper with no tp semantics of its own, used by +`tp-palette-show' to build the suffixed palette variant names." (intern (concat (symbol-name symbol) string))) +(define-obsolete-function-alias 'tp-suffix-symbol + 'tp--suffix-symbol "0.3.0") + ;;;###autoload (defun tp-palette-show () + "Display a gallery of every palette registered in `tp-palette-alist'. +Shows the read-only buffer *tp-palette-gallery* listing, for each +palette NAME, the symbols the `tp-palette' layer accepts: NAME itself +\(foreground, background and border together) plus the NAME-fg, +NAME-bg, NAME-fbg and NAME-border variants, each label rendered in +the colors it selects for the current theme. Press \\`q' to quit +the gallery window." (interactive) (let ((alist (seq-reverse tp-palette-alist))) (tp-switch-to-buffer "*tp-palette-gallery*" @@ -109,19 +123,19 @@ its window." " " (tp-set (concat name "-fg") 'tp-palette - (tp-suffix-symbol symbol "-fg")) + (tp--suffix-symbol symbol "-fg")) " " (tp-set (concat name "-bg") 'tp-palette - (tp-suffix-symbol symbol "-bg")) + (tp--suffix-symbol symbol "-bg")) " " (tp-set (concat name "-fbg") 'tp-palette - (tp-suffix-symbol symbol "-fbg")) + (tp--suffix-symbol symbol "-fbg")) " " (tp-set (concat name "-border") 'tp-palette - (tp-suffix-symbol symbol "-border"))))) + (tp--suffix-symbol symbol "-border"))))) alist "\n"))))) (define-tp tp-fg (color) diff --git a/tp-core-tests.el b/tp-core-tests.el index 7a1fc5b..9f5e49b 100644 --- a/tp-core-tests.el +++ b/tp-core-tests.el @@ -68,5 +68,70 @@ "The face-family property list contains the three face properties." (should (equal tp-face-properties '(face font-lock-face mouse-face)))) +;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map + +(ert-deftest tp-core-test-intervals-buffer-relative-default () + "Without ABSOLUTE, buffer intervals stay START-relative (legacy)." + (with-temp-buffer + (insert "hello world") + (put-text-property 4 8 'face 'bold) + (should (equal (tp-intervals 3 9) + '((0 1 nil) (1 5 (face bold)) (5 6 nil)))))) + +(ert-deftest tp-core-test-intervals-buffer-absolute () + "With ABSOLUTE, buffer intervals use native 1-based positions." + (with-temp-buffer + (insert "hello world") + (put-text-property 4 8 'face 'bold) + (should (equal (tp-intervals 3 9 nil t) + '((3 4 nil) (4 8 (face bold)) (8 9 nil)))) + ;; Clipping still applies in native coordinates. + (should (equal (tp-intervals 5 7 nil t) + '((5 7 (face bold))))))) + +(ert-deftest tp-core-test-intervals-string-ignores-absolute () + "String intervals are already absolute; ABSOLUTE changes nothing." + (let ((s (copy-sequence "hello world"))) + (put-text-property 3 7 'face 'bold s) + (should (equal (tp-intervals 2 9 s) (tp-intervals 2 9 s t))) + (should (equal (tp-intervals 2 9 s t) + '((2 3 nil) (3 7 (face bold)) (7 9 nil)))))) + +(ert-deftest tp-core-test-intervals-map-absolute () + "tp-intervals-map passes ABSOLUTE through to native positions." + (with-temp-buffer + (insert "hello world") + (put-text-property 4 8 'face 'bold) + (should (equal (tp-intervals-map #'list 3 9) + '((0 1 nil nil) (1 5 (face bold) nil) (5 6 nil nil)))) + (should (equal (tp-intervals-map #'list 3 9 nil t) + '((3 4 nil nil) (4 8 (face bold) nil) (8 9 nil nil)))))) + +(ert-deftest tp-core-test-intervals-map-splits-layer-stack () + "tp-intervals-map hands the tp-layers stack to FUNCTION separately." + (with-temp-buffer + (insert "hello") + (set-text-properties + 1 6 '(face bold tp-layers ((face italic tp-name below)))) + (let ((res (tp-intervals-map #'list 1 6 nil t))) + (should (= (length res) 1)) + (pcase-let ((`(,beg ,end ,top ,below) (car res))) + (should (= beg 1)) + (should (= end 6)) + (should (eq (plist-get top 'face) 'bold)) + (should-not (plist-member top 'tp-layers)) + (should (equal below '((face italic tp-name below)))))))) + +(ert-deftest tp-core-test-intervals-map-drops-nil-results () + "nil results from FUNCTION are removed from the returned list." + (with-temp-buffer + (insert "hello world") + (put-text-property 4 8 'face 'bold) + (should (equal (tp-intervals-map + (lambda (beg end top _below) + (when (plist-get top 'face) (cons beg end))) + 1 12 nil t) + '((4 . 8)))))) + (provide 'tp-core-tests) ;;; tp-core-tests.el ends here diff --git a/tp-core.el b/tp-core.el index 8f46d8c..2dd3a74 100644 --- a/tp-core.el +++ b/tp-core.el @@ -29,9 +29,6 @@ :prefix "tp-" :group 'development) -(defvar tp--anonymous-layer-counter 0 - "Counter for generating unique anonymous layer names.") - (defcustom tp-debug-mode nil "When non-nil, enable debug logging for reactive updates. Debug messages are logged to the *tp-debug* buffer and optionally @@ -68,7 +65,8 @@ If nil, debug messages are only logged to the *tp-debug* buffer." ;; Misc yank-handler auto-composed evaporate face-alias) "List of built-in Emacs text property names. -These property names are reserved and cannot be used as layer names in `define-tp'. +These property names are reserved and cannot be used as layer names +in `define-tp'. An error is signaled at macro expansion time (when the `define-tp' form is evaluated) if a reserved name is used, preventing the layer definition from being created.") @@ -95,6 +93,7 @@ FORMAT-STRING and ARGS are passed to `format'." (when tp-debug-echo (message "[tp] %s" msg))))) +;;;###autoload (defun tp-debug-clear () "Clear the *tp-debug* buffer." (interactive) @@ -102,16 +101,12 @@ FORMAT-STRING and ARGS are passed to `format'." (with-current-buffer buf (erase-buffer)))) +;;;###autoload (defun tp-debug-show () "Show the *tp-debug* buffer." (interactive) (pop-to-buffer (get-buffer-create "*tp-debug*"))) -(defun tp--generate-anonymous-layer-name () - "Generate a unique symbol for anonymous reactive layers." - (setq tp--anonymous-layer-counter (1+ tp--anonymous-layer-counter)) - (intern (format "tp-anon-%d" tp--anonymous-layer-counter))) - (defmacro tp-with-current-buffer (buffer-or-name &rest body) "Execute BODY in BUFFER-OR-NAME with `inhibit-read-only' bound to t." (declare (indent defun)) @@ -119,19 +114,28 @@ FORMAT-STRING and ARGS are passed to `format'." (let ((inhibit-read-only t)) ,@body))) -(defun tp-intervals (start end &optional object) +(defun tp-intervals (start end &optional object absolute) "Return list of property intervals from START to END in OBJECT. -Each element is (START END PROPERTIES). OBJECT defaults to current buffer. -For buffers, returns positions relative to START (0-based offsets). -For strings, returns absolute positions. +Each element is (START END PROPERTIES). OBJECT defaults to current +buffer. +For buffers, positions are by default relative to START (0-based +offsets, the legacy convention). When ABSOLUTE is non-nil they are +native 1-based buffer positions instead, directly reusable in other +tp calls (`tp-set', `tp-remove', ...) without offset arithmetic. +For strings, positions are always absolute (0-based); ABSOLUTE +changes nothing. Intervals that extend beyond the requested range are clipped to it, so returned positions never fall outside [START, END)." (let* ((intervals (object-intervals (or object (current-buffer)))) ;; For buffers, object-intervals returns 0-based positions - ;; but buffer positions are 1-based, so we need to adjust - (offset (if (stringp object) 0 (1- start))) + ;; but buffer positions are 1-based, so we need to adjust: + ;; subtracting (1- start) makes them START-relative, while + ;; subtracting -1 restores native 1-based positions. + (offset (cond ((stringp object) 0) + (absolute -1) + (t (1- start)))) ;; Filter bounds in 0-based terms for buffers - (filter-start (if (stringp object) start offset)) + (filter-start (if (stringp object) start (1- start))) (filter-end (if (stringp object) end (1- end)))) (mapcar (lambda (tp) (let* ((tp-start (- (max (nth 0 tp) filter-start) offset)) @@ -455,7 +459,8 @@ Example: (tp--merge-duplicate-keys \\='(face bold face (:foreground \"red\"))) => (face ((:foreground \"red\") bold)) - (tp--merge-duplicate-keys \\='(face (:background \"blue\") face (:foreground \"red\"))) + (tp--merge-duplicate-keys + \\='(face (:background \"blue\") face (:foreground \"red\"))) => (face (:background \"blue\" :foreground \"red\")) (tp--merge-duplicate-keys \\='(prop1 a prop2 b prop1 c)) @@ -555,7 +560,8 @@ Returns a list of reactive symbols found." (defun tp--extract-reactive-value (val reactive-var) "Extract only the parts of VAL that use REACTIVE-VAR. -If VAL is a plist, recursively extract only the key-value pairs containing REACTIVE-VAR. +If VAL is a plist, recursively extract only the key-value pairs +containing REACTIVE-VAR. If VAL directly contains REACTIVE-VAR, return VAL as-is. REACTIVE-VAR should be the $-prefixed symbol (e.g., $my-color)." (cond @@ -757,9 +763,28 @@ order." (setq pos next))) (nreverse results)))))) -(defun tp-intervals-map (function start end &optional object) - "Apply FUNCTION to all intervals between START and END in OBJECT. -FUNCTION receives (i-start i-end top-props below-props-lst)." +(defun tp-intervals-map (function start end &optional object absolute) + "Apply FUNCTION to each property interval of [START, END) in OBJECT. + +FUNCTION is called with (I-START I-END TOP-PROPS BELOW-PROPS-LST) for +every interval `tp-intervals' reports, splitting the layer-stack +bookkeeping out of the raw properties: +- TOP-PROPS is the interval's property plist with the `tp-layers' + entry removed: the directly rendered properties. +- BELOW-PROPS-LST is the value of the interval's `tp-layers' + property: the list of stored layer plists (normally the layers + buried below the rendered top layer; while any layer is hidden it + holds the whole ordered stack - see `tp-layer-stack-at' for the + decoded view). It is nil when the interval carries no layer stack. + +I-START/I-END follow `tp-intervals' coordinates: for buffers they +are by default relative to START (0-based offsets, the legacy +convention), or native 1-based buffer positions when ABSOLUTE is +non-nil; for strings they are always absolute 0-based positions. +OBJECT is a string, a buffer, or nil for the current buffer. + +Returns the list of FUNCTION's non-nil results, in interval order +\(nil results are dropped)." (remove nil (mapcar @@ -775,7 +800,7 @@ FUNCTION receives (i-start i-end top-props below-props-lst)." (funcall function interval-start interval-end top-props below-props-lst))) - (tp-intervals start end object)))) + (tp-intervals start end object absolute)))) (provide 'tp-core) ;;; tp-core.el ends here diff --git a/tp-doctest.el b/tp-doctest.el index b30dc2a..3b99ddc 100644 --- a/tp-doctest.el +++ b/tp-doctest.el @@ -23,16 +23,17 @@ (require 'tp) (tp-layer-reset) -(defvar fails 0) -(defvar total 0) +(defvar tp-doctest--fails 0) +(defvar tp-doctest--total 0) (defmacro chk (label expected &rest body) `(let* ((exp ,expected) (got (condition-case err (progn ,@body) (error (list :ERROR err))))) - (setq total (1+ total)) + (setq tp-doctest--total (1+ tp-doctest--total)) (if (equal got exp) (princ (format "PASS %s\n" ,label)) - (setq fails (1+ fails)) - (princ (format "FAIL %s\n expected: %S\n got: %S\n" ,label exp got))))) + (setq tp-doctest--fails (1+ tp-doctest--fails)) + (princ (format "FAIL %s\n expected: %S\n got: %S\n" + ,label exp got))))) (defmacro chk-str (label expected &rest body) "Compare prin1 form (covers propertized strings)." `(chk ,label ,expected (prin1-to-string (progn ,@body)))) @@ -97,12 +98,15 @@ (tp-layer-props 'full-name-layer))) ;; ---- tp-set my-style ---- -(chk-str "S-mystyle" "#(\" \" 0 1 (face (:foreground \"blue\") tp-name my-style))" - (progn - (define-tp my-style () - :props '(face (:foreground $my-color)) - :data '((my-color . "blue"))) - (tp-set " " 'my-style))) +;; Compared per property: the ORDER properties print in varies across +;; Emacs versions (28 vs 29+), the values do not. +(chk "S-mystyle" '((:foreground "blue") my-style) + (progn + (define-tp my-style () + :props '(face (:foreground $my-color)) + :data '((my-color . "blue"))) + (let ((r (tp-set " " 'my-style))) + (list (tp-at 0 'face r) (tp-at 0 'tp-name r))))) ;; ---- tp-member ---- (chk "M-member-str" '((face nil) nil) @@ -195,6 +199,7 @@ (list (substring-no-properties my-string) (nreverse positions)))) ;; ---- Layer definitions ---- +(defvar my-color) (chk "L-format3" '((:foreground "blue") "status: active") (progn (tp-layer-reset) @@ -230,21 +235,29 @@ '("first-quarter" . (display "🌓")) '("full" . (display "🌕"))) (tp-layer-props 'moon-phases-full))) -(chk-str "L-paramgroup" - "#(\"emacs\" 0 5 (face (:foreground \"orange\") tp-name tp-test-l1 tp-layers ((face (:foreground \"red\") tp-name tp-test-l2) (face (:background \"green\") tp-name tp-test-l3))))" - (progn - (tp-layer-reset) - (define-tp tp-test-l1 (color) - `(face (:foreground ,color))) - (define-tp tp-test-l2 (color) - `(face (:foreground ,color))) - (define-tp tp-test-l3 () - '(face (:background "green"))) - (define-tps tp-test-group1 (color) - `(tp-test-l1 ,color) - '(tp-test-l2 "red") - 'tp-test-l3) - (tp-set "emacs" 'tp-test-group1 "orange"))) +;; Compared per property (print order of the top-level plist varies +;; across Emacs versions; the tp-layers stack order itself is stable). +(chk "L-paramgroup" + '((:foreground "orange") + tp-test-l1 + ((face (:foreground "red") tp-name tp-test-l2) + (face (:background "green") tp-name tp-test-l3))) + (progn + (tp-layer-reset) + (define-tp tp-test-l1 (color) + `(face (:foreground ,color))) + (define-tp tp-test-l2 (color) + `(face (:foreground ,color))) + (define-tp tp-test-l3 () + '(face (:background "green"))) + (define-tps tp-test-group1 (color) + `(tp-test-l1 ,color) + '(tp-test-l2 "red") + 'tp-test-l3) + (let ((r (tp-set "emacs" 'tp-test-group1 "orange"))) + (list (tp-at 0 'face r) + (tp-at 0 'tp-name r) + (tp-at 0 'tp-layers r))))) (chk "L-props" '((face bold help-echo "tip") (face bold help-echo "tip" tp-name my-layer)) (progn @@ -456,6 +469,8 @@ '("error" :props (face (:foreground $error-color)) :data ((error-color . "red")))) (tp-layer-props 'status-indicators-success))) +(defvar fg-color) +(defvar bg-color) (chk "RC-batch" '(:foreground "red" :background "blue") (progn (tp-layer-reset) @@ -484,6 +499,7 @@ (list before (tp-at 1 'face)))))) ;; ---- Theme example (as in the docs) ---- +(declare-function switch-to-light-theme "tp-doctest") (defvar theme-fg "white") (defvar theme-bg "black") (defvar theme-accent "cyan") @@ -548,7 +564,318 @@ (list (tp-forward-do #'upcase 'marker nil str 3) (substring-no-properties str)))) -(princ (format "\nTOTAL: %d FAILS: %d\n" total fails)) -(when (> fails 0) (kill-emacs 1)) +;; ---- 0.3.0: search bounds and SUBEXP ---- +;; Compared via tp-search / tp-at accessors, not prin1 output, so the +;; property print order difference between Emacs 28 and 29+ cannot bite. +(chk "V3-match-bounds" '((10 . 14)) + (with-temp-buffer + (insert "TODO one TODO two") + (tp-match-set "TODO" '(face warning) nil 5 18))) +(chk "V3-subexp" '(((8 10 bold) (13 14 bold)) ((0 3 bold))) + (list (tp-search (tp-regexp-set "\\([0-9]+\\)px" '(face bold) + "margin: 10px 4px" nil nil 1) + 'face) + ;; group 1 does not participate in the "bar" match + (tp-search (tp-regexp-set "\\(foo\\)\\|bar" '(face bold) + "foo bar" nil nil 1) + 'face))) +(chk "V3-subexp-out-of-range" + '(:ERROR (error "Regexp \"[0-9]+\" has no group 2")) + (tp-regexp-set "[0-9]+" '(face bold) "abc 123" nil nil 2)) +(chk "V3-regexp-bounds-and-reversed" '(((1 3 bold)) ((1 3 bold))) + (list (tp-search (tp-regexp-set "a+" '(face bold) "aaaa" 1 3) 'face) + (tp-search (tp-regexp-set "a+" '(face bold) "aaaa" 3 1) 'face))) + +;; ---- 0.3.0: PREDICATE / NOT-CURRENT ---- +(chk "V3-predicate" '((3 6) ((6 11 20))) + (list (with-temp-buffer + (insert "abcdef") + (tp-set 1 3 '(size 10)) + (tp-set 3 6 '(size 20)) + (goto-char 1) + (let ((match (tp-forward 'size 15 nil 1 + (lambda (target v) (and v (> v target)))))) + (list (prop-match-beginning match) (prop-match-end match)))) + (let ((str (copy-sequence "hello world"))) + (tp-set 0 5 '(size 10) str) + (tp-set 6 11 '(size 20) str) + (tp-forward 'size 15 str 2 + (lambda (target v) (and v (> v target))))))) +(chk "V3-not-current" '(2 5) + (with-temp-buffer + (insert "one two") + (tp-set 1 4 '(mark t)) + (tp-set 5 8 '(mark t)) + (let (a b) + (goto-char 2) + (setq a (prop-match-beginning (tp-forward 'mark t))) + (goto-char 2) + (setq b (prop-match-beginning (tp-forward 'mark t nil 1 nil t))) + (list a b)))) + +;; ---- 0.3.0: multi-argument parameterized layers ---- +(chk "V3-multiarg-specs" '((:foreground "red" :background "blue") + ((:foreground "red" :background "blue") "tip") + (:foreground "white" :background "black")) + (progn + (tp-layer-reset) + (define-tp tp-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + (list (tp-at 0 'face (tp-set "hello" 'tp-colors "red" "blue")) + (let ((str (copy-sequence "hello"))) + (tp-set 0 5 '(tp-colors ("red" "blue") help-echo "tip") str) + (list (tp-at 0 'face str) (tp-at 0 'help-echo str))) + (with-temp-buffer + (insert "Hello World") + (tp-put-layer 1 10 '(tp-colors "white" "black") 0) + (tp-at 1 'face))))) +(chk "V3-multiarg-arity-error" + '(:ERROR (error "tp layer tp-colors takes 2 argument(s), got 1")) + (tp-set "hello" 'tp-colors "red")) +(chk "V3-args-introspection" + '((face (:foreground "red" :background "blue")) + (fg bg) + ((face (:foreground "white" :background "black")) (face bold))) + (progn + (define-tps tp-badge (fg bg) + `(tp-colors ,fg ,bg) + '(face bold)) + (list (tp-layer-props-with-args 'tp-colors '("red" "blue")) + (tp-layer-arglist 'tp-colors) + (tp-group-props-with-args 'tp-badge '("white" "black"))))) + +;; ---- 0.3.0: layer visibility ---- +(chk "V3-hide-reveals-below" + '(:visible base :face default :count 2 :layers (highlight base)) + (progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (list :visible (tp-at 1 'tp-name) + :face (tp-at 1 'face) + :count (tp-layer-count 1 10) + :layers (tp-layer-list 1 10))))) +(chk "V3-hide-all-bare-and-show" '((:face nil :count 2) (:background "yellow")) + (progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-hide-layer 1 10 'base) + (let ((all-hidden (list :face (tp-at 1 'face) + :count (tp-layer-count 1 10)))) + (tp-show-layer 1 10 'highlight) + (list all-hidden (tp-at 1 'face)))))) +(chk "V3-hide-run-counts" '(1 0 0) + (progn + (tp-layer-reset) + (define-tp base () '(face default)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (list (tp-hide-layer 1 10 'base) + (tp-hide-layer 1 10 'base) + (tp-hide-layer 1 10 'nonexistent))))) +(chk "V3-merge-excludes-hidden" '(:face bold :help nil :name merged) + (progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(help-echo "tip")) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-hide-layer 1 10 'layer2) + (tp-merge-layers 1 10 'merged '(layer1 layer2)) + (list :face (tp-at 1 'face) + :help (tp-at 1 'help-echo) + :name (tp-at 1 'tp-name))))) +(chk "V3-flatten-discards-hidden" '(default flat) + (progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (tp-hide-layer 1 10 'highlight) + (tp-flatten-layers 1 10 'flat) + (list (tp-at 1 'face) (tp-at 1 'tp-name))))) + +;; ---- 0.3.0: movement additions and stack introspection ---- +(chk "V3-lower-layer" '(layer2 (layer2 layer3 layer1)) + (progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(face italic)) + (define-tp layer3 () '(face underline)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + (tp-lower-layer 1 10 'layer3 1) + (list (tp-layer-top 1 10) (tp-layer-list 1 10))))) +(chk "V3-rotate-canonical" '((layer1 layer3 layer2) (layer1 layer3 layer2)) + (progn + (tp-layer-reset) + (define-tp layer1 () '(face bold)) + (define-tp layer2 () '(face italic)) + (define-tp layer3 () '(face underline)) + (list (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + (tp-rotate-layer 1 10 'up) + (tp-layer-list 1 10)) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'layer1) + (tp-push-layer 1 10 'layer2) + (tp-push-layer 1 10 'layer3) + (tp-rotate-layer 1 10 'down 2) + (tp-layer-list 1 10))))) +;; Compared via assq/plist-get per layer: the top layer's PROPS come from +;; the direct text properties, whose plist order varies on Emacs 28. +(chk "V3-layer-stack-at" '(((highlight base) (:background "yellow") default nil) + ((highlight base) (:background "yellow") default t) + nil) + (progn + (tp-layer-reset) + (define-tp base () '(face default)) + (define-tp highlight () '(face (:background "yellow"))) + (with-temp-buffer + (insert "Hello World") + (tp-push-layer 1 10 'base) + (tp-push-layer 1 10 'highlight) + (let* ((probe (lambda () + (let ((stack (tp-layer-stack-at 1))) + (list (mapcar #'car stack) + (plist-get (cdr (assq 'highlight stack)) 'face) + (plist-get (cdr (assq 'base stack)) 'face) + (plist-get (cdr (assq 'highlight stack)) + 'tp-hidden))))) + (visible (funcall probe))) + (tp-hide-layer 1 10 'highlight) + (list visible + (funcall probe) + (with-temp-buffer (insert "Hello") (tp-layer-stack-at 1))))))) +(chk "V3-put-push-noerror" '(nil nil) + (with-temp-buffer + (insert "Hello World") + (list (tp-put-layer 1 10 'no-such-layer 0 nil t) + (tp-push-layer 1 10 'no-such-layer nil t)))) + +;; ---- 0.3.0: reactive layer-buffer registry and lifecycle ---- +(defvar reg-color "red") +(chk "V3-registry-and-track" '(unknown t (reg-layer)) + (progn + (tp-layer-reset) + (define-tp reg-layer () + :props '(face (:foreground $reg-color))) + (let ((before (tp-reactive-layer-buffers 'reg-layer))) + (with-temp-buffer + (insert "Hello") + (tp-push-layer 1 6 'reg-layer) + (let ((registered (equal (tp-reactive-layer-buffers 'reg-layer) + (list (current-buffer))))) + (list before + registered + (let ((s (tp-set "hello" 'reg-layer))) + (with-temp-buffer + (insert s) + (tp-reactive-track-buffer))))))))) +(defvar tmp-color "green") +(chk "V3-gc-anonymous" '(1 nil nil) + (progn + (tp-reactive-reset) + (tp-layer-reset) + (let ((buf (generate-new-buffer "*gc-demo*"))) + (with-current-buffer buf + (insert "Hello") + (tp-set 1 6 '(face (:foreground $tmp-color)))) + (kill-buffer buf) + (let ((collected (tp-gc-anonymous-layers))) + (list (length collected) + (tp-layer-props (car collected)) + ;; string-only layers stay `unknown' and are kept + (let ((s (tp-set "hello" '(face (:foreground $tmp-color))))) + (ignore s) + (tp-gc-anonymous-layers))))))) + +;; ---- 0.3.0: minimal-diff tp-text re-rendering ---- +(defvar counter-val "0") +(chk "V3-tp-text-minimal-diff" '("count: 9 items" 105 10) + (progn + (tp-layer-reset) + (setq counter-val "0") + (define-tp counter-label () + :props '(tp-text $counter-val)) + (with-temp-buffer + (insert "count: 0 items") + (tp-set 8 9 'counter-label) + (let ((m (copy-marker 10))) ; marker on the "i" of "items" + (setq counter-val "9") + (list (buffer-substring-no-properties 1 (point-max)) + (char-after m) + (marker-position m)))))) +(chk "V3-tp-text-noop-unmodified" nil + (with-temp-buffer + (insert "count: 9 items") + (tp-set 8 9 'counter-label) + (set-buffer-modified-p nil) + (setq counter-val "9") + (buffer-modified-p))) + +;; ---- 0.3.0: ABSOLUTE coordinates and palette primaries ---- +(chk "V3-intervals-absolute" + '(((1 6 (face bold)) (6 7 nil) (7 12 (face italic))) "bold text") + (list (with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (tp-set 7 12 '(face italic)) + (tp-intervals 1 12 nil t)) + (with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (dolist (iv (tp-intervals 1 12 nil t)) + (when (eq (plist-get (nth 2 iv) 'face) 'bold) + (tp-add (nth 0 iv) (nth 1 iv) '(help-echo "bold text")))) + (tp-at 1 'help-echo)))) +(chk "V3-intervals-map-absolute" '((1 6 bold) (6 7 nil) (7 12 italic)) + (with-temp-buffer + (insert "Hello World") + (tp-set 1 6 '(face bold)) + (tp-set 7 12 '(face italic)) + (tp-intervals-map + (lambda (start end props belows) + (ignore belows) + (list start end (plist-get props 'face))) + 1 12 nil t))) +;; The resolved color depends on the frame's light/dark mode, like the +;; U-parsecolor2 assertion above. +(chk "V3-palette-primaries" '(t nil (t t t nil)) + (list (and (member (tp-palette-color 'info :fg) + '("#0969da" "#58a6ff")) + t) + (tp-palette-color 'no-such-palette :fg) + (list (tp-palette-has-p 'info) + (tp-palette-has-p 'info :fg) + (tp-palette-has-p 'info :border) + (tp-palette-has-p 'no-such-palette)))) + +(princ (format "\nTOTAL: %d FAILS: %d\n" tp-doctest--total tp-doctest--fails)) +(when (> tp-doctest--fails 0) (kill-emacs 1)) ;;; tp-doctest.el ends here diff --git a/tp-layer-tests.el b/tp-layer-tests.el index 56b2278..29971eb 100644 --- a/tp-layer-tests.el +++ b/tp-layer-tests.el @@ -338,5 +338,373 @@ (tp-layer-reset) (should-not tp--anonymous-layer-registry))) +;;; 0.3.0 A4: multi-argument parameterized layers + +(ert-deftest tp-layer-test-multi-arg-define-and-props-with-args () + "define-tp accepts multi-symbol arglists; props-with-args expands them." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-fgbg (fg bg) + `(face (:foreground ,fg :background ,bg))) + (should (tp-layer-parameterized-p 'tp-layer-test-fgbg)) + (should (equal (tp-layer-arglist 'tp-layer-test-fgbg) '(fg bg))) + (should (equal (tp-layer-props-with-args 'tp-layer-test-fgbg + '("red" "blue")) + '(face (:foreground "red" :background "blue")))) + (should (equal (tp-layer-props-with-args 'tp-layer-test-fgbg + '("red" "blue") t) + '(face (:foreground "red" :background "blue") + tp-name tp-layer-test-fgbg))))) + +(ert-deftest tp-layer-test-props-with-arg-is-thin-wrapper () + "tp-layer-props-with-arg keeps its single-argument contract." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-fg1 (c) `(face (:foreground ,c))) + (should (equal (tp-layer-props-with-arg 'tp-layer-test-fg1 "red") + '(face (:foreground "red")))) + (should (equal (tp-layer-props-with-arg 'tp-layer-test-fg1 "red") + (tp-layer-props-with-args 'tp-layer-test-fg1 '("red")))))) + +(ert-deftest tp-layer-test-props-with-args-non-parameterized-nil () + "props-with-args and tp-layer-arglist return nil for other layers." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-np () '(face bold)) + (should-not (tp-layer-props-with-args 'tp-layer-test-np '(1))) + (should-not (tp-layer-arglist 'tp-layer-test-np)) + (should-not (tp-layer-props-with-args 'tp-layer-test-missing '(1))))) + +(ert-deftest tp-layer-test-multi-arg-tp-set-flat-string-form () + "The flat (tp-set STRING \\='LAYER ARG1 ARG2) form binds all params." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-fgbg (fg bg) + `(face (:foreground ,fg :background ,bg))) + (let ((s (tp-set "hello" 'tp-layer-test-fgbg "red" "blue"))) + (should (equal (get-text-property 0 'face s) + '(:foreground "red" :background "blue")))))) + +(ert-deftest tp-layer-test-multi-arg-tp-set-flat-with-extra-props () + "Extra props after multi args survive, with no stray nil pair." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-fgbg (fg bg) + `(face (:foreground ,fg :background ,bg))) + (let ((s (tp-set "hello" 'tp-layer-test-fgbg "red" "blue" + 'help-echo "tip"))) + (should (equal (plist-get (get-text-property 0 'face s) :foreground) + "red")) + (should (equal (get-text-property 0 'help-echo s) "tip")) + ;; The odd-length flat spec is padded with nil by key merging; + ;; resolution must strip it instead of setting a nil property. + (should (equal (text-properties-at 0 s) + '(face (:foreground "red" :background "blue") + help-echo "tip")))))) + +(ert-deftest tp-layer-test-multi-arg-tp-set-region-list-form () + "The region form (tp-set START END \\='(LAYER ARG1 ARG2)) works (1-based)." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-fgbg (fg bg) + `(face (:foreground ,fg :background ,bg))) + (with-temp-buffer + (insert "hello") + (tp-set 1 4 '(tp-layer-test-fgbg "red" "blue")) + (should (equal (get-text-property 1 'face) + '(:foreground "red" :background "blue"))) + (should-not (get-text-property 4 'face))))) + +(ert-deftest tp-layer-test-multi-arg-tp-set-wrapped-args-plist-form () + "The plist spec (LAYER (ARG1 ARG2) EXTRA...) passes args as one list." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-fgbg (fg bg) + `(face (:foreground ,fg :background ,bg))) + ;; Layer at the head of the plist. + (let ((s (copy-sequence "hello"))) + (tp-set 0 5 '(tp-layer-test-fgbg ("red" "blue") help-echo "tip") s) + (should (equal (get-text-property 0 'face s) + '(:foreground "red" :background "blue"))) + (should (equal (get-text-property 0 'help-echo s) "tip"))) + ;; Layer at a non-head plist position. + (let ((s (copy-sequence "hello"))) + (tp-set 0 5 '(help-echo "tip" tp-layer-test-fgbg ("red" "blue")) s) + (should (equal (plist-get (get-text-property 0 'face s) :background) + "blue")) + (should (equal (get-text-property 0 'help-echo s) "tip"))))) + +(ert-deftest tp-layer-test-multi-arg-normalize-layer-spec () + "tp--normalize-layer-spec accepts (LAYER ARG1 ARG2) specs." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-fgbg (fg bg) + `(face (:foreground ,fg :background ,bg))) + (should (equal (tp--normalize-layer-spec + '(tp-layer-test-fgbg "red" "blue")) + '(face (:foreground "red" :background "blue") + tp-name tp-layer-test-fgbg))))) + +(ert-deftest tp-layer-test-multi-arg-tp-put-layer () + "tp-put-layer accepts multi-argument parameterized layer specs." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-fgbg (fg bg) + `(face (:foreground ,fg :background ,bg))) + (let ((s (copy-sequence "hi"))) + (tp-put-layer s '(tp-layer-test-fgbg "red" "blue") 0) + (should (equal (get-text-property 0 'face s) + '(:foreground "red" :background "blue"))) + (should (eq (get-text-property 0 'tp-name s) 'tp-layer-test-fgbg))))) + +(ert-deftest tp-layer-test-multi-arg-cycle-detection () + "Cycle detection still fires through the multi-argument path." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-mcyc (a b) + `(tp-layer-test-mcyc (,a ,b))) + (let ((err (should-error + (tp-layer-props-with-args 'tp-layer-test-mcyc '(1 2))))) + (should (string-match-p "cyclic layer reference" + (error-message-string err)))))) + +(ert-deftest tp-layer-test-multi-arg-props-are-copies () + "props-with-args returns fresh copies; mutation cannot corrupt storage." + (tp-layer-tests--with-clean + ;; The (:weight bold) subform is a shared constant in the + ;; backquoted body; without copy-on-return, mutating the returned + ;; plist would corrupt every later expansion. + (define-tp tp-layer-test-mcopy (a b) + `(face (:weight bold) help-echo ,(format "%s-%s" a b))) + (let ((props (tp-layer-props-with-args 'tp-layer-test-mcopy '("x" "y")))) + (setcar (plist-get props 'face) 'MUTATED)) + (should (equal (tp-layer-props-with-args 'tp-layer-test-mcopy '("x" "y")) + '(face (:weight bold) help-echo "x-y"))))) + +(ert-deftest tp-layer-test-multi-arg-group () + "define-tps accepts multi-symbol arglists usable through tp-set specs." + (tp-layer-tests--with-clean + (define-tps tp-layer-test-mgrp (fg w) + `((face (:foreground ,fg))) + `((face (:weight ,w)))) + (should (tp-group-parameterized-p 'tp-layer-test-mgrp)) + (should (equal (tp--group-arglist 'tp-layer-test-mgrp) '(fg w))) + (should (equal (tp--group-props-with-args 'tp-layer-test-mgrp + '("red" bold)) + '((face (:foreground "red")) (face (:weight bold))))) + ;; Flat (GROUP ARG1 ARG2) spec through the tp-set pipeline. + (let ((props (tp--resolve-props '(tp-layer-test-mgrp "red" bold)))) + (should (equal (plist-get props 'face) '(:foreground "red"))) + (should (equal (plist-get props 'tp-layers) + '((face (:weight bold)))))) + ;; Single-argument groups keep working through the wrapper. + (define-tps tp-layer-test-sgrp (color) + `((face (:foreground ,color)))) + (should (equal (tp-group-props-with-arg 'tp-layer-test-sgrp "red") + '((face (:foreground "red"))))))) + +;;; 0.3.0 A5: tp-describe-layer and its data collector + +(ert-deftest tp-layer-test-describe-data-unified () + "Describe data for a define-tp layer reports the unified format." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-du () '(face bold)) + (let ((data (tp--describe-layer-data 'tp-layer-test-du))) + (should (eq (plist-get data :name) 'tp-layer-test-du)) + (should (eq (plist-get data :format) 'unified)) + (should (equal (plist-get data :body) '(quote (face bold)))) + (should (equal (plist-get data :props) + '(face bold tp-name tp-layer-test-du))) + (should-not (plist-get data :arglist)) + (should-not (plist-get data :reactive-deps)) + (should-not (plist-get data :transform)) + (should-not (plist-get data :group))))) + +(ert-deftest tp-layer-test-describe-data-flat () + "Describe data for an old-format layer reports the flat format." + (tp-layer-tests--with-clean + (tp--set-layer-props 'tp-layer-test-df '(face italic)) + (let ((data (tp--describe-layer-data 'tp-layer-test-df))) + (should (eq (plist-get data :format) 'flat)) + (should (equal (plist-get data :body) '(face italic))) + (should (equal (plist-get data :props) + '(face italic tp-name tp-layer-test-df)))))) + +(ert-deftest tp-layer-test-describe-data-parameterized () + "Describe data for a parameterized layer reports arglist and a note." + (tp-layer-tests--with-clean + (define-tp tp-layer-test-dp (a b) + `(face (:foreground ,a :background ,b))) + (let ((data (tp--describe-layer-data 'tp-layer-test-dp))) + (should (eq (plist-get data :format) 'parameterized)) + (should (equal (plist-get data :arglist) '(a b))) + ;; Expanded props need arguments, so a placeholder note is used. + (should (stringp (plist-get data :props))) + (should (string-match-p "tp-layer-props-with-args" + (plist-get data :props)))))) + +(ert-deftest tp-layer-test-describe-data-reactive () + "Describe data for a reactive layer reports format and dependencies." + (tp-layer-tests--with-clean + (setq tp-layer-test-b15-color "red") + (define-tp tp-layer-test-dr () + '(face (:foreground $tp-layer-test-b15-color))) + (let ((data (tp--describe-layer-data 'tp-layer-test-dr))) + (should (eq (plist-get data :format) 'reactive)) + (should (equal (plist-get data :reactive-deps) + '(tp-layer-test-b15-color)))))) + +(ert-deftest tp-layer-test-describe-data-group-and-transform () + "Describe data reports the owning group and transform presence." + (tp-layer-tests--with-clean + (define-tps tp-layer-test-dg () + '("a" :props (face bold) :transform upcase)) + (let ((data (tp--describe-layer-data 'tp-layer-test-dg-a))) + (should (eq (plist-get data :group) 'tp-layer-test-dg)) + (should (plist-get data :transform))))) + +(ert-deftest tp-layer-test-describe-data-unknown-layer-nil () + "Describe data returns nil for names not in tp-layer-alist." + (tp-layer-tests--with-clean + (should-not (tp--describe-layer-data 'tp-layer-test-nonexistent)))) + +(ert-deftest tp-layer-test-describe-layer-command () + "tp-describe-layer is a command and renders a help buffer." + (should (commandp 'tp-describe-layer)) + (tp-layer-tests--with-clean + (define-tp tp-layer-test-dc () '(face bold)) + (save-window-excursion + (tp-describe-layer 'tp-layer-test-dc) + (with-current-buffer (help-buffer) + (should (string-match-p "tp-layer-test-dc is a tp layer" + (buffer-string))) + (should (string-match-p "Storage format: unified" + (buffer-string))))) + (should-error (tp-describe-layer 'tp-layer-test-missing) + :type 'user-error))) + +;;; ARG-1: wrong-arity parameterized-layer calls signal clear errors + +(defmacro tp-layer-tests--with-colors (&rest body) + "Run BODY with the two-parameter test layer tp-lt-colors defined." + (declare (indent 0)) + `(tp-layer-tests--with-clean + (define-tp tp-lt-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + ,@body)) + +(ert-deftest tp-layer-test-props-with-args-missing-arg-errors () + "tp-layer-props-with-args signals on fewer args than parameters. +Since Emacs 27 `cl-progv' silently binds missing parameters to nil, +so the old docstring's promised unbound-variable error could never +fire; the arity is now checked explicitly (ARG-1)." + (tp-layer-tests--with-colors + (let ((err (should-error + (tp-layer-props-with-args 'tp-lt-colors '("red"))))) + ;; Parens are literal in Emacs regexps. + (should (string-match-p "takes 2 argument(s), got 1" (cadr err)))) + ;; Correct arity still works. + (should (equal (tp-layer-props-with-args 'tp-lt-colors + '("red" "blue")) + '(face (:foreground "red" :background "blue")))) + ;; Extra values are still ignored, per the documented contract. + (should (equal (tp-layer-props-with-args 'tp-lt-colors + '("red" "blue" "green")) + '(face (:foreground "red" :background "blue")))))) + +(ert-deftest tp-layer-test-tp-set-flat-missing-arg-errors () + "The flat tp-set form with too few layer args signals, not nil-binds. +Before ARG-1, (tp-set \"s\" \\='(layer \"red\")) on a two-parameter +layer silently produced (:foreground \"red\" :background nil)." + (tp-layer-tests--with-colors + (should-error (tp-set "s" '(tp-lt-colors "red"))))) + +(ert-deftest tp-layer-test-tp-set-flat-excess-arg-errors () + "Flat-form excess positional args signal instead of corrupting props. +Before ARG-1, the excess string fell into extra-props and was applied +as a text-property KEY with value nil." + (tp-layer-tests--with-colors + (let ((err (should-error + (tp-set "gg" '(tp-lt-colors "red" "blue" "green"))))) + (should (string-match-p "excess argument" (cadr err)))) + ;; Correct-arity flat form is unchanged. + (should (equal (text-properties-at + 0 (tp-set "ok" '(tp-lt-colors "red" "blue"))) + '(face (:foreground "red" :background "blue")))) + ;; Legitimate extra PROPS after the args still work. + (should (equal (plist-get + (text-properties-at + 0 (tp-set "ok" '(tp-lt-colors "red" "blue" + help-echo "tip"))) + 'help-echo) + "tip")) + ;; The wrapped-args form with extra props is untouched as well. + (should (equal (plist-get + (text-properties-at + 0 (tp-set "ok" '(tp-lt-colors ("red" "blue") + help-echo "tip"))) + 'help-echo) + "tip")))) + +(ert-deftest tp-layer-test-stack-path-wrong-arity-clear-error () + "The stack path signals a clear arity error, not \"Odd length ...\". +Before ARG-1, (tp-push-layer s \\='(layer \"red\")) fell through +tp--normalize-layer-spec's named-inline branch, producing the odd +plist (\"red\" tp-name layer) and the cryptic error \"Odd length +text property list\"." + (tp-layer-tests--with-colors + (let ((err (should-error + (tp-push-layer (copy-sequence "st") + '(tp-lt-colors "red"))))) + (should (string-match-p "expects 2 args, got 1" (cadr err)))) + (let ((err (should-error + (tp--normalize-layer-spec '(tp-lt-colors "red"))))) + (should (string-match-p "expects 2 args, got 1" (cadr err)))) + ;; Correct arity through the stack path is unchanged. + (let ((s (copy-sequence "st"))) + (tp-push-layer s '(tp-lt-colors "red" "blue")) + (should (equal (text-properties-at 0 s) + '(face (:foreground "red" :background "blue") + tp-name tp-lt-colors)))))) + +;;; API-SYM-01: public tp-group-props-with-args mirrors the layer pair + +(ert-deftest tp-layer-test-group-props-with-args-public () + "The public plural group accessor matches the private path." + (tp-layer-tests--with-clean + (define-tps tp-layer-test-pgrp (fg w) + `((face (:foreground ,fg))) + `((face (:weight ,w)))) + (should (equal (tp-group-props-with-args 'tp-layer-test-pgrp + '("red" bold)) + '((face (:foreground "red")) (face (:weight bold))))) + (should (equal (tp-group-props-with-args 'tp-layer-test-pgrp + '("red" bold)) + (tp--group-props-with-args 'tp-layer-test-pgrp + '("red" bold)))) + (should (equal (tp-group-props-with-args 'tp-layer-test-pgrp + '("red" bold) t) + (tp--group-props-with-args 'tp-layer-test-pgrp + '("red" bold) t))) + ;; Non-parameterized or undefined groups return nil, like the + ;; layer counterpart. + (should-not (tp-group-props-with-args 'tp-layer-test-nope '("x"))))) + +;;; API-NAME-02: prefix-conforming tp-define-* aliases + +(ert-deftest tp-layer-test-define-layer-alias () + "tp-define-layer is a working macro alias of define-tp." + (tp-layer-tests--with-clean + (tp-define-layer tp-layer-test-alias-l () + '(face bold)) + (should (equal (tp-layer-props 'tp-layer-test-alias-l) '(face bold))) + ;; Parameterized definitions work through the alias too. + (tp-define-layer tp-layer-test-alias-p (color) + `(face (:foreground ,color))) + (should (equal (tp-layer-props-with-arg 'tp-layer-test-alias-p "red") + '(face (:foreground "red")))))) + +(ert-deftest tp-layer-test-define-group-alias () + "tp-define-group is a working macro alias of define-tps." + (tp-layer-tests--with-clean + (tp-define-layer tp-layer-test-alias-m () + '(face italic)) + (tp-define-group tp-layer-test-alias-g () + 'tp-layer-test-alias-m + '(face bold)) + (should (assoc 'tp-layer-test-alias-g tp-layer-groups)) + (should (equal (tp-group-props 'tp-layer-test-alias-g) + '((face italic) (face bold)))))) + (provide 'tp-layer-tests) ;;; tp-layer-tests.el ends here diff --git a/tp-layer.el b/tp-layer.el index 07f7d70..e57e1ff 100644 --- a/tp-layer.el +++ b/tp-layer.el @@ -51,6 +51,23 @@ named elements) are recorded here; layers merely referenced by name are not. Used to clean up orphaned layers when a group is redefined or undefined.") +;; The counter below INTENTIONALLY survives `tp-layer-reset' (which +;; clears `tp--anonymous-layer-registry' but not this): detached +;; strings can outlive a reset while still carrying `tp-anon-N' +;; property values, so the counter must keep increasing monotonically +;; - a post-reset anonymous layer must never be minted under a name a +;; stale string still holds. Do not "fix" this by resetting it. +(defvar tp--anonymous-layer-counter 0 + "Counter for generating unique anonymous layer names. +Never reset - not even by `tp-layer-reset' - so freshly minted +`tp-anon-N' names cannot collide with names living on in detached +strings (see the comment above).") + +(defun tp--generate-anonymous-layer-name () + "Generate a unique symbol for anonymous reactive layers." + (setq tp--anonymous-layer-counter (1+ tp--anonymous-layer-counter)) + (intern (format "tp-anon-%d" tp--anonymous-layer-counter))) + (defvar tp--anonymous-layer-registry nil "Alist interning anonymous reactive layers: (PROPS-SPEC . LAYER-NAME). PROPS-SPEC is the original (unresolved) props spec passed to @@ -69,6 +86,55 @@ and record it in `tp--anonymous-layer-registry'." (push (cons (copy-tree props) name) tp--anonymous-layer-registry) name))) +(defun tp--buffer-has-layer-region-p (layer-name &optional buffer) + "Return non-nil when BUFFER has a region carrying LAYER-NAME. +BUFFER defaults to the current buffer; a dead BUFFER yields nil. +Stack-aware: the layer counts as present when it is the rendered top +layer (direct `tp-name' text property) or sits anywhere inside the +`tp-layers' stack-storage property - buried below another layer, or +hidden (see `tp-hide-layer') - so liveness checks never miss a layer +a live buffer still holds. Built on the shared scan +`tp-reactive--buffer-layer-names'." + (and (member layer-name (tp-reactive--buffer-layer-names buffer)) t)) + +;;;###autoload +(defun tp-gc-anonymous-layers () + "Collect anonymous layers that no live buffer displays anymore. +Walk `tp--anonymous-layer-registry' and, for every interned anonymous +layer whose buffer registry has real knowledge (see +`tp-reactive-layer-buffers'), check whether any registered live +buffer still contains a region carrying the layer - as the rendered +top layer or anywhere inside `tp-layers' stack storage, so buried and +hidden layers count as alive (see `tp--buffer-has-layer-region-p'). +Layers displayed nowhere are undefined via `tp-undefine-layer', which +also drops their reactive dependencies, transforms and registry +entries. + +Layers whose registry state is `unknown' are conservatively kept: +they were never seen in any buffer through the registering paths, +and detached strings may still reference them. A layer becomes +collectable only after it was registered for at least one buffer and +none of the registered buffers still shows it (for example after the +buffers were killed); call `tp-reactive-track-buffer' after +inserting propertized strings so their buffers are registered too. + +Return the list of collected layer names." + (interactive) + (let ((collected nil)) + ;; Snapshot the names first: `tp-undefine-layer' mutates the + ;; anonymous-layer registry while we iterate. + (dolist (name (mapcar #'cdr tp--anonymous-layer-registry)) + (let ((bufs (tp-reactive-layer-buffers name))) + (when (and (not (eq bufs 'unknown)) + (not (cl-some (lambda (buf) + (tp--buffer-has-layer-region-p name buf)) + bufs))) + (tp-undefine-layer name) + (push name collected)))) + (when (called-interactively-p 'interactive) + (message "tp: collected %d anonymous layer(s)" (length collected))) + (nreverse collected))) + (defvar tp--layer-expansion-stack nil "Layer names currently being expanded, innermost first. Dynamically bound during `tp-layer-props' / `tp-layer-props-with-arg' @@ -83,70 +149,6 @@ The error message names the full cycle, e.g. \"a -> b -> a\"." (reverse (cons layer-name tp--layer-expansion-stack)) " -> ")))) -(defun tp--expand-layer-to-props-list (layer-name str start) - "Expand LAYER-NAME to a list of property keys it contributes. -If LAYER-NAME is a layer defined in `tp-layer-alist', returns a list -of the property keys that the layer adds, plus 'tp-name. -STR and START are used to get the argument value for parameterized layers. -For non-layer symbols, returns a list containing just that symbol." - (if (tp--is-layer-name-p layer-name) - (let* ((existing-props (text-properties-at start str)) - (existing-tp-name (plist-get existing-props 'tp-name)) - (layer-prop-value (plist-get existing-props layer-name)) - ;; Proceed if tp-name matches OR if the layer property exists - ;; (for cases where layer was used in mixed syntax without tp-name) - (layer-props - (cond - ;; tp-name matches - traditional layer application - ((eq existing-tp-name layer-name) - (cond - ;; Parameterized layer - get property keys it would produce - ;; We pass a dummy arg (t) since we only need the key names, not values - ((tp-layer-parameterized-p layer-name) - (tp-layer-props-with-arg layer-name t nil)) ; arg=t, include-tp-name=nil - ;; Non-parameterized layer - ((assoc layer-name tp-layer-alist) - (tp-layer-props layer-name nil)) ; include-tp-name=nil - ;; Layer group - ((assoc layer-name tp-layer-groups) - (when-let ((layer-props-list (tp-group-props layer-name t))) - (tp--build-layer-props layer-props-list))))) - ;; Layer property exists (mixed syntax like `tp-set str 'face 'bold 'layer arg`) - ;; In this case, the layer's face properties are merged into face - (layer-prop-value - (cond - ((tp-layer-parameterized-p layer-name) - (tp-layer-props-with-arg layer-name layer-prop-value nil)) - ((assoc layer-name tp-layer-alist) - (tp-layer-props layer-name nil)) - ((assoc layer-name tp-layer-groups) - (when-let ((layer-props-list (tp-group-props layer-name t))) - (tp--build-layer-props layer-props-list)))))))) - (if layer-props - ;; Return all property keys from the layer plus tp-name and the layer itself - (let ((keys (cl-loop for (key _val) on layer-props by #'cddr - collect key))) - (unless (memq 'tp-name keys) - (push 'tp-name keys)) - (unless (memq layer-name keys) - (push layer-name keys)) - keys) - ;; Layer name doesn't match tp-name and layer property doesn't exist - ;; Just remove the literal symbol - (list layer-name))) - ;; Not a layer name, just return the symbol itself - (list layer-name))) - -(defun tp--expand-props-to-remove (props-to-remove str start) - "Expand PROPS-TO-REMOVE list, expanding any layer names to their property keys. -STR and START are used to determine context for parameterized layers." - (let ((result nil)) - (dolist (prop props-to-remove) - (dolist (expanded (tp--expand-layer-to-props-list prop str start)) - (unless (memq expanded result) - (push expanded result)))) - (nreverse result))) - (defun tp--get-layer-face-contribution (layer-name layer-prop-value) "Get the face contribution from LAYER-NAME. LAYER-PROP-VALUE is the value of the layer property (the argument passed to it). @@ -155,7 +157,7 @@ Returns the face value that the layer adds, or nil if no face contribution." (let ((layer-props (cond ((tp-layer-parameterized-p layer-name) - (tp-layer-props-with-arg layer-name layer-prop-value nil)) + (tp--layer-props-for-arg-value layer-name layer-prop-value nil)) ((assoc layer-name tp-layer-alist) (tp-layer-props layer-name nil)) ((assoc layer-name tp-layer-groups) @@ -167,13 +169,13 @@ Returns the face value that the layer adds, or nil if no face contribution." (defun tp--parse-define-layer-args (args) "Parse ARGS for tp--define-layer-internal function. Returns plist with keys :props, :data, :watch, :compute, :transform. -- Keyword arguments: :props PLIST [:data DATA] [:watch WATCH] [:compute COMPUTE] [:transform FN]" - (let (props data watch compute transform has-keywords) +- Keyword arguments: :props PLIST [:data DATA] [:watch WATCH] + [:compute COMPUTE] [:transform FN]" + (let (props data watch compute transform) (cond ;; Check for keyword arguments format ((and (keywordp (car args)) (memq (car args) '(:props :data :watch :compute :transform))) - (setq has-keywords t) ;; Parse keyword arguments (let ((rest args)) (while rest @@ -203,11 +205,14 @@ Format 1 - Direct plist (no :watch/:compute/:data/:transform support): (tp--define-layer-internal \\='layer-name \\='(display \"🌑\" face (:height 1.0))) -Format 2 - With :props, :data, :watch, :compute, and/or :transform (Vue 3 style reactivity): +Format 2 - With :props, :data, :watch, :compute, and/or :transform +\(Vue 3 style reactivity): (tp--define-layer-internal \\='layer-name - ;; props: $-prefixed symbols are reactive variables; auto-defined if not bound + ;; props: $-prefixed symbols are reactive variables; + ;; auto-defined if not bound :props \\='(face (:foreground $my-color) help-echo $full-name) - ;; data: additional reactive variables not used in props; auto-defined if not bound + ;; data: additional reactive variables not used in props; + ;; auto-defined if not bound :data \\='((first-name . \"John\") (last-name . \"Doe\")) ;; compute: list of (VAR-NAME FUNCTION) - compute reactive variable values :compute \\='((full-name (lambda () (concat first-name \" \" last-name)))) @@ -234,7 +239,8 @@ Reactive Variables: :transform - A function that receives the tp-text value and returns a transformed string. Useful for formatting numbers, dates, or other values - before display. Example: (lambda (text) (format \"$%.2f\" (string-to-number text))) + before display. + Example: (lambda (text) (format \"$%.2f\" (string-to-number text))) Note: When using :watch, :compute, or :data, you MUST use :props to specify the text properties explicitly. @@ -306,6 +312,7 @@ The layer is stored in `tp-layer-alist'." (tp--layer-refresh name) (assoc name tp-layer-alist))))) +;;;###autoload (defmacro define-tp (name arglist &rest body) "Define a text property layer named NAME. @@ -315,11 +322,14 @@ Format 1 - Non-parameterized simple (empty arglist, simple body): (define-tp tp-bold () \\='(face bold)) -Format 2 - Parameterized simple (single argument, simple body): +Format 2 - Parameterized simple (one or more arguments, simple body): (define-tp tp-space (pixel) \\=`(display (space :width (,pixel)))) + (define-tp tp-colors (fg bg) + \\=`(face (:foreground ,fg :background ,bg))) -Format 3 - Non-parameterized with reactive features (requires $-prefixed variables): +Format 3 - Non-parameterized with reactive features +\(requires $-prefixed variables): (define-tp my-layer () :props \\='(face (:foreground $my-color)) :data \\='((my-color . \"red\")) @@ -334,12 +344,13 @@ Usage: ARGLIST must be either: - An empty list () for non-parameterized layers -- A list containing exactly one symbol for parameterized layers +- A list of one or more parameter symbols for parameterized layers BODY is either: - A single property list expression (simple format) - Keyword arguments starting with :props, :data, :compute, :watch, or :transform - (reactive format - only for non-parameterized layers with $-prefixed variables) + (reactive format - only for non-parameterized layers with $-prefixed + variables) In simple format, exactly one body form is accepted; supplying more than one signals an error at macro-expansion time instead of silently @@ -349,7 +360,7 @@ $-prefixed reactive symbols appearing in a PARAMETERIZED body do not create reactive dependencies (parameterized layers cannot be reactive); they are resolved to the current value of the corresponding variable each time the layer is evaluated via -`tp-layer-props-with-arg'. +`tp-layer-props-with-arg' or `tp-layer-props-with-args'. Note: NAME cannot be a built-in Emacs text property name like `face', `display', `invisible', etc. See `tp--builtin-text-properties' for the @@ -379,18 +390,30 @@ complete list of reserved names." ;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM) ((null arglist) `(tp--define-layer-unified ',name nil ,simple-body)) - ;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM) - ((and (= (length arglist) 1) - (symbolp (car arglist))) + ;; Parameterized: one or more argument symbols - store as + ;; (LAYER-NAME ARGLIST BODY-FORM) + ((cl-every #'symbolp arglist) `(tp--define-layer-unified ',name ',arglist ',simple-body)) (t - (error "define-tp ARGLIST must be empty or contain exactly one symbol")))))))) + (error "define-tp ARGLIST must be empty or a list of symbols")))))))) + +;;;###autoload +(defalias 'tp-define-layer 'define-tp + "Define a text property layer named NAME; alias of `define-tp'. +This is the package-prefix-conforming name for the layer definition +macro, so it is discoverable via the tp- prefix; `define-tp' is the +historical name and both are permanent - neither will be removed. +See `define-tp' for the full documentation of NAME, ARGLIST and +BODY.") +(function-put 'tp-define-layer 'lisp-indent-function 'defun) (defun tp--define-layer-unified (name arglist body) "Define a layer NAME with ARGLIST and BODY using unified structure. For non-parameterized layers, ARGLIST is nil and BODY is the evaluated plist. -For parameterized layers, ARGLIST contains one symbol and BODY is the unevaluated form. -Stores the layer in `tp-layer-alist' with format: (LAYER-NAME ARGLIST BODY-FORM). +For parameterized layers, ARGLIST is a list of one or more parameter +symbols and BODY is the unevaluated form. +Stores the layer in `tp-layer-alist' with format: +\(LAYER-NAME ARGLIST BODY-FORM). For non-parameterized layers, if BODY contains reactive symbols ($-prefixed), delegates to `tp--define-layer-internal' for proper reactive handling." @@ -417,7 +440,8 @@ delegates to `tp--define-layer-internal' for proper reactive handling." (defun tp--layer-group-element-format (element) "Determine the format type of ELEMENT. -Returns 'symbol, 'format-1, 'format-2, 'format-3, 'format-4, or nil if invalid." +Returns `symbol', `format-1', `format-2', `format-3', `format-4', or +nil if invalid." (cond ;; Symbol - reference to existing layer ((symbolp element) 'symbol) @@ -452,9 +476,11 @@ Returns 'symbol, 'format-1, 'format-2, 'format-3, 'format-4, or nil if invalid." (t nil))) (defun tp--parse-layer-group-element (group-name element idx) - "Parse a layer group element and return (layer-name . properties) or extended form. + "Parse a layer group element and return (layer-name . properties) +or extended form. GROUP-NAME is the name of the layer group. -ELEMENT is the element to parse (can be anonymous plist, cons-cell, or :props form). +ELEMENT is the element to parse (can be anonymous plist, cons-cell, +or :props form). IDX is the index for anonymous elements. Returns a cons cell (LAYER-NAME . PROPERTIES) or a symbol if ELEMENT @@ -634,7 +660,8 @@ ELEMENTS is the list of layer definitions." (defun tp--define-layer-group-unified (name arglist body-form) "Define a parameterized layer group NAME with ARGLIST and BODY-FORM. -Stores the group in `tp-layer-groups' with format: (GROUP-NAME ARGLIST BODY-FORM). +Stores the group in `tp-layer-groups' with format: +\(GROUP-NAME ARGLIST BODY-FORM). Layers generated by a previous non-parameterized definition of NAME are undefined, since a parameterized group generates none." (dolist (stale (cdr (assq name tp--group-generated-layers))) @@ -647,15 +674,17 @@ are undefined, since a parameterized group generates none." (push (cons name entry) tp-layer-groups))) (assoc name tp-layer-groups)) +;;;###autoload (defmacro define-tps (name arglist &rest body) "Define a text property group named NAME. -This macro defines a group of text properties (layers) that can be used together. +This macro defines a group of text properties (layers) that can be +used together. It follows the same format as `define-tp' for consistency. ARGLIST must be either: - An empty list () for non-parameterized groups -- A list containing exactly one symbol for parameterized groups +- A list of one or more parameter symbols for parameterized groups BODY contains the layer definitions, which should be quoted lists. @@ -664,7 +693,7 @@ Format 1 - Non-parameterized (empty arglist): \\='(display \"🌑\") \\='(display \"🌕\")) -Format 2 - Parameterized (with argument): +Format 2 - Parameterized (with one or more arguments): (define-tps my-status (color) \\=`((face (:foreground ,color))) \\='(face (:weight bold))) @@ -686,7 +715,8 @@ Format 4 - Named layer with :props keyword (named as NAME-suffix): Format 5 - Named layer with :props, :data, :watch, and/or :compute: \\='(\"reactive\" :props (face (:foreground $my-color)) :data ((my-color . \"red\")) - :watch ((my-color (lambda (new old layer) (message \"Changed!\"))))) + :watch ((my-color (lambda (new old layer) + (message \"Changed!\"))))) Note: NAME cannot be a built-in Emacs text property name like `face', `display', `invisible', etc. See `tp--builtin-text-properties' for the @@ -701,22 +731,33 @@ complete list of reserved names." ;; Non-parameterized: empty arglist ((null arglist) `(tp--define-layer-group-internal ',name nil (list ,@body))) - ;; Parameterized: single argument - ((and (= (length arglist) 1) - (symbolp (car arglist))) + ;; Parameterized: one or more argument symbols + ((cl-every #'symbolp arglist) `(tp--define-layer-group-unified ',name ',arglist '(list ,@body))) (t - (error "define-tps ARGLIST must be empty or contain exactly one symbol")))) + (error "define-tps ARGLIST must be empty or a list of symbols")))) ;; For backward compatibility, keep define-tp-group as an alias (defalias 'define-tp-group 'define-tps "Alias for `define-tps' for backward compatibility.") +;;;###autoload +(defalias 'tp-define-group 'define-tps + "Define a text property group named NAME; alias of `define-tps'. +This is the package-prefix-conforming name for the group definition +macro, so it is discoverable via the tp- prefix; `define-tps' and +`define-tp-group' are the historical names and all three are +permanent - none will be removed. See `define-tps' for the full +documentation of NAME, ARGLIST and BODY.") +(function-put 'tp-define-group 'lisp-indent-function 'defun) + (defun tp--set-layer-props (layer-name properties) "Set PROPERTIES for layer LAYER-NAME in `tp-layer-alist'. If the layer already exists, updates its properties; otherwise creates it. -Stores as (LAYER-NAME . PROPERTIES) for backward compatibility with reactive layers. -This is an internal function used by layer definition macros and reactive updates." +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))) @@ -731,12 +772,15 @@ This is an internal function used by group definition macros." (defun tp-layer-props (layer-name &optional include-tp-name) "Return properties for layer LAYER-NAME from `tp-layer-alist'. -If INCLUDE-TP-NAME is non-nil, appends 'tp-name property to identify the layer. -Also includes tp-name automatically if the layer has reactive dependencies registered. +If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify +the layer. +Also includes tp-name automatically if the layer has reactive +dependencies registered. Handles two storage formats: 1. Old format (from tp--set-layer-props): (LAYER-NAME . PLIST) - flat plist 2. Unified format (from define-tp): (LAYER-NAME ARGLIST BODY-FORM) -For parameterized layers (ARGLIST non-nil), returns nil - use `tp-layer-props-with-arg'. +For parameterized layers (ARGLIST non-nil), returns nil - use +`tp-layer-props-with-arg'. Recursively expands any nested layer names in the returned plist. Signals an error naming the cycle if layer references are cyclic. The returned plist is a fresh copy: mutating it does not affect the @@ -791,40 +835,94 @@ where ARGLIST is a non-nil list of argument symbols." (not (null (car entry))) (cl-every #'symbolp (car entry))))) -(defun tp-layer-props-with-arg (layer-name arg &optional include-tp-name) - "Return properties for parameterized layer LAYER-NAME with ARG. -Evaluates the body form with the argument bound to the parameter. -If INCLUDE-TP-NAME is non-nil, appends 'tp-name property to identify the layer. +(defun tp-layer-arglist (layer-name) + "Return the parameter list of parameterized layer LAYER-NAME. +Returns nil when LAYER-NAME is not a parameterized layer (including +non-parameterized and undefined layers). The returned list is a copy +of the ARGLIST given to `define-tp', e.g. (fg bg) for a +two-parameter layer." + (when (tp-layer-parameterized-p layer-name) + (copy-sequence (car (cdr (assoc layer-name tp-layer-alist)))))) + +(defun tp-layer-props-with-args (layer-name args &optional include-tp-name) + "Return properties for parameterized layer LAYER-NAME with ARGS. +ARGS is a list of argument values bound positionally (via `cl-progv', +so dynamically) to the layer's parameters while the stored body form +is evaluated. Extra values are ignored; passing fewer values than +the layer has parameters signals a wrong-arity error (since Emacs 27 +`cl-progv' silently binds missing parameters to nil, so the arity is +checked explicitly here). +If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify +the layer. Recursively expands any nested layer names in the returned plist. $-prefixed reactive symbols in the body are resolved to the current values of their variables at evaluation time; they do not create reactive dependencies (parameterized layers cannot be reactive). Signals an error naming the cycle if layer references are cyclic. The returned plist is a fresh copy: mutating it does not affect the -stored layer definition." - (when-let ((entry (cdr (assoc layer-name tp-layer-alist)))) - ;; entry is (ARGLIST BODY-FORM) - (let ((arglist (car entry)) - (body (cadr entry))) - (when arglist ; Only for parameterized layers - (tp--check-layer-cycle layer-name) - (let* ((tp--layer-expansion-stack - (cons layer-name tp--layer-expansion-stack)) - (arg-sym (car arglist)) - ;; Evaluate the body with the argument bound - (plist (eval `(let ((,arg-sym ',arg)) ,body)))) - (when plist - ;; Recursively expand nested layer names - (when (tp--plist-has-layer-key-p plist) - (setq plist (tp--expand-layer-in-plist plist))) - ;; Resolve $-prefixed reactive symbols to their current values - ;; so they never leak literally into the returned props. - (when (tp--collect-reactive-symbols plist) - (setq plist (tp--resolve-reactive-symbols plist))) - (copy-tree - (if include-tp-name - (append plist (list 'tp-name layer-name)) - plist)))))))) +stored layer definition. +Returns nil when LAYER-NAME is not a parameterized layer. + +See also `tp-layer-props-with-arg' - note the one-character name +difference - for the single-argument convenience, and +`tp-group-props-with-args' for the group counterpart." + (when (tp-layer-parameterized-p layer-name) + (let* ((entry (cdr (assoc layer-name tp-layer-alist))) + (arglist (car entry)) + (body (cadr entry))) + (when (< (length args) (length arglist)) + (error "tp layer %s takes %d argument(s), got %d" + layer-name (length arglist) (length args))) + (tp--check-layer-cycle layer-name) + (let* ((tp--layer-expansion-stack + (cons layer-name tp--layer-expansion-stack)) + ;; Evaluate the body with all parameters bound. `eval' + ;; without a lexical environment sees the dynamic + ;; bindings established by `cl-progv'. + (plist (cl-progv arglist args (eval body)))) + (when plist + ;; Recursively expand nested layer names + (when (tp--plist-has-layer-key-p plist) + (setq plist (tp--expand-layer-in-plist plist))) + ;; Resolve $-prefixed reactive symbols to their current values + ;; so they never leak literally into the returned props. + (when (tp--collect-reactive-symbols plist) + (setq plist (tp--resolve-reactive-symbols plist))) + (copy-tree + (if include-tp-name + (append plist (list 'tp-name layer-name)) + plist))))))) + +(defun tp-layer-props-with-arg (layer-name arg &optional include-tp-name) + "Return properties for parameterized layer LAYER-NAME with ARG. +Evaluates the body form with the argument bound to the parameter. +This is the single-argument convenience over +`tp-layer-props-with-args' - note the one-character name difference - +equivalent to calling it with (list ARG). +If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify +the layer. +Recursively expands any nested layer names in the returned plist. +$-prefixed reactive symbols in the body are resolved to the current +values of their variables at evaluation time; they do not create +reactive dependencies (parameterized layers cannot be reactive). +Signals an error naming the cycle if layer references are cyclic. +The returned plist is a fresh copy: mutating it does not affect the +stored layer definition. + +See also `tp-group-props-with-arg' for the group counterpart." + (tp-layer-props-with-args layer-name (list arg) include-tp-name)) + +(defun tp--layer-props-for-arg-value (layer-name value &optional include-tp-name) + "Return props for parameterized LAYER-NAME given a stored VALUE. +When LAYER-NAME takes more than one parameter and VALUE is a proper +list, VALUE is treated as the full argument list (as stored by the +plist-style spec (LAYER-NAME (ARG1 ARG2 ...))); otherwise VALUE is +the single argument (the single-parameter behavior). +INCLUDE-TP-NAME is passed through." + (if (and (proper-list-p value) + (> (length (tp-layer-arglist layer-name)) 1)) + (tp-layer-props-with-args layer-name value include-tp-name) + (tp-layer-props-with-arg layer-name value include-tp-name))) (defun tp-group-props (group-name &optional include-tp-name) "Return list of properties for all layers in GROUP-NAME. @@ -860,6 +958,13 @@ where ARGLIST is a non-nil list of argument symbols." (not (null (car entry))) (cl-every #'symbolp (car entry))))) +(defun tp--group-arglist (group-name) + "Return the parameter list of parameterized group GROUP-NAME. +Returns nil when GROUP-NAME is not a parameterized group. The +returned list is a copy of the ARGLIST given to `define-tps'." + (when (tp-group-parameterized-p group-name) + (copy-sequence (car (cdr (assoc group-name tp-layer-groups)))))) + (defun tp--group-anonymous-props (plist) "Normalize anonymous-layer PLIST from a parameterized group element. Expands nested layer names, resolves $-prefixed reactive symbols to @@ -891,10 +996,13 @@ Returns nil if SPEC cannot be interpreted." ((not (consp spec)) nil) ;; (LAYER-NAME ARG ...) - defined layer at the head ((and (symbolp (car spec)) (tp--is-layer-name-p (car spec))) - (let ((layer-name (car spec)) - (layer-arg (cadr spec))) + (let ((layer-name (car spec))) (if (tp-layer-parameterized-p layer-name) - (tp-layer-props-with-arg layer-name layer-arg include-tp-name) + ;; Bind as many arguments as the layer has parameters. + (tp-layer-props-with-args + layer-name + (-take (length (tp-layer-arglist layer-name)) (cdr spec)) + include-tp-name) ;; Non-parameterized layer - arg should be t or ignored (tp-layer-props layer-name include-tp-name)))) ;; ("NAME" :props PLIST) or ("NAME" . PLIST) - use the props part @@ -911,26 +1019,69 @@ Returns nil if SPEC cannot be interpreted." (tp--group-anonymous-props spec)) (t nil))) +(defun tp--group-props-with-args (group-name args &optional include-tp-name) + "Return list of properties for parameterized group GROUP-NAME with ARGS. +ARGS is a list of argument values bound positionally (via `cl-progv', +so dynamically) to the group's parameters while the stored body form +is evaluated. Each evaluated element is converted like +`tp-group-props-with-arg' documents. If INCLUDE-TP-NAME is non-nil, +named layer references include tp-name. +Returns nil when GROUP-NAME is not a parameterized group. +The public entry point delegating here is `tp-group-props-with-args'." + (when (tp-group-parameterized-p group-name) + (let* ((entry (cdr (assoc group-name tp-layer-groups))) + (arglist (car entry)) + (body-form (cadr entry)) + ;; Evaluate the body with all parameters bound - returns + ;; list of layer specs. + (layer-specs (cl-progv arglist args (eval body-form)))) + ;; Convert layer specs to property lists + (mapcar (lambda (spec) + (tp--group-spec-to-props spec include-tp-name)) + layer-specs)))) + (defun tp-group-props-with-arg (group-name arg &optional include-tp-name) "Return list of properties for parameterized group GROUP-NAME with ARG. Evaluates the body form with the argument bound to the parameter. +This is the single-argument convenience over +`tp-group-props-with-args' - note the one-character name difference - +equivalent to calling it with (list ARG). Each evaluated element may be a layer name symbol, a (LAYER-NAME ARG) reference, a named element (\"NAME\" . PLIST) / (\"NAME\" :props PLIST), or a raw property list (anonymous layer) as documented in `define-tps'. If INCLUDE-TP-NAME is non-nil, named layer references include tp-name. -Returns a list of property lists for each layer in the group." - (when-let ((entry (cdr (assoc group-name tp-layer-groups)))) - ;; entry is (ARGLIST BODY-FORM) - (let ((arglist (car entry)) - (body-form (cadr entry))) - (when arglist ; Only for parameterized groups - (let* ((arg-sym (car arglist)) - ;; Evaluate the body with the argument bound - returns list of layer specs - (layer-specs (eval `(let ((,arg-sym ',arg)) ,body-form)))) - ;; Convert layer specs to property lists - (mapcar (lambda (spec) - (tp--group-spec-to-props spec include-tp-name)) - layer-specs)))))) +Returns a list of property lists for each layer in the group. + +See also `tp-layer-props-with-arg' for the single-layer counterpart." + (tp--group-props-with-args group-name (list arg) include-tp-name)) + +(defun tp-group-props-with-args (group-name args &optional include-tp-name) + "Return list of properties for parameterized group GROUP-NAME with ARGS. +ARGS is a list of argument values bound positionally to the group's +parameters while the stored body form is evaluated - the public +multi-argument introspection path for groups defined by `define-tps' +with two or more parameters (which `tp-put-layer' specs like +\(GROUP-NAME ARG1 ARG2) consume). Each evaluated element is +converted exactly as `tp-group-props-with-arg' documents. If +INCLUDE-TP-NAME is non-nil, named layer references include tp-name. +Returns nil when GROUP-NAME is not a parameterized group. + +This mirrors `tp-layer-props-with-args' for layers. See also +`tp-group-props-with-arg' - note the one-character name difference - +for the single-argument convenience." + (tp--group-props-with-args group-name args include-tp-name)) + +(defun tp--group-props-for-arg-value (group-name value &optional include-tp-name) + "Return props list for parameterized GROUP-NAME given a stored VALUE. +When GROUP-NAME takes more than one parameter and VALUE is a proper +list, VALUE is treated as the full argument list (as stored by the +plist-style spec (GROUP-NAME (ARG1 ARG2 ...))); otherwise VALUE is +the single argument (the single-parameter behavior). +INCLUDE-TP-NAME is passed through." + (if (and (proper-list-p value) + (> (length (tp--group-arglist group-name)) 1)) + (tp--group-props-with-args group-name value include-tp-name) + (tp-group-props-with-arg group-name value include-tp-name))) (defun tp--is-layer-name-p (sym) "Return non-nil if SYM is a defined layer, parameterized layer, or group name." @@ -960,15 +1111,18 @@ Returns the expanded plist." ((tp--is-layer-name-p key) (let ((layer-props (cond - ;; Parameterized layer - evaluate with the argument (val) + ;; Parameterized layer - evaluate with the argument (val); + ;; for multi-parameter layers a list VAL carries all args ((tp-layer-parameterized-p key) - (tp-layer-props-with-arg key val nil)) ; no tp-name + (tp--layer-props-for-arg-value key val nil)) ; no tp-name ;; Non-parameterized layer - val should be t ((assoc key tp-layer-alist) (tp-layer-props key nil)) ; no tp-name - ;; Parameterized layer group - evaluate with the argument (val) + ;; Parameterized layer group - evaluate with the argument (val); + ;; for multi-parameter groups a list VAL carries all args ((tp-group-parameterized-p key) - (when-let ((layer-props-list (tp-group-props-with-arg key val t))) + (when-let ((layer-props-list + (tp--group-props-for-arg-value key val t))) ;; Build layered structure: first layer at top, rest in tp-layers (tp--build-layer-props layer-props-list))) ;; Non-parameterized layer group - build layered structure @@ -991,15 +1145,34 @@ Returns the expanded plist." (tp--merge-duplicate-keys result) result))) +(defun tp--strip-trailing-plist-nil (plist) + "Remove a lone trailing nil from odd-length PLIST. +`tp--merge-duplicate-keys' pads an odd-length property spec (a flat +\(LAYER ARG1 ARG2 EXTRA-PROP VAL) call for a multi-parameter layer) +with a trailing nil value; strip it so the extra properties form a +proper plist again." + (if (and plist + (cl-oddp (length plist)) + (null (car (last plist)))) + (butlast plist) + plist)) + (defun tp--resolve-props (props) "Resolve PROPS to a property list with layer metadata. PROPS can be: -- A symbol (layer name from `tp-layer-alist' or group name from `tp-layer-groups') +- A symbol (layer name from `tp-layer-alist' or group name from + `tp-layer-groups') - A two-element list (LAYER-NAME ARG) where LAYER-NAME is a defined layer and ARG is either `t' for non-parameterized layers or the argument value for parameterized layers - A list starting with (LAYER-NAME ARG EXTRA-PROPS...) where extra properties are merged with the layer properties +- For multi-parameter layers/groups, (LAYER-NAME ARG1 ARG2 ... + EXTRA-PROPS...) binds as many leading elements as the layer has + parameters; alternatively (LAYER-NAME (ARG1 ARG2 ...) EXTRA-PROPS...) + passes all arguments as one list (recognized when the list's length + equals the layer's parameter count and the remaining elements form + an even-length plist) - A plist with layer names at any position - they will be expanded inline - A plist (handles anonymous layers with reactive variables) @@ -1009,8 +1182,10 @@ If PROPS is a symbol: If PROPS is (LAYER-NAME ARG) or (LAYER-NAME ARG EXTRA-PROPS...): - For non-parameterized layers: if ARG is t, returns the layer properties -- For parameterized layers: evaluates the body with ARG and returns the result -- Extra properties after ARG are appended to the layer properties +- For parameterized layers: evaluates the body with the argument(s) + and returns the result +- Extra properties after the argument(s) are appended to the layer + properties If PROPS is a plist with layer names at any position: - Layer names are expanded inline with their properties @@ -1018,8 +1193,10 @@ If PROPS is a plist with layer names at any position: If PROPS is a plist: - If it contains reactive variables ($...), generates a UUID for `tp-name', - registers reactive dependencies, and returns the resolved props with `tp-name'. - If the plist already has a `tp-name', uses that instead of generating a new one. + registers reactive dependencies, and returns the resolved props + with `tp-name'. + If the plist already has a `tp-name', uses that instead of + generating a new one. - If no reactive variables, returns props as-is (no tp-name added). Returns nil if PROPS is a symbol but no matching layer/group is found. @@ -1030,32 +1207,70 @@ For group names, includes `tp-layers' property with the full layer stack." ;; Already a plist - check for reactive variables and add tp-name ((listp props) (let ((first-elem (car-safe props)) - (second-elem (cadr props)) - (extra-props (cddr props))) + (second-elem (cadr props))) (cond ;; Handle (layer-name arg ...) format for defined layers at the START ;; This includes both (layer-name arg) and (layer-name arg extra-prop val ...) ((and (>= (length props) 2) (tp--is-layer-name-p first-elem)) - (let ((layer-props - (cond - ;; Parameterized layer - evaluate with the argument - ((tp-layer-parameterized-p first-elem) - (tp-layer-props-with-arg first-elem second-elem nil)) ; no tp-name - ;; Non-parameterized layer - arg should be t, return the layer props - ;; (silently ignore non-t values for flexibility) - ((assoc first-elem tp-layer-alist) - (tp-layer-props first-elem nil)) ; no tp-name - ;; Parameterized layer group - evaluate with the argument - ((tp-group-parameterized-p first-elem) - (when-let ((layer-props-list (tp-group-props-with-arg first-elem second-elem t))) - ;; Build layered structure: first layer at top, rest in tp-layers - (tp--build-layer-props layer-props-list))) - ;; Non-parameterized layer group - build layered structure - ((assoc first-elem tp-layer-groups) - (when-let ((layer-props-list (tp-group-props first-elem t))) - ;; Build layered structure: first layer at top, rest in tp-layers - (tp--build-layer-props layer-props-list)))))) + (let* ((arity (cond ((tp-layer-parameterized-p first-elem) + (length (tp-layer-arglist first-elem))) + ((tp-group-parameterized-p first-elem) + (length (tp--group-arglist first-elem))) + ;; Non-parameterized: one slot is consumed + ;; by the conventional `t' argument. + (t 1))) + ;; Plist-style multi-arg spec (LAYER (ARG1 ... ARGN) + ;; EXTRA...): the element after the name carries all + ;; arguments when it is a list of exactly ARITY values + ;; and the remaining elements form an even-length plist. + (wrapped-args (and (> arity 1) + (proper-list-p second-elem) + (= (length second-elem) arity) + (cl-evenp (length (cddr props))))) + (args (if wrapped-args + second-elem + (-take arity (cdr props)))) + (extra-props (if wrapped-args + (cddr props) + (tp--strip-trailing-plist-nil + (-drop arity (cdr props))))) + ;; ARG-1: wrong-arity parameterized calls must signal + ;; clearly instead of nil-binding missing parameters or + ;; applying excess positional args as garbage property + ;; keys. + (kind (cond ((tp-layer-parameterized-p first-elem) "layer") + ((tp-group-parameterized-p first-elem) "group"))) + (_arity-check + (when kind + (when (< (length args) arity) + (error "tp %s %s takes %d argument(s), got %d" + kind first-elem arity (length args))) + (when (and (not wrapped-args) + extra-props + (not (symbolp (car extra-props)))) + (error "tp %s %s takes %d argument(s); excess argument %S is not a property key" + kind first-elem arity (car extra-props))))) + (layer-props + (cond + ;; Parameterized layer - evaluate with the argument(s) + ((tp-layer-parameterized-p first-elem) + (tp-layer-props-with-args first-elem args nil)) ; no tp-name + ;; Non-parameterized layer - arg should be t, return the layer props + ;; (silently ignore non-t values for flexibility) + ((assoc first-elem tp-layer-alist) + (tp-layer-props first-elem nil)) ; no tp-name + ;; Parameterized layer group - evaluate with the argument(s) + ((tp-group-parameterized-p first-elem) + (when-let ((layer-props-list + (tp--group-props-with-args first-elem args t))) + ;; Build layered structure: first layer at top, rest in tp-layers + (tp--build-layer-props layer-props-list))) + ;; Non-parameterized layer group - build layered structure + ((assoc first-elem tp-layer-groups) + (when-let ((layer-props-list (tp-group-props first-elem t))) + ;; Build layered structure: first layer at top, rest in tp-layers + (tp--build-layer-props layer-props-list)))))) ;; Recursively resolve extra properties (they may also contain layer names) (let ((expanded-props (if (and layer-props extra-props) @@ -1157,13 +1372,15 @@ For group names, includes `tp-layers' property with the full layer stack." (t nil))) (defun tp--ensure-props (plist) - "Ensure PLIST is a property list, resolving layer names and handling reactive vars. + "Ensure PLIST is a property list, resolving layer names and +handling reactive vars. If PLIST is a symbol, resolve it via `tp--resolve-props'. If PLIST is a plist, also process it via `tp--resolve-props' to handle anonymous reactive layers. If resolution fails, return PLIST unchanged (for backward compatibility)." (or (tp--resolve-props plist) plist)) +;;;###autoload (defun tp-layer-reset () "Reset all layer definitions. Clears both `tp-layer-alist' and `tp-layer-groups'. @@ -1204,8 +1421,11 @@ untouched." Used by layer stack functions that need tp-name for identification. LAYER-SPEC can be: -- A symbol (non-parameterized layer name from define-tp or tp--define-layer-internal) -- A list (LAYER-NAME ARG) for parameterized layers from define-tp +- A symbol (non-parameterized layer name from define-tp or + tp--define-layer-internal) +- A list (LAYER-NAME ARG ...) for parameterized layers from + define-tp, with exactly as many arguments as the layer has + parameters - A plist for inline layer definition - A list (NAME &rest PLIST) for named inline layer" (cond @@ -1229,12 +1449,20 @@ LAYER-SPEC can be: (let ((name (car layer-spec)) (rest (cdr layer-spec))) (cond - ;; Parameterized layer: (LAYER-NAME ARG) + ;; Parameterized layer: (LAYER-NAME ARG ...) with exactly as + ;; many arguments as the layer has parameters ((and (tp-layer-parameterized-p name) - (= (length rest) 1)) - (or (tp-layer-props-with-arg name (car rest) t) ; include tp-name - (error "Failed to resolve parameterized layer %S with arg %S" - name (car rest)))) + (= (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))) + ;; ARG-1: a parameterized layer with the wrong number of + ;; arguments must not fall through to the named-inline branch, + ;; which would build an odd-length plist and die with the + ;; cryptic "Odd length text property list". + ((tp-layer-parameterized-p name) + (error "tp layer %s expects %d args, got %d" + name (length (tp-layer-arglist name)) (length rest))) ;; Named inline layer: (NAME &rest PLIST) (rest (append rest (list 'tp-name name))) @@ -1274,6 +1502,163 @@ First element is top layer, rest are in tp-layers." (cons top belows) belows)) +;;; Layer stack storage codec +;; +;; The encoding/decoding of a layer stack into raw text properties +;; lives here, beside `tp--build-layer-props' / `tp--layer-stack-to-list', +;; so both the stack operations (tp-stack.el) and the reactive +;; re-render engine (tp-render.el) can read and write stack storage +;; without duplicating format knowledge or requiring each other. + +(defun tp--stack-hidden-p (layer) + "Return non-nil when the layer plist LAYER is flagged hidden. +A layer is hidden when its plist carries a non-nil `tp-hidden' entry; +see `tp-hide-layer'." + (and (plist-get layer 'tp-hidden) t)) + +(defun tp--stack-props-to-list (props) + "Return the ordered layer stack stored in raw text properties PROPS. +The result is a list of layer plists, top layer first, including +hidden layers (flagged with a non-nil `tp-hidden' entry) at their +stack position. Returns nil for bare text. + +This is the inverse of `tp--stack-build-props': when any entry of the +`tp-layers' bookkeeping property is hidden, that property holds the +whole ordered stack and the direct properties are only a render cache +of the topmost non-hidden layer; otherwise the direct properties are +the top layer and `tp-layers' holds the layers below it. 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." + (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 + (tp--layer-stack-to-list top belows)))) + +(defun tp--stack-build-props (layer-list) + "Build text properties from LAYER-LIST (top layer first). +Like `tp--build-layer-props', but the `tp-layers' entry is only added +when there are below-layers, so single-layer stacks do not carry a +garbage (tp-layers nil) property. Consumers must therefore tolerate +an absent `tp-layers' property (both `plist-get' and +`tp--stack-map-region' do). + +When any layer in LAYER-LIST is hidden (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." + (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) + (list 'tp-layers layer-list))) + ((null (cdr layer-list)) (copy-sequence (car layer-list))) + (t (append (car layer-list) + (list 'tp-layers (cdr layer-list)))))) + +(defun tp--describe-layer-data (name) + "Collect description data for layer NAME as a plist. +Returns nil when NAME is not registered in `tp-layer-alist'. +The returned plist has these keys: +:name NAME itself. +:format Storage format: `parameterized' (unified storage with + a non-empty arglist), `reactive' (flat storage with + reactive dependencies registered), `unified' (from + `define-tp' with an empty arglist) or `flat' (old + direct plist storage). +:arglist The parameter list for parameterized layers, else nil. +:body The raw stored body: the unevaluated BODY-FORM for + unified/parameterized layers, the stored plist for + flat/reactive layers. +:props The expanded properties from `tp-layer-props' (with + tp-name), or a placeholder string for parameterized + layers, which need arguments + \(see `tp-layer-props-with-args'). +:reactive-deps List of reactive variable symbols NAME depends on, + from tp-reactive's `tp-reactive-deps' registry. +:transform Non-nil when a transform is registered for NAME in + `tp-layer-transforms'. +:group The group that generated NAME (from + `tp--group-generated-layers'), or nil." + (when-let ((entry (cdr (assoc name tp-layer-alist)))) + (let* ((parameterized (tp-layer-parameterized-p name)) + (reactive (tp--layer-has-reactive-deps-p name)) + (unified (and (= (length entry) 2) + (or (null (car entry)) + (and (listp (car entry)) + (cl-every #'symbolp (car entry)))))) + (format (cond (parameterized 'parameterized) + (reactive 'reactive) + (unified 'unified) + (t 'flat))) + (arglist (when parameterized (tp-layer-arglist name))) + (body (if unified (cadr entry) entry)) + (props (if parameterized + "parameterized layer: expand with `tp-layer-props-with-args'" + (tp-layer-props name t))) + (deps (cl-loop for dep in tp-reactive-deps + when (assoc name (cdr dep)) + collect (car dep))) + (transform (and (assoc name tp-layer-transforms) t)) + (group (cl-loop for (group-name . layers) + in tp--group-generated-layers + when (memq name layers) + return group-name))) + (list :name name + :format format + :arglist arglist + :body body + :props props + :reactive-deps deps + :transform transform + :group group)))) + +;;;###autoload +(defun tp-describe-layer (name) + "Display a help buffer describing the tp layer NAME. +NAME is a layer registered in `tp-layer-alist'. Interactively, +prompt with completion over the registered layers. +The buffer shows the storage format (flat, unified, parameterized or +reactive), the raw stored body, the expanded properties (or a +placeholder for parameterized layers, which need arguments), the +parameter list, the reactive variables the layer depends on, whether +a transform is registered, and the group that generated the layer, +if any." + (interactive + (list (intern (completing-read "Describe tp layer: " + (mapcar #'car tp-layer-alist) + nil t)))) + (let ((data (tp--describe-layer-data name))) + (unless data + (user-error "No tp layer named `%s'" name)) + (with-help-window (help-buffer) + (princ (format "%s is a tp layer.\n\n" name)) + (princ (format "Storage format: %s\n" (plist-get data :format))) + (when (plist-get data :arglist) + (princ (format "Arguments: %S\n" (plist-get data :arglist)))) + (princ (format "Stored body: %S\n" (plist-get data :body))) + (let ((props (plist-get data :props))) + (princ (format "Expanded props: %s\n" + (if (stringp props) props (format "%S" props))))) + (princ (format "Reactive deps: %s\n" + (if (plist-get data :reactive-deps) + (mapconcat #'symbol-name + (plist-get data :reactive-deps) ", ") + "none"))) + (princ (format "Transform: %s\n" + (if (plist-get data :transform) "yes" "no"))) + (when (plist-get data :group) + (princ (format "Generated by: group %s\n" + (plist-get data :group))))))) + (defun tp--get-layer-by-idx-or-name (layers idx-or-name) "Find layer in LAYERS by IDX-OR-NAME. Returns (index . layer-props) or nil." diff --git a/tp-ops.el b/tp-ops.el index bd0513c..02c6d7c 100644 --- a/tp-ops.el +++ b/tp-ops.el @@ -14,31 +14,236 @@ ;; The public property primitives: `tp-set', `tp-reset', `tp-add', ;; `tp-get', `tp-at', `tp-remove', `tp-clear', built on the shared ;; argument parser. Layer names in property specs are resolved through -;; tp-layer.el. The reactive `tp-text' property is handled through -;; `tp--tp-text-handler-function', installed by tp-render.el. +;; tp-layer.el. The reactive `tp-text' property is handled here by +;; `tp--handle-tp-text-property' and its helper chain; re-rendering on +;; later variable changes lives in tp-render.el, which calls back down +;; into these helpers. ;;; Code: (require 'cl-lib) (require 'dash) (require 'tp-core) +(require 'tp-reactive) (require 'tp-layer) -(defvar tp--tp-text-handler-function nil - "Function that handles the reactive `tp-text' property, or nil. -Installed by tp-render.el. Called with (START END PROPS OBJECT -PRESERVE-PROPS MERGE-MODE) and must return (PROPS NEW-END NEW-OBJECT). -When nil, `tp-text' is treated as an ordinary text property.") +(defun tp--find-tp-text-reactive-var (layer-name) + "Find the reactive variable symbol used for tp-text in LAYER-NAME. +Returns the variable symbol (e.g., tp-test-counter) if tp-text uses a +reactive variable (e.g., $tp-test-counter), or nil if not found. +Searches through `tp-reactive-deps' to find the original reactive props." + (catch 'found + (dolist (dep tp-reactive-deps) + (let* ((var-sym (car dep)) + (layer-entry (assoc layer-name (cdr dep)))) + (when layer-entry + (let ((reactive-props (cdr layer-entry))) + ;; Check if tp-text in reactive-props uses this variable + (when (plist-member reactive-props 'tp-text) + (let ((tp-text-val (plist-get reactive-props 'tp-text))) + ;; Check if tp-text-val is a reactive symbol for this variable + (when (and (tp--reactive-symbol-p tp-text-val) + (eq (tp--reactive-var-symbol tp-text-val) var-sym)) + (throw 'found var-sym)))))))) + nil)) -(defun tp--handle-tp-text (start end props object preserve-props merge-mode) - "Dispatch `tp-text' handling for PROPS between START and END in OBJECT. -PRESERVE-PROPS and MERGE-MODE are forwarded to the installed handler. -Returns (PROPS NEW-END NEW-OBJECT); a pass-through when no handler is -installed (see `tp--tp-text-handler-function')." - (if tp--tp-text-handler-function - (funcall tp--tp-text-handler-function - start end props object preserve-props merge-mode) - (list props end object))) +(defun tp--tp-text-transform (layer-name text) + "Return TEXT transformed by LAYER-NAME's `:transform', or TEXT. +Transform errors are reported and TEXT is returned unchanged; a +non-string transform result is ignored as well." + (let ((transform-fn (when layer-name + (cdr (assoc layer-name tp-layer-transforms))))) + (if (not transform-fn) + text + (condition-case err + (let ((result (funcall transform-fn text))) + (tp-debug-log " Transform %s: %S -> %S" layer-name text result) + (if (stringp result) result text)) + (error + (message "tp: transform error for %s: %s" layer-name err) + text))))) + +(defun tp--merge-embedded-props (embedded props) + "Merge the EMBEDDED string props plist under PROPS; PROPS win. +Like `tp--merge-string-props-into-plist' but takes the embedded plist +directly instead of sampling position 0 of a string, so callers can +merge per property interval. Face-family values (see +`tp-face-properties') are merged with PROPS taking precedence; other +conflicting keys keep the PROPS value; keys only in EMBEDDED are +added." + (let ((result (copy-sequence props))) + (cl-loop for (key val) on embedded by #'cddr + do (let ((existing (plist-get result key))) + (setq result + (plist-put result key + (if existing + (if (memq key tp-face-properties) + (tp--merge-face-values val existing) + existing) + val))))) + result)) + +(defun tp--put-text-property-unless-equal (start end key val object) + "Apply KEY -> VAL over [START, END) of OBJECT unless already there. +Like `put-text-property', but when every position of the span already +holds a value `equal' to VAL for KEY the call is skipped, so an +update that changes nothing does not flip the buffer-modified flag. +OBJECT is a string, a buffer, or nil for the current buffer." + (when (< start end) + (unless (and (equal (get-text-property start key object) val) + (>= (or (next-single-property-change start key object end) + end) + end)) + (put-text-property start end key val object)))) + +(defun tp--apply-reactive-text-props (source props offset &optional target) + "Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET. +SOURCE is the (possibly propertized) replacement string; TARGET is a +string, or nil for the current buffer. For every embedded-property +interval of SOURCE the interval's props are merged under PROPS (see +`tp--merge-embedded-props') and the result is applied to the +corresponding span of TARGET shifted by OFFSET. This keeps +per-interval styling of propertized reactive strings intact instead +of smearing position-0 props across the whole region. Spans that +already carry an `equal' value are left untouched, so an update that +changes nothing does not mark the buffer as modified." + (tp--map-intervals + source nil nil + (lambda (istart iend str-props) + (let ((merged (if str-props + (tp--merge-embedded-props str-props props) + props))) + (cl-loop for (key val) on merged by #'cddr + do (tp--put-text-property-unless-equal + (+ offset istart) (+ offset iend) key val target)))))) + +(defun tp--tp-text-replace (start end final-text result-props object preserve-props) + "Replace [START, END) of OBJECT with FINAL-TEXT, handling props. +Implements the text replacement of `tp--handle-tp-text-property' and +returns its (PROPS NEW-END NEW-OBJECT) result. + +For a string OBJECT a NEW string is built as prefix + FINAL-TEXT + +suffix, so text outside the region survives. RESULT-PROPS (merged +per embedded interval of FINAL-TEXT) are applied to the replaced span +here, because callers can only apply props from index 0, which would +smear them over the preserved prefix; the returned NEW-END is 0 so +the caller's own application over [0, NEW-END) is a no-op. + +For buffers the region text is replaced in place and the returned +NEW-END is the end of the inserted text; the caller applies +RESULT-PROPS itself. + +When PRESERVE-PROPS is non-nil, properties present at START whose +keys RESULT-PROPS does not set are re-applied over the replacement." + (if (stringp object) + (let* ((plain (substring-no-properties final-text)) + ;; Splice: keep the string outside [start, end) intact. + (new-string (concat (substring object 0 start) + plain + (substring object end))) + (new-end (+ start (length plain))) + (existing-props (when preserve-props + (text-properties-at start object)))) + ;; Preserve non-conflicting existing props of the replaced region + (cl-loop for (key val) on existing-props by #'cddr + do (unless (plist-member result-props key) + (put-text-property start new-end key val new-string))) + ;; Apply the merged props per embedded interval of FINAL-TEXT + (tp--apply-reactive-text-props final-text result-props start new-string) + (list result-props 0 new-string)) + ;; Buffer object + (with-current-buffer (or object (current-buffer)) + (let ((old-text (buffer-substring-no-properties start end))) + (if (equal old-text (substring-no-properties final-text)) + ;; Same text content, no replacement needed + (list result-props end object) + ;; Need to replace text + (let ((existing-props (when preserve-props + (text-properties-at start))) + (inhibit-read-only t)) + (save-excursion + (delete-region start end) + (goto-char start) + ;; Insert without properties - the caller applies RESULT-PROPS + (insert (substring-no-properties final-text))) + (let ((new-end (+ start (length final-text)))) + ;; Re-apply existing properties to new text region if preserving + (cl-loop for (key val) on existing-props by #'cddr + do (unless (plist-member result-props key) + (put-text-property start new-end key val object))) + (list result-props new-end object)))))))) + +(defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode) + "Handle tp-text property in PROPS for region from START to END in OBJECT. +If tp-text is nil, initialize it to the current text in the region; +when the layer has a `:transform', the displayed text is the +transformed value (matching later reactive updates) while the model - +the reactive variable and the `tp-text' property - keeps the raw text. +If tp-text is a string different from current text, replace the text. +When PRESERVE-PROPS is non-nil, existing text properties are preserved +on the replaced text (used by tp-set and tp-add). +MERGE-MODE is retained for backward compatibility but no longer +affects behavior. +All modes now preserve embedded text properties from tp-text, with props taking +precedence over embedded props when there's a conflict. +Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props, +NEW-END is the new end position after any text replacement, and +NEW-OBJECT is the new string object (only different for strings whose +text was replaced; see `tp--tp-text-replace' for the string-object +convention of a 0 NEW-END with pre-applied properties)." + (ignore merge-mode) + (if (not (plist-member props 'tp-text)) + ;; tp-text not in props - return unchanged + (list props end object) + (let ((tp-text-val (plist-get props 'tp-text)) + (layer-name (plist-get props 'tp-name))) + (cond + ;; tp-text is nil - initialize it to the current text + ((null tp-text-val) + (let ((current-text + (if (stringp object) + (substring-no-properties object start end) + (with-current-buffer (or object (current-buffer)) + (buffer-substring-no-properties start end))))) + ;; If tp-text uses a reactive variable, update that variable to match + ;; This ensures the reactive variable and buffer text stay in sync + (when layer-name + (when-let ((reactive-var (tp--find-tp-text-reactive-var layer-name))) + ;; Update the reactive variable with the current text + ;; Note: Using global `set` here because the layer definition is global. + ;; When the variable is changed, the reactive watcher will update all + ;; buffers that have this layer applied. + (set reactive-var current-text) + ;; Also update the layer definition so future accesses see the new value + (let ((layer-props (cdr (assoc layer-name tp-layer-alist)))) + (when layer-props + (tp--set-layer-props layer-name + (plist-put layer-props 'tp-text current-text)))))) + (setq props (plist-put props 'tp-text current-text)) + ;; Apply the layer's :transform to the DISPLAYED text on this first + ;; render too, so the initial rendering matches later reactive + ;; updates. The model value stays the raw text. + (let ((display-text (tp--tp-text-transform layer-name current-text))) + (if (equal display-text current-text) + (list props end object) + (tp--tp-text-replace + start end display-text + (tp--merge-string-props-into-plist display-text props) + object preserve-props))))) + ;; tp-text has a string value - replace the text in the region + ((stringp tp-text-val) + ;; Apply transform if layer has one registered + (let* ((final-text (tp--tp-text-transform layer-name tp-text-val)) + ;; Embedded text properties from tp-text are preserved in all + ;; cases. The props passed to this function take precedence + ;; over embedded props when there's a conflict (e.g. both have + ;; a `face' property). + (result-props + (tp--merge-string-props-into-plist final-text props))) + (tp--tp-text-replace start end final-text result-props + object preserve-props))) + ;; Other types - return unchanged + (t (list props end object)))))) (defun tp--parse-args (start-or-string end-or-prop props-or-val rest) "Parse flexible function arguments and return (OBJECT START END PROPS). @@ -48,7 +253,8 @@ Supports multiple calling conventions: 3. String region: (START END PROPS STRING) 4. Entire string with plist: (STRING PROP VAL ...) 5. Entire string with layer: (STRING LAYER-NAME ARG) -6. Entire string with layer and extra props: (STRING LAYER-NAME ARG PROP VAL ...)" +6. Entire string with layer and extra props: + (STRING LAYER-NAME ARG PROP VAL ...)" (let (object start finish props) (cond ;; First arg is a string - apply to entire string @@ -110,6 +316,18 @@ Supports multiple calling conventions: (setq props (or (tp--resolve-props props) props))) (list object start finish props))) +(defun tp--ops-register-layer-buffer (props object) + "Record OBJECT in the reactive buffer registry for PROPS's layer. +When PROPS carries a `tp-name' (a resolved layer application) and +OBJECT is a buffer or nil (the current buffer), register that buffer +under the layer's name so reactive updates can walk only registered +buffers instead of scanning `buffer-list'. String OBJECTs are not +registered; see `tp-reactive-layer-buffers' for that gap." + (when-let ((layer-name (plist-get props 'tp-name))) + (when (or (null object) (bufferp object)) + (tp-reactive--register-layer-buffer + layer-name (or object (current-buffer)))))) + (defun tp--apply-props-to-string (str start end props &optional merge-mode) "Apply PROPS to string STR from START to END, returning a NEW string. This function does not modify the original string. @@ -166,10 +384,14 @@ Returns a new propertized string." (defun tp-set (start-or-string &optional end-or-prop props-or-val &rest rest) "Set text properties on string or buffer region. -Supports four calling conventions: -1. (tp-set START END PROPS) - current buffer -2. (tp-set START END PROPS BUFFER/STRING) - specific object -3. (tp-set STRING PROP VAL ...) - entire string +Supports five calling conventions: +1. (tp-set START END PROPS) - region of the current buffer +2. (tp-set START END PROPS OBJECT) - region of a buffer or string +3. (tp-set STRING PROP VAL ...) - entire string, flat prop/value pairs +4. (tp-set STRING LAYER-NAME [ARG]) - entire string, a defined + layer/group, optionally with its argument +5. (tp-set STRING LAYER-NAME ARG PROP VAL ...) - entire string, a + parameterized layer/group plus extra flat properties PROPS can be a plist or a layer/group name symbol. Preserves existing properties not specified in PROPS. @@ -189,7 +411,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string." (tp--parse-args start-or-string end-or-prop props-or-val rest))) ;; Handle tp-text property specially - :override means props override embedded props (pcase-let ((`(,new-props ,new-finish ,new-object) - (tp--handle-tp-text start finish props object t :override))) + (tp--handle-tp-text-property start finish props object t :override))) (setq props new-props finish new-finish object new-object) (when (and (stringp object) (plist-member props 'tp-text)) (setq start 0))) @@ -214,12 +436,24 @@ Returns: For buffers, (START . END) cons. For strings, the result string." (set-text-properties start finish props object) (cl-loop for (key val) on props by #'cddr do (put-text-property start finish key val object)))) + (tp--ops-register-layer-buffer props object) (cons start finish)))))) (defun tp-reset (start-or-string &optional end-or-prop props-or-val &rest rest) "Completely replace all text properties with PROPS. Like `tp-set' but replaces ALL existing properties. -For tp-text, embedded text properties are preserved (props override if there's a conflict). + +Supports the same five calling conventions as `tp-set': +1. (tp-reset START END PROPS) - region of the current buffer +2. (tp-reset START END PROPS OBJECT) - region of a buffer or string +3. (tp-reset STRING PROP VAL ...) - entire string, flat pairs +4. (tp-reset STRING LAYER-NAME [ARG]) - entire string, defined + layer/group +5. (tp-reset STRING LAYER-NAME ARG PROP VAL ...) - layer plus extra + flat properties + +For tp-text, embedded text properties are preserved (props override +if there's a conflict). **String Modification Behavior:** - Entire string form (tp-reset STRING ...): Returns a NEW propertized string @@ -235,7 +469,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string." (tp--parse-args start-or-string end-or-prop props-or-val rest))) ;; Handle tp-text property - :reset means only use props, ignore embedded props (pcase-let ((`(,new-props ,new-finish ,new-object) - (tp--handle-tp-text start finish props object nil :reset))) + (tp--handle-tp-text-property start finish props object nil :reset))) (setq props new-props finish new-finish object new-object) (when (and (stringp object) (plist-member props 'tp-text)) (setq start 0))) @@ -250,11 +484,22 @@ Returns: For buffers, (START . END) cons. For strings, the result string." ;; Buffer: modify in place (t (set-text-properties start finish props object) + (tp--ops-register-layer-buffer props object) (cons start finish)))))) (defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest) "Add or update text properties with deep merging. Unlike `tp-set', deeply merges nested properties. + +Supports the same five calling conventions as `tp-set': +1. (tp-add START END PROPS) - region of the current buffer +2. (tp-add START END PROPS OBJECT) - region of a buffer or string +3. (tp-add STRING PROP VAL ...) - entire string, flat pairs +4. (tp-add STRING LAYER-NAME [ARG]) - entire string, defined + layer/group +5. (tp-add STRING LAYER-NAME ARG PROP VAL ...) - layer plus extra + flat properties + For face-family properties (see `tp-face-properties': face, font-lock-face, mouse-face), symbol faces are prepended to the existing face list and face plists are deep-merged. @@ -275,7 +520,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string." ;; Handle tp-text property - :merge means embedded props are merged with props (let ((has-tp-text (plist-member props 'tp-text))) (pcase-let ((`(,new-props ,new-finish ,new-object) - (tp--handle-tp-text start finish props object t :merge))) + (tp--handle-tp-text-property start finish props object t :merge))) (setq props new-props finish new-finish object new-object) (when (and (stringp object) has-tp-text) (setq start 0)))) @@ -329,6 +574,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string." (t val)))) (put-text-property pos next-pos key new-val object))) (setq pos next-pos)))) + (tp--ops-register-layer-buffer props object) (cons start finish)))))) (defun tp-get (start-or-string &optional end-or-property &rest args) @@ -600,11 +846,15 @@ If PROPERTY is a layer name, all properties added by that layer are removed." (next-pos (or (next-single-property-change pos 'tp-name object end) end))) (when (eq tp-name-at-pos property) ;; This region has the layer applied - get the layer's property keys - ;; For parameterized layers, we pass a dummy arg (t) since we only need key names + ;; For parameterized layers, we pass dummy args (t per + ;; parameter) since we only need key names (let* ((layer-props (cond ((tp-layer-parameterized-p property) - (tp-layer-props-with-arg property t nil)) ; arg=t, include-tp-name=nil + (tp-layer-props-with-args + property + (make-list (length (tp-layer-arglist property)) t) + nil)) ((assoc property tp-layer-alist) (tp-layer-props property nil)) ; include-tp-name=nil ((assoc property tp-layer-groups) @@ -898,7 +1148,8 @@ Returns a new plist (does not modify the original)." OBJECT is a string or buffer; nil means the current buffer. If START and END are not provided, they default to the whole of OBJECT: 0/(length OBJECT) for strings, `point-min'/`point-max' of -OBJECT for buffers (the current buffer when OBJECT is nil)." +OBJECT for buffers (the current buffer when OBJECT is nil). +Returns nil." (interactive) (let ((beg (or start (cond ((stringp object) 0) @@ -910,7 +1161,8 @@ OBJECT for buffers (the current buffer when OBJECT is nil)." ((bufferp object) (with-current-buffer object (point-max))) (t (point-max)))))) - (set-text-properties beg finish nil object))) + (set-text-properties beg finish nil object) + nil)) (provide 'tp-ops) ;;; tp-ops.el ends here diff --git a/tp-palette.el b/tp-palette.el index f31912d..e30412d 100644 --- a/tp-palette.el +++ b/tp-palette.el @@ -42,6 +42,15 @@ definition updates the stored palette in place." (declare (indent defun)) `(setf (alist-get ',name tp-palette-alist) '(,@plist))) +(defalias 'tp-define-palette 'define-tp-palette + "Register a color palette named NAME; alias of `define-tp-palette'. +This is the package-prefix-conforming name for the palette +definition macro, so it is discoverable via the tp- prefix; +`define-tp-palette' is the historical name and both are permanent - +neither will be removed. See `define-tp-palette' for the full +documentation of NAME and PLIST.") +(function-put 'tp-define-palette 'lisp-indent-function 'defun) + (define-tp-palette button-primary :fg ("#ffffff" . "#ffffff") :bg ("#007bff" . "#007bff")) @@ -245,9 +254,11 @@ definition updates the stored palette in place." ;;; Utilities (defun tp-theme-dark-p () + "Return non-nil when the current frame's background mode is dark." (eq (frame-parameter nil 'background-mode) 'dark)) (defun tp-theme-light-p () + "Return non-nil when the current frame's background mode is light." (eq (frame-parameter nil 'background-mode) 'light)) (defun tp-parse-color (color) @@ -284,11 +295,49 @@ back to the light color." "Get color value for KEY from the palette named SYMBOL. SYMBOL is looked up in `tp-palette-alist'. KEY should be one of :fg, :bg, or :border. Return nil if SYMBOL names no registered -palette or its definition doesn't contain KEY." +palette or its definition doesn't contain KEY. +The public entry point delegating here is `tp-palette-color'." (let ((plist (alist-get symbol tp-palette-alist))) (when (tp-palette--plistp plist) (tp-parse-color (plist-get plist key))))) +(defun tp-palette-color (symbol key) + "Return the KEY color of the palette named SYMBOL, theme-resolved. +SYMBOL is looked up in `tp-palette-alist'; KEY is one of :fg, :bg or +:border. The stored color spec is resolved for the current theme by +`tp-parse-color', so a (LIGHT . DARK) cons yields the side matching +the frame's background mode. Returns nil when SYMBOL names no +registered palette, its definition has no KEY entry, or the entry +resolves to no color for the current theme. + +This is the generic palette accessor; `tp-palette-fg-color', +`tp-palette-bg-color' and `tp-palette-border-color' are per-key +conveniences equivalent to calling it with a fixed KEY. See also +`tp-palette-has-p' to test for a palette or key without resolving a +color." + (tp-palette--get-color symbol key)) + +(defun tp-palette-has-p (symbol &optional kind) + "Return non-nil when SYMBOL names a palette that defines KIND. +With nil KIND, test only that SYMBOL names a palette registered in +`tp-palette-alist' (like `tp-palette-p'). Otherwise KIND is one of +:fg, :bg or :border, and the palette's definition must contain that +key. A defined key may still resolve to no color for the current +theme (for example a (LIGHT . nil) cons in dark mode); use +`tp-palette-color' when the resolved color itself matters. + +Note that the suffix predicates `tp-palette-fg-p', `tp-palette-bg-p', +`tp-palette-fbg-p' and `tp-palette-border-p' answer a different +question: whether SYMBOL is a suffixed variant name like `info-fg' +naming a registered palette (the `tp-palette' layer's convention). +This predicate takes the palette name itself." + (let ((entry (assoc symbol tp-palette-alist))) + (cond ((null entry) nil) + ((null kind) t) + (t (and (tp-palette--plistp (cdr entry)) + (plist-member (cdr entry) kind) + t))))) + (defun tp-palette-fg-color (symbol) "Get the foreground color from palette SYMBOL. SYMBOL should be a symbol bound to a palette plist with a :fg key. @@ -308,33 +357,52 @@ Returns nil if SYMBOL is unbound or doesn't contain :border." (tp-palette--get-color symbol :border)) (defun tp-palette-p (symbol) + "Return non-nil when SYMBOL names a registered palette. +The value is SYMBOL's entry in `tp-palette-alist'. See also the +generalized `tp-palette-has-p'." (assoc symbol tp-palette-alist)) (defun tp-palette-fg-p (symbol) + "Return non-nil when SYMBOL is a NAME-fg variant of a palette NAME. +Tests the suffixed naming convention of the `tp-palette' layer, not +the palette contents; see `tp-palette-has-p' for the latter." (save-match-data (let ((str (symbol-name symbol))) (and (string-match "\\(.+\\)-fg$" str) (tp-palette-p (intern (match-string 1 str))))))) (defun tp-palette-bg-p (symbol) + "Return non-nil when SYMBOL is a NAME-bg variant of a palette NAME. +Tests the suffixed naming convention of the `tp-palette' layer, not +the palette contents; see `tp-palette-has-p' for the latter." (save-match-data (let ((str (symbol-name symbol))) (and (string-match "\\(.+\\)-bg$" str) (tp-palette-p (intern (match-string 1 str))))))) (defun tp-palette-fbg-p (symbol) + "Return non-nil when SYMBOL is a NAME-fbg variant of a palette NAME. +Tests the suffixed naming convention of the `tp-palette' layer (fg +plus bg), not the palette contents." (save-match-data (let ((str (symbol-name symbol))) (and (string-match "\\(.+\\)-fbg$" str) (tp-palette-p (intern (match-string 1 str))))))) (defun tp-palette-border-p (symbol) + "Return non-nil when SYMBOL is a NAME-border variant of a palette NAME. +Tests the suffixed naming convention of the `tp-palette' layer, not +the palette contents; see `tp-palette-has-p' for the latter." (save-match-data (let ((str (symbol-name symbol))) (and (string-match "\\(.+\\)-border$" str) (tp-palette-p (intern (match-string 1 str))))))) (defun tp-palette-pure (symbol) + "Return the palette name behind SYMBOL, stripping variant suffixes. +SYMBOL may be a registered palette name or one of its -fg/-bg/-fbg/ +-border variants (see the `tp-palette' layer); signal an error for +anything else." (pcase symbol ((pred tp-palette-p) symbol) ((pred tp-palette-fg-p) diff --git a/tp-reactive.el b/tp-reactive.el index 6d865e8..5fe542a 100644 --- a/tp-reactive.el +++ b/tp-reactive.el @@ -13,9 +13,10 @@ ;; Reactive core of tp: storage for variable dependencies, watchers, ;; computed properties and data variables; registration/unregistration; -;; the variable-watcher shell and the batching queue. The actual -;; re-rendering of buffers lives in tp-render.el, which installs -;; itself via `tp--reactive-update-function' / `tp--reactive-flush-function'. +;; the variable-watcher shell and the batching queue state. The +;; actual re-rendering of buffers - including the queue flush and the +;; public `tp-with-batch-updates' macro - lives in tp-render.el, which +;; installs itself via `tp--reactive-update-function'. ;;; Code: @@ -40,6 +41,118 @@ Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).") Each entry is a list (LAYER-NAME CHANGED-SYMBOLS WHERE TP-TEXT-AFFECTED). Entries are created and widened by `tp--queue-batch-update'.") +(defvar tp--layer-buffers (make-hash-table :test 'equal) + "Hash table mapping layer names to buffers showing their regions. +Keys are layer names; values are lists of buffers registered via +`tp-reactive--register-layer-buffer'. Reactive updates walk only +these buffers instead of scanning `buffer-list' (see +`tp-reactive-layer-buffers'). A key holding an empty list means +\"known: no buffer shows this layer\", which is distinct from an +absent key (`unknown').") + +(defvar tp--layer-buffers-hook-installed nil + "Non-nil once the registry's `kill-buffer-hook' pruner is installed.") + +(defun tp-reactive--install-kill-buffer-hook () + "Install the global `kill-buffer-hook' pruning the buffer registry. +Idempotent; guarded by `tp--layer-buffers-hook-installed'." + (unless tp--layer-buffers-hook-installed + (add-hook 'kill-buffer-hook #'tp-reactive--prune-killed-buffer) + (setq tp--layer-buffers-hook-installed t))) + +(defun tp-reactive--prune-killed-buffer () + "Drop the buffer being killed from `tp--layer-buffers'. +Runs on `kill-buffer-hook' with the dying buffer current. The layer +entries themselves are kept: an entry left with an empty list means +\"known: no buffer shows this layer\", not `unknown'." + (let ((buf (current-buffer))) + (maphash (lambda (layer bufs) + (when (memq buf bufs) + (puthash layer (delq buf bufs) tp--layer-buffers))) + tp--layer-buffers))) + +(defun tp-reactive--register-layer-buffer (layer-name buffer) + "Register BUFFER as showing regions of layer LAYER-NAME. +Idempotent: registering the same live BUFFER again keeps a single +entry. Dead buffers and a nil LAYER-NAME are ignored. Installs the +`kill-buffer-hook' pruner on first use. See +`tp-reactive-layer-buffers' for the consumer side of the registry." + (when (and layer-name (buffer-live-p buffer)) + (tp-reactive--install-kill-buffer-hook) + (let ((bufs (gethash layer-name tp--layer-buffers))) + (unless (memq buffer bufs) + (puthash layer-name (cons buffer bufs) tp--layer-buffers))))) + +(defun tp-reactive-layer-buffers (layer-name) + "Return the live buffers registered as showing layer LAYER-NAME. +Return a list of live buffers - possibly empty, meaning \"known: no +buffer shows this layer\" - or the symbol `unknown' when LAYER-NAME +has no registry entry at all. Killed buffers still recorded in the +registry are dropped lazily by this accessor. + +KNOWN GAP: inserting an already-propertized STRING into a buffer +bypasses the buffer operations that register buffers, so such a +buffer is missing here until a reactive update's full-scan fallback +finds it or `tp-reactive-track-buffer' is called on it." + (let ((bufs (gethash layer-name tp--layer-buffers 'unknown))) + (if (eq bufs 'unknown) + 'unknown + (let ((live (cl-remove-if-not #'buffer-live-p bufs))) + (unless (= (length live) (length bufs)) + (puthash layer-name live tp--layer-buffers)) + live)))) + +(defun tp-reactive--buffer-layer-names (&optional buffer) + "Return the layer names present in BUFFER, in buffer order. +BUFFER defaults to the current buffer; a dead BUFFER yields nil. +Stack-aware: a layer counts as present when its name is the direct +`tp-name' text property of a run (the rendered top layer) or the +`tp-name' of any layer plist inside the run's `tp-layers' +stack-storage property (layers buried below the top, or hidden - see +tp-stack.el). The `tp-layers' value is read as a plain list of +plists, so this helper stays below the stack module. Names are +deduplicated with `equal'. This is the shared scan behind +`tp-reactive-track-buffer' and the anonymous-layer GC's liveness +test `tp--buffer-has-layer-region-p'." + (let ((buf (or buffer (current-buffer))) + (found nil)) + (when (buffer-live-p buf) + (tp--map-intervals + buf nil nil + (lambda (_start _end props) + (let ((direct (plist-get props 'tp-name))) + (when (and direct (not (member direct found))) + (push direct found))) + (dolist (layer (plist-get props 'tp-layers)) + (let ((name (plist-get layer 'tp-name))) + (when (and name (not (member name found))) + (push name found))))))) + (nreverse found))) + +;;;###autoload +(defun tp-reactive-track-buffer (&optional buffer) + "Scan BUFFER for layer regions and register it in the buffer registry. +BUFFER defaults to the current buffer. Walk BUFFER's text-property +runs and register BUFFER for every layer name found - rendered top +layers (direct `tp-name') as well as layers inside `tp-layers' stack +storage (buried below another layer, or hidden) - so reactive updates +visit it without a full `buffer-list' scan. + +Call this after inserting an already-propertized string into a +buffer: string application bypasses the buffer operations that +register buffers (see `tp-reactive-layer-buffers'), and this command +closes that gap. Return the list of layer names registered, in +buffer order." + (interactive) + (let* ((buf (or buffer (current-buffer))) + (found (tp-reactive--buffer-layer-names buf))) + (dolist (name found) + (tp-reactive--register-layer-buffer name buf)) + (when (called-interactively-p 'interactive) + (message "tp: tracking %d layer(s) in %s" + (length found) (buffer-name buf))) + found)) + (defvar tp--batch-update-active nil "When non-nil, we are inside a `tp-with-batch-updates' form.") @@ -122,7 +235,11 @@ Only the reactive portions of the properties are stored for each variable." ;; Also clean up layer watchers, computed properties, and data (tp--unregister-layer-watchers layer-name) (tp--unregister-layer-computed layer-name) - (tp--unregister-layer-data layer-name)) + (tp--unregister-layer-data layer-name) + ;; Drop the layer's buffer-registry entry: an undefined (or about to + ;; be redefined) layer must not linger as stale "known" state; the + ;; next update or refresh falls back to a learning full scan. + (remhash layer-name tp--layer-buffers)) (defun tp--layer-has-reactive-deps-p (layer-name) "Return non-nil if LAYER-NAME has reactive dependencies registered. @@ -138,11 +255,6 @@ SYMBOL NEWVAL WHERE OVERRIDE-ALIST) after the user watch callbacks have run. When nil, variable changes only invoke watch callbacks and no re-rendering happens.") -(defvar tp--reactive-flush-function nil - "Function flushing one pending batched update entry. -Installed by tp-render.el. Called with (LAYER-NAME WHERE -TP-TEXT-AFFECTED).") - (defun tp--reactive-variable-watcher (symbol newval operation where) "Watcher function called when a reactive variable changes. SYMBOL is the variable that changed. @@ -153,10 +265,10 @@ WHERE indicates where the variable was set: - a buffer for `setq-local' Updates all layers that depend on this variable. -Only 'set' operations trigger updates because: -- 'let'/'unlet': Temporary bindings that will be restored, no need to update UI -- 'makunbound': Variable is being undefined, not a value change -- 'defvaralias': Aliasing, the actual value change will trigger a separate 'set' +Only `set' operations trigger updates because: +- `let'/`unlet': Temporary bindings that will be restored, no need to update UI +- `makunbound': Variable is being undefined, not a value change +- `defvaralias': Aliasing, the actual value change will trigger a separate `set' When `tp--batch-update-active' is non-nil, buffer updates are deferred until the batch completes. Layer definitions are still updated immediately. @@ -205,48 +317,6 @@ NEWVAL is the new value, OLDVAL is the old value." (error (message "tp: watcher error for %s watching %s: %s" layer-name watch-sym err)))))))) -(defun tp--flush-batch-updates () - "Flush all pending batch updates. -This processes all updates collected during a `tp-with-batch-updates' form." - (tp-debug-log "Flushing %d pending batch updates" (length tp--batch-update-pending)) - (let ((processed-layers nil)) - ;; Process each pending update, avoiding duplicate layer updates - (dolist (pending (nreverse tp--batch-update-pending)) - (let ((layer-name (car pending)) - (where (caddr pending)) - (tp-text-affected (cadddr pending))) - (unless (memq layer-name processed-layers) - (push layer-name processed-layers) - (tp-debug-log " Batch updating layer %s (tp-text: %s)" - layer-name (if tp-text-affected "yes" "no")) - (when tp--reactive-flush-function - (funcall tp--reactive-flush-function - layer-name where tp-text-affected)))))) - (setq tp--batch-update-pending nil)) - -(defmacro tp-with-batch-updates (&rest body) - "Execute BODY with reactive updates batched. -Multiple variable changes within BODY are collected and applied -together at the end, avoiding redundant buffer modifications. - -This is useful when changing multiple reactive variables simultaneously: - - (tp-with-batch-updates - (setq my-color \"red\") - (setq my-size 14) - (setq my-text \"Hello\")) - -Without batching, each `setq' would trigger a separate buffer update. -With batching, all updates are consolidated and applied once at the end." - (declare (indent 0) (debug t)) - `(let ((tp--batch-update-active t) - (tp--batch-update-pending nil)) - (tp-debug-log "Starting batch updates") - (unwind-protect - (progn ,@body) - (tp-debug-log "Ending batch updates") - (tp--flush-batch-updates)))) - (defun tp--register-layer-watchers (layer-name watchers) "Register WATCHERS for LAYER-NAME. WATCHERS is a list of (VAR-SYMBOL CALLBACK) pairs." @@ -335,9 +405,10 @@ Also adds variable watchers so changes to data vars trigger computed updates." (defun tp--ensure-reactive-variables (var-symbols) "Ensure all VAR-SYMBOLS are defined as global variables. VAR-SYMBOLS can be a list of symbols or cons cells (SYMBOL . INITIAL-VALUE). -If a variable is not bound, define it with the initial value (nil if not specified). -If a variable has an explicit initial value (cons cell), always update it to allow -re-definition to change initial values." +If a variable is not bound, define it with the initial value (nil if +not specified). +If a variable has an explicit initial value (cons cell), always update +it to allow re-definition to change initial values." (dolist (sym var-symbols) (let* ((is-cons (and (consp sym) (not (tp--reactive-symbol-p sym)))) (var-sym (cond @@ -353,6 +424,7 @@ re-definition to change initial values." (unless (boundp var-sym) (set var-sym initial-val)))))) +;;;###autoload (defun tp-reactive-reset () "Reset all reactive text property watchers and dependencies." (interactive) @@ -364,7 +436,12 @@ re-definition to change initial values." (setq tp-reactive-deps nil) (setq tp-layer-watchers nil) (setq tp-layer-computed nil) - (setq tp-layer-data nil)) + (setq tp-layer-data nil) + ;; Drop queued re-renders too: entries stranded by an error escaping + ;; an update would otherwise survive the reset and replay against + ;; freshly (re)defined layers on the next flush (ARCH-4). + (setq tp--batch-update-pending nil) + (clrhash tp--layer-buffers)) (provide 'tp-reactive) ;;; tp-reactive.el ends here diff --git a/tp-render-tests.el b/tp-render-tests.el index 21add29..210b3d6 100644 --- a/tp-render-tests.el +++ b/tp-render-tests.el @@ -34,6 +34,17 @@ (defvar tp-rt-b18-text nil) (defvar tp-rt-b19-amount nil) (defvar tp-rt-b19s-amount nil) +(defvar tp-rt-r1-color nil) +(defvar tp-rt-r1b-color nil) +(defvar tp-rt-r1c-color nil) +(defvar tp-rt-r1d-color nil) +(defvar tp-rt-r2-text nil) +(defvar tp-rt-r2m-text nil) +(defvar tp-rt-r2n-text nil) +(defvar tp-rt-r2s-text nil) +(defvar tp-rt-r3a-color nil) +(defvar tp-rt-r3b-color nil) +(defvar tp-rt-r3c-color nil) (defmacro tp-rt-with-cleanup (layers vars &rest body) "Run BODY, then undefine LAYERS and reset VARS to nil (teardown)." @@ -360,5 +371,523 @@ (should (equal (get-text-property 0 'tp-text result) "5.00")) (should (eq (get-text-property 0 'face result) 'bold))))) +;;; R1 (0.3.0): reactive buffer registry replaces the buffer-list scan + +(ert-deftest tp-render-test-registry-update-visits-only-registered () + "A reactive update walks only registered buffers, not `buffer-list'." + (tp-rt-with-cleanup (tp-rt-r1-layer) (tp-rt-r1-color) + (setq tp-rt-r1-color "red") + (define-tp tp-rt-r1-layer () '(face (:foreground $tp-rt-r1-color))) + (let ((buf-a (generate-new-buffer " tp-rt-r1-a")) + (buf-b (generate-new-buffer " tp-rt-r1-b")) + (visited nil)) + (unwind-protect + (progn + (with-current-buffer buf-a + (insert "Hello") + (tp-set 1 6 'tp-rt-r1-layer)) + (with-current-buffer buf-b (insert "Hello")) + ;; Applying through tp-ops registered the buffer + (should (equal (tp-reactive-layer-buffers 'tp-rt-r1-layer) + (list buf-a))) + ;; Count per-buffer visits of the update walk + (let ((orig (symbol-function 'tp--render-visit-buffer))) + (cl-letf (((symbol-function 'tp--render-visit-buffer) + (lambda (buf fn) + (push buf visited) + (funcall orig buf fn)))) + (setq tp-rt-r1-color "blue"))) + ;; Only the registered buffer was visited + (should (equal visited (list buf-a))) + (with-current-buffer buf-a + (should (equal (plist-get (get-text-property 1 'face) + :foreground) + "blue")))) + (kill-buffer buf-a) + (kill-buffer buf-b))))) + +(ert-deftest tp-render-test-registry-prunes-on-kill-buffer () + "Killing a buffer removes it from the layer-buffer registry." + (tp-rt-with-cleanup (tp-rt-r1b-layer) (tp-rt-r1b-color) + (setq tp-rt-r1b-color "red") + (define-tp tp-rt-r1b-layer () '(face (:foreground $tp-rt-r1b-color))) + (let ((buf (generate-new-buffer " tp-rt-r1b"))) + (unwind-protect + (progn + (with-current-buffer buf + (insert "Hello") + (tp-set 1 6 'tp-rt-r1b-layer)) + (should (equal (tp-reactive-layer-buffers 'tp-rt-r1b-layer) + (list buf))) + (kill-buffer buf) + ;; The kill-buffer hook pruned the raw registry entry ... + (should-not (memq buf (gethash 'tp-rt-r1b-layer + tp--layer-buffers))) + ;; ... and the accessor answers "known: none", NOT `unknown'. + (should (null (tp-reactive-layer-buffers 'tp-rt-r1b-layer))) + (should-not (eq (tp-reactive-layer-buffers 'tp-rt-r1b-layer) + 'unknown))) + (when (buffer-live-p buf) (kill-buffer buf)))))) + +(ert-deftest tp-render-test-registry-unknown-full-scan-learns () + "An `unknown' layer falls back to a full scan and learns its buffers." + (tp-rt-with-cleanup (tp-rt-r1c-layer) (tp-rt-r1c-color) + (setq tp-rt-r1c-color "red") + (define-tp tp-rt-r1c-layer () '(face (:foreground $tp-rt-r1c-color))) + (let ((buf (generate-new-buffer " tp-rt-r1c"))) + (unwind-protect + (progn + (with-current-buffer buf + (insert "Hello") + (tp-set 1 6 'tp-rt-r1c-layer)) + ;; Simulate a buffer that got the layer outside the + ;; registering paths: erase the registry knowledge. + (remhash 'tp-rt-r1c-layer tp--layer-buffers) + (should (eq (tp-reactive-layer-buffers 'tp-rt-r1c-layer) + 'unknown)) + ;; The update still reaches the buffer (conservative fallback) + (setq tp-rt-r1c-color "blue") + (with-current-buffer buf + (should (equal (plist-get (get-text-property 1 'face) + :foreground) + "blue"))) + ;; ... and the scan registered the buffer it found (learning) + (should (equal (tp-reactive-layer-buffers 'tp-rt-r1c-layer) + (list buf)))) + (kill-buffer buf))))) + +(ert-deftest tp-render-test-track-buffer-closes-string-insert-gap () + "`tp-reactive-track-buffer' registers a buffer filled by string insert." + (tp-rt-with-cleanup (tp-rt-r1d-layer) (tp-rt-r1d-color) + (setq tp-rt-r1d-color "red") + (define-tp tp-rt-r1d-layer () '(face (:foreground $tp-rt-r1d-color))) + (let ((buf-a (generate-new-buffer " tp-rt-r1d-a")) + (buf-b (generate-new-buffer " tp-rt-r1d-b"))) + (unwind-protect + (progn + (with-current-buffer buf-a + (insert "Hello") + (tp-set 1 6 'tp-rt-r1d-layer)) + ;; Inserting an already-propertized STRING bypasses the + ;; registering buffer operations. + (let ((s (tp-set "Hi" 'tp-rt-r1d-layer))) + (with-current-buffer buf-b (insert s))) + (should-not (memq buf-b + (tp-reactive-layer-buffers 'tp-rt-r1d-layer))) + ;; The layer is known, so buf-b is NOT updated (the gap) ... + (setq tp-rt-r1d-color "blue") + (with-current-buffer buf-b + (should (equal (plist-get (get-text-property 1 'face) + :foreground) + "red"))) + ;; ... until tp-reactive-track-buffer closes it. + (should (equal (with-current-buffer buf-b + (tp-reactive-track-buffer)) + '(tp-rt-r1d-layer))) + (should (memq buf-b + (tp-reactive-layer-buffers 'tp-rt-r1d-layer))) + (setq tp-rt-r1d-color "green") + (with-current-buffer buf-b + (should (equal (plist-get (get-text-property 1 'face) + :foreground) + "green"))) + (with-current-buffer buf-a + (should (equal (plist-get (get-text-property 1 'face) + :foreground) + "green")))) + (kill-buffer buf-a) + (kill-buffer buf-b))))) + +;;; R2 (0.3.0): minimal-diff tp-text replacement + +(ert-deftest tp-render-test-minimal-diff-point-in-prefix-stays () + "Point in the common prefix survives a reactive text edit unmoved." + (tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text) + (setq tp-rt-r2-text "abcdef") + (define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text)) + (with-temp-buffer + (insert "abcdef") + (tp-set 1 7 'tp-rt-r2-layer) + (goto-char 2) ; inside the common prefix "ab" + (setq tp-rt-r2-text "abXYef") + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + "abXYef")) + (should (= (point) 2))))) + +(ert-deftest tp-render-test-minimal-diff-point-in-suffix-stays () + "Point in the common suffix stays glued to its character." + (tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text) + (setq tp-rt-r2-text "abcdef") + (define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text)) + (with-temp-buffer + (insert "abcdef") + (tp-set 1 7 'tp-rt-r2-layer) + (goto-char 6) ; on the "f" of the suffix "ef" + ;; Same-length edit: point must not move at all + (setq tp-rt-r2-text "abXYef") + (should (= (point) 6)) + (should (eq (char-after) ?f)) + ;; Length-changing edit: point stays glued to its character + (setq tp-rt-r2-text "abXYZWef") + (should (= (point) 8)) + (should (eq (char-after) ?f))))) + +(ert-deftest tp-render-test-minimal-diff-point-inside-diff-clamps () + "Point inside the differing span ends up at the edit start." + (tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text) + (setq tp-rt-r2-text "abcdef") + (define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text)) + (with-temp-buffer + (insert "abcdef") + (tp-set 1 7 'tp-rt-r2-layer) + (goto-char 4) ; on "d", inside the "cd" -> "XY" span + (setq tp-rt-r2-text "abXYef") + (should (= (point) 3))))) + +(ert-deftest tp-render-test-minimal-diff-markers-survive () + "Markers in the unchanged prefix and suffix survive a text update." + (tp-rt-with-cleanup (tp-rt-r2m-layer) (tp-rt-r2m-text) + (setq tp-rt-r2m-text "abcdef") + (define-tp tp-rt-r2m-layer () '(tp-text $tp-rt-r2m-text)) + (with-temp-buffer + (insert "abcdef") + (tp-set 1 7 'tp-rt-r2m-layer) + (let ((m-prefix (copy-marker 2)) ; on "b" + (m-suffix (copy-marker 6))) ; on "f" + (setq tp-rt-r2m-text "abXYZef") ; "cd" -> "XYZ", one char longer + (should (equal (buffer-substring-no-properties (point-min) + (point-max)) + "abXYZef")) + (should (= (marker-position m-prefix) 2)) + (should (eq (char-after m-prefix) ?b)) + (should (= (marker-position m-suffix) 7)) + (should (eq (char-after m-suffix) ?f)) + (set-marker m-prefix nil) + (set-marker m-suffix nil))))) + +;;; TXT-1: the suffix-boundary marker must track its character + +(defun tp-rt--txt1-marker-after-edit (old new marker-offset) + "Run a minimal-diff replacement of OLD by NEW with a boundary marker. +Insert \"HEAD \" OLD \" TAIL\" in a temp buffer, tag OLD with a +tp-name, put an insertion-type-nil marker at OLD's start plus +MARKER-OFFSET, replace via `tp--replace-reactive-text-in-buffer' and +return (MARKER-POSITION CHAR-AT-MARKER ORIGINAL-CHAR)." + (with-temp-buffer + (insert "HEAD ") + (let ((m-start (point))) + (insert old " TAIL") + (put-text-property m-start (+ m-start (length old)) + 'tp-name 'tp-rt-txt1-layer) + (let* ((mpos (+ m-start marker-offset)) + (mchar (char-after mpos)) + (mk (copy-marker mpos))) + (tp--replace-reactive-text-in-buffer 'tp-rt-txt1-layer new nil) + (prog1 (list (marker-position mk) (char-after mk) mchar) + (set-marker mk nil)))))) + +(ert-deftest tp-render-test-minimal-diff-suffix-start-marker-tracks () + "A marker on the FIRST character of the preserved suffix tracks it. +TXT-1: delete-then-insert collapsed such a marker onto the edit +start, stranding it before the inserted text; insert-then-delete +shifts it right with its character. Grow, same-length (the clearest +docstring violation) and shrink edits are all covered." + ;; Grow: "0" -> "42"; marker on the space before "items" (offset 8). + (pcase-let ((`(,pos ,got ,want) + (tp-rt--txt1-marker-after-edit + "count: 0 items" "count: 42 items" 8))) + (should (eq got want)) + (should (= pos 15))) ; 14 shifted right by 1 + ;; Same length: "0" -> "9"; the marker's correct position is + ;; numerically unchanged. + (pcase-let ((`(,pos ,got ,want) + (tp-rt--txt1-marker-after-edit + "count: 0 items" "count: 9 items" 8))) + (should (eq got want)) + (should (= pos 14))) + ;; Shrink: "42" -> "0". + (pcase-let ((`(,pos ,got ,want) + (tp-rt--txt1-marker-after-edit + "count: 42 items" "count: 0 items" 9))) + (should (eq got want)) + (should (= pos 14)))) + +(ert-deftest tp-render-test-minimal-diff-deleted-char-marker-at-edit-end () + "A marker whose character was deleted ends at the END of the edit. +The documented side effect of inserting before deleting; previously +such markers collapsed to the edit start. Either way they stay +inside the replacement span." + ;; "100" -> "42": marker on the middle "0" (strictly inside the + ;; edited span) ends after the inserted "42". + (pcase-let ((`(,pos ,_got ,_want) + (tp-rt--txt1-marker-after-edit + "count: 100 items" "count: 42 items" 8))) + ;; Edit span starts at buffer position 13 ("100"), insert "42": + ;; the marker lands at the end of the inserted text. + (should (= pos 15)))) + +(ert-deftest tp-render-test-minimal-diff-suffix-marker-real-path () + "The suffix-start marker tracks through a real setq-driven update." + (tp-rt-with-cleanup (tp-rt-r2s-layer) (tp-rt-r2s-text) + (setq tp-rt-r2s-text "count: 0 items") + (define-tp tp-rt-r2s-layer () '(tp-text $tp-rt-r2s-text)) + (with-temp-buffer + (insert "count: 0 items") + (tp-set 1 15 'tp-rt-r2s-layer) + (let ((m (copy-marker 9))) ; the space before "items" + (setq tp-rt-r2s-text "count: 42 items") + (should (equal (buffer-substring-no-properties (point-min) + (point-max)) + "count: 42 items")) + (should (eq (char-after m) ?\s)) + (should (= (marker-position m) 10)) + (set-marker m nil))))) + +(ert-deftest tp-render-test-minimal-diff-identical-update-is-noop () + "An identical-text reactive replacement leaves the buffer unmodified." + (tp-rt-with-cleanup (tp-rt-r2n-layer) (tp-rt-r2n-text) + (setq tp-rt-r2n-text "emacs") + (define-tp tp-rt-r2n-layer () '(face bold tp-text $tp-rt-r2n-text)) + (with-temp-buffer + (insert "emacs") + (tp-set 1 6 'tp-rt-r2n-layer) + (set-buffer-modified-p nil) + (save-excursion + (tp--replace-reactive-text-in-buffer + 'tp-rt-r2n-layer "emacs" (tp-layer-props 'tp-rt-r2n-layer t))) + ;; No text edit and no property churn: the flag must stay clear + (should-not (buffer-modified-p)) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + "emacs")) + (should (eq (get-text-property 1 'face) 'bold))))) + +;;; ARCH-4: the pending queue must survive neither reset nor errors + +(defvar tp-rt-a4-face nil) +(defvar tp-rt-a4-color nil) + +(ert-deftest tp-render-test-reactive-reset-clears-pending-queue () + "tp-reactive-reset drops queued batch re-renders (ARCH-4). +Stranded entries would otherwise survive the reset and replay against +freshly (re)defined layers on the next flush." + (unwind-protect + (progn + (tp--queue-batch-update 'tp-rt-a4-ghost 'tp-rt-a4-ghost-var nil nil) + (should tp--batch-update-pending) + (tp-reactive-reset) + (should (null tp--batch-update-pending))) + (setq tp--batch-update-pending nil))) + +(ert-deftest tp-render-test-error-escaping-update-flushes-nested-queue () + "An error escaping a re-render cannot strand nested queued updates. +A modification hook that writes a second reactive variable and then +signals used to strand the nested entry in the global queue - the +flush tail sat outside any unwind-protect. The flush now runs as the +update unwinds, so the nested variable's re-render still lands and +the queue is drained (ARCH-4)." + (setq tp-rt-a4-face 'bold + tp-rt-a4-color "red") + (unwind-protect + (progn + (define-tp tp-rt-a4-layer-a () '(face $tp-rt-a4-face)) + (define-tp tp-rt-a4-layer-b () + '(face (:foreground $tp-rt-a4-color))) + (with-temp-buffer + (insert "Hello world") + (tp-set 1 6 'tp-rt-a4-layer-a) + (tp-set 7 12 'tp-rt-a4-layer-b) + (let ((armed t)) + (add-hook 'before-change-functions + (lambda (_beg _end) + (when armed + (setq armed nil) + ;; Nested reactive write from within the + ;; re-render: goes to the global queue. + (setq tp-rt-a4-color "green") + (error "boom from modification hook"))) + nil t) + (should-error (setq tp-rt-a4-face 'italic)) + ;; The nested entry was flushed on the way out, not + ;; stranded... + (should (null tp--batch-update-pending)) + ;; ...and its re-render landed despite the error. + (should (equal (get-text-property 7 'face) + '(:foreground "green")))))) + (tp-undefine-layer 'tp-rt-a4-layer-a) + (tp-undefine-layer 'tp-rt-a4-layer-b) + (setq tp-rt-a4-face nil + tp-rt-a4-color nil + tp--batch-update-pending nil))) + +;;; R3 (0.3.0): anonymous-layer garbage collection + +(ert-deftest tp-render-test-gc-collects-unreferenced-anonymous-layer () + "GC collects an anonymous layer whose only buffer was killed." + (setq tp-rt-r3a-color "red") + (let ((buf (generate-new-buffer " tp-rt-r3a")) + (name nil)) + (unwind-protect + (progn + (with-current-buffer buf + (insert "Hello") + (tp-set 1 6 '(face (:foreground $tp-rt-r3a-color))) + (setq name (get-text-property 1 'tp-name))) + (should name) + (should (assoc name tp-layer-alist)) + (kill-buffer buf) + (should (memq name (tp-gc-anonymous-layers))) + (should-not (assoc name tp-layer-alist)) + (should-not (rassq name tp--anonymous-layer-registry))) + (when (buffer-live-p buf) (kill-buffer buf)) + (when (and name (assoc name tp-layer-alist)) + (tp-undefine-layer name)) + (setq tp-rt-r3a-color nil)))) + +(ert-deftest tp-render-test-gc-keeps-layer-still-displayed () + "GC keeps an anonymous layer that a live buffer still shows." + (setq tp-rt-r3b-color "red") + (let ((buf (generate-new-buffer " tp-rt-r3b")) + (name nil)) + (unwind-protect + (progn + (with-current-buffer buf + (insert "Hello") + (tp-set 1 6 '(face (:foreground $tp-rt-r3b-color))) + (setq name (get-text-property 1 'tp-name))) + (should name) + (should-not (memq name (tp-gc-anonymous-layers))) + (should (assoc name tp-layer-alist))) + (kill-buffer buf) + (when (and name (assoc name tp-layer-alist)) + (tp-undefine-layer name)) + (setq tp-rt-r3b-color nil)))) + +(ert-deftest tp-render-test-gc-keeps-unknown-registry-layer () + "GC keeps an anonymous layer whose registry state is `unknown'." + (setq tp-rt-r3c-color "red") + (let* ((s (tp-set "Hello" '(face (:foreground $tp-rt-r3c-color)))) + (name (get-text-property 0 'tp-name s))) + (unwind-protect + (progn + (should name) + ;; Applied to a string only: the registry knows nothing + (should (eq (tp-reactive-layer-buffers name) 'unknown)) + (should-not (memq name (tp-gc-anonymous-layers))) + (should (assoc name tp-layer-alist))) + (when (and name (assoc name tp-layer-alist)) + (tp-undefine-layer name)) + (setq tp-rt-r3c-color nil)))) + +;;; GC-1: buried and hidden layers are ALIVE for GC and track-buffer + +(defvar tp-rt-gc1-color nil) +(defvar tp-rt-gc1b-color nil) +(defvar tp-rt-gc1c-color nil) + +(ert-deftest tp-render-test-gc-keeps-layer-buried-under-push () + "GC keeps an anonymous layer buried below a pushed top layer. +The buried layer's tp-name lives inside `tp-layers' storage, not as a +direct property; the stack-aware liveness scan must still see it, and +reactivity must survive a later pop (GC-1)." + (setq tp-rt-gc1-color "blue") + (let ((buf (generate-new-buffer " tp-rt-gc1")) + (name nil)) + (unwind-protect + (progn + (define-tp tp-rt-gc1-top () '(face bold)) + (with-current-buffer buf + (insert "0123456789") + (tp-set 1 6 '(face (:foreground $tp-rt-gc1-color))) + (setq name (get-text-property 1 'tp-name)) + (should name) + (tp-push-layer 1 6 'tp-rt-gc1-top) + ;; Now buried: direct tp-name is the pushed top's. + (should (eq (get-text-property 1 'tp-name) 'tp-rt-gc1-top)) + ;; The buffer is live and still holds the layer: GC must + ;; keep it. + (should-not (memq name (tp-gc-anonymous-layers))) + (should (assoc name tp-layer-alist)) + ;; Reactivity survives: pop and update. + (tp-pop-layer 1 6) + (setq tp-rt-gc1-color "red") + (should (equal (get-text-property 1 'face) + '(:foreground "red"))))) + (kill-buffer buf) + (when (and name (assoc name tp-layer-alist)) + (tp-undefine-layer name)) + (tp-undefine-layer 'tp-rt-gc1-top) + (setq tp-rt-gc1-color nil)))) + +(ert-deftest tp-render-test-gc-keeps-hidden-layer () + "GC keeps an anonymous layer hidden via tp-hide-layer. +An all-hidden run carries no direct tp-name at all; the layer lives +only inside `tp-layers' storage yet is queryable and re-showable, so +GC must not collect it and show+setq must still re-render (GC-1, +XM-02)." + (setq tp-rt-gc1b-color "green") + (let ((buf (generate-new-buffer " tp-rt-gc1b")) + (name nil)) + (unwind-protect + (with-current-buffer buf + (insert "abcdefghij") + (tp-set 1 6 '(face (:foreground $tp-rt-gc1b-color))) + (setq name (get-text-property 1 'tp-name)) + (should name) + (tp-hide-layer 1 6 name) + (should-not (get-text-property 1 'tp-name)) + ;; Live buffer still holds the hidden layer: keep it. + (should-not (memq name (tp-gc-anonymous-layers))) + (should (assoc name tp-layer-alist)) + ;; Show and update: reactivity must be intact. + (tp-show-layer 1 6 name) + (setq tp-rt-gc1b-color "purple") + (should (equal (get-text-property 1 'face) + '(:foreground "purple")))) + (kill-buffer buf) + (when (and name (assoc name tp-layer-alist)) + (tp-undefine-layer name)) + (setq tp-rt-gc1b-color nil)))) + +(ert-deftest tp-render-test-track-buffer-finds-buried-and-hidden-layers () + "tp-reactive-track-buffer registers layers buried or hidden in storage. +A propertized string carrying a stacked (buried) layer and an +all-hidden string are inserted into a fresh buffer; the track scan +must register every layer name, not just the rendered top ones +\(GC-1, XM-04)." + (setq tp-rt-gc1c-color "gold") + (let ((buf (generate-new-buffer " tp-rt-gc1c")) + (name nil)) + (unwind-protect + (progn + (define-tp tp-rt-gc1c-top () '(face bold)) + (define-tp tp-rt-gc1c-hidden () '(face italic)) + (let ((s (with-temp-buffer + (insert "trackme") + (tp-set 1 6 '(face (:foreground $tp-rt-gc1c-color))) + (setq name (get-text-property 1 'tp-name)) + (tp-push-layer 1 6 'tp-rt-gc1c-top) + (buffer-string))) + (h (let ((h (copy-sequence " hideme"))) + (tp-push-layer h 'tp-rt-gc1c-hidden) + (tp-hide-layer h 'tp-rt-gc1c-hidden) + h))) + (with-current-buffer buf + (insert s) + (insert h) + (let ((found (tp-reactive-track-buffer))) + ;; Rendered top, buried layer, and all-hidden layer. + (should (memq 'tp-rt-gc1c-top found)) + (should (memq name found)) + (should (memq 'tp-rt-gc1c-hidden found))) + (should (memq buf (tp-reactive-layer-buffers name))) + (should (memq buf (tp-reactive-layer-buffers + 'tp-rt-gc1c-hidden)))))) + (kill-buffer buf) + (when (and name (assoc name tp-layer-alist)) + (tp-undefine-layer name)) + (tp-undefine-layer 'tp-rt-gc1c-top) + (tp-undefine-layer 'tp-rt-gc1c-hidden) + (setq tp-rt-gc1c-color nil)))) + (provide 'tp-render-tests) ;;; tp-render-tests.el ends here diff --git a/tp-render.el b/tp-render.el index 96c7c1f..5aeeb1f 100644 --- a/tp-render.el +++ b/tp-render.el @@ -13,9 +13,12 @@ ;; The reactive update engine: when a reactive variable changes, this ;; module recomputes layer definitions and re-renders every affected -;; buffer region, including live `tp-text' text replacement. It -;; installs itself into tp-reactive.el (update/flush hooks) and -;; tp-ops.el (`tp-text' handler). +;; buffer region, including live `tp-text' text replacement. It also +;; owns the batching flush and the public `tp-with-batch-updates' +;; macro (the queue state lives in tp-reactive.el). It installs +;; itself into tp-reactive.el (update hook) and tp-layer.el (layer +;; refresh hook), and calls down into tp-ops.el for the `tp-text' +;; helper chain. ;;; Code: @@ -102,6 +105,88 @@ Returns an updated override-alist with the new computed values." (tp--deep-merge-plist current-props resolved-props))))))))))) override-alist) +(defun tp--render-visit-buffer (buffer fn) + "Call FN with BUFFER current and `inhibit-read-only' bound to t. +Dead buffers are skipped. This is the per-buffer seam of the +reactive update walk; tests may advise it to count buffer visits." + (when (buffer-live-p buffer) + (tp-with-current-buffer buffer + (funcall fn)))) + +(defun tp--map-layer-buffers (layer-name where fn) + "Run FN in each buffer that may show LAYER-NAME's regions. +A non-nil WHERE (a live buffer, the `setq-local' case) restricts the +walk to that buffer. Otherwise the walk consults the buffer registry +via `tp-reactive-layer-buffers' and visits only registered live +buffers. When the registry answers `unknown', the walk falls back to +a full `buffer-list' scan, registering every buffer that actually +contains a region of LAYER-NAME; once at least one buffer is +registered the layer is known and later updates skip the full scan. +A layer found in no buffer at all deliberately stays `unknown', so a +later application through a path that does not register buffers is +still picked up by the next update's full scan." + (if (and where (bufferp where) (buffer-live-p where)) + (tp--render-visit-buffer where fn) + (let ((registered (tp-reactive-layer-buffers layer-name))) + (if (not (eq registered 'unknown)) + (dolist (buf registered) + (tp--render-visit-buffer buf fn)) + ;; Learning fallback: behave exactly like the historical full + ;; scan, but record which buffers actually carry the layer. + (dolist (buf (buffer-list)) + (when (buffer-live-p buf) + (when (tp--buffer-has-layer-region-p layer-name buf) + (tp-reactive--register-layer-buffer layer-name buf)) + (tp--render-visit-buffer buf fn))))))) + +(defun tp--merge-props-into-stack-entry (entry props) + "Return stack-storage plist ENTRY with its keys updated from PROPS. +Every key of PROPS except `tp-name' and `tp-layers' replaces ENTRY's +value for that key (or extends ENTRY when the key is new), so ENTRY's +`tp-hidden' flag and identity survive the update. Returns a fresh +plist; ENTRY itself is not modified." + (let ((new-entry (copy-sequence entry))) + (cl-loop for (key val) on props by #'cddr + unless (memq key '(tp-name tp-layers)) + do (setq new-entry (plist-put new-entry key val))) + new-entry)) + +(defun tp--write-layer-through-stack-storage (layer-name props) + "Write PROPS through to LAYER-NAME's entries in `tp-layers' storage. +A reactive re-render rewrites a layer's direct (rendered) properties, +but the same layer can also sit inside the `tp-layers' stack-storage +property of a run: buried below another layer, or hidden (see +`tp-hide-layer'), in which case the direct properties are only a +render cache and the stored entry is what the next stack operation +rebuilds from. For every run of the current buffer whose `tp-layers' +holds an entry whose `tp-name' equals LAYER-NAME, replace the layer's +own keys in that entry with their values from PROPS - preserving the +entry's `tp-hidden' flag and stack position - and rewrite the run via +`tp--stack-props-to-list' / `tp--stack-build-props', which also +refreshes the topmost-visible render cache in full-stack storage +mode. Runs already storing the current values are left untouched, so +an update that changes nothing does not mark the buffer as modified." + (let ((pos (point-min)) + (max (point-max))) + (while (< pos max) + (let ((next (or (next-property-change pos nil max) max)) + (stored (get-text-property pos 'tp-layers))) + (when (and stored + (cl-some (lambda (entry) + (equal (plist-get entry 'tp-name) layer-name)) + stored)) + (let* ((stack (tp--stack-props-to-list (text-properties-at pos))) + (new-stack + (mapcar (lambda (entry) + (if (equal (plist-get entry 'tp-name) layer-name) + (tp--merge-props-into-stack-entry entry props) + entry)) + stack))) + (unless (equal new-stack stack) + (set-text-properties pos next + (tp--stack-build-props new-stack))))) + (setq pos next))))) + (defun tp--update-layer-regions (layer-name &optional where override-alist) "Update text regions that have LAYER-NAME applied. Re-applies the layer's current properties to every region tagged with @@ -110,9 +195,18 @@ with their current values (so refresh is idempotent: a face variable changing from bold to italic yields italic, not (italic bold)), while properties contributed by other sources are left untouched. +The update also writes through to `tp-layers' stack storage (see +`tp--write-layer-through-stack-storage'): copies of the layer that +are hidden or buried below another layer are refreshed in place, so a +later stack operation or `tp-show-layer' renders current values +instead of a stale snapshot. + WHERE specifies which buffers to update: - If WHERE is a buffer, only update that buffer (setq-local case). - - If WHERE is nil, update all buffers that have the text property. + - If WHERE is nil, update the buffers registered for the layer in + the reactive buffer registry, falling back to one full + `buffer-list' scan when the registry has no knowledge of the + layer (see `tp--map-layer-buffers'). OVERRIDE-ALIST maps reactive variables to their new values when the watcher fires before the variables are set; layer props are @@ -131,91 +225,12 @@ variable values are honored." (cl-loop for (key val) on props by #'cddr do (put-text-property start end key val)) nil) - 'tp-name layer-name))))))) - (if (and where (bufferp where) (buffer-live-p where)) - ;; setq-local case: only update the specific buffer - (tp-with-current-buffer where - (funcall update-buffer)) - ;; setq case: update all buffers that have the text property - (dolist (buf (buffer-list)) - (when (buffer-live-p buf) - (tp-with-current-buffer buf - (funcall update-buffer))))))) - -(defun tp--find-tp-text-reactive-var (layer-name) - "Find the reactive variable symbol used for tp-text in LAYER-NAME. -Returns the variable symbol (e.g., tp-test-counter) if tp-text uses a -reactive variable (e.g., $tp-test-counter), or nil if not found. -Searches through `tp-reactive-deps' to find the original reactive props." - (catch 'found - (dolist (dep tp-reactive-deps) - (let* ((var-sym (car dep)) - (layer-entry (assoc layer-name (cdr dep)))) - (when layer-entry - (let ((reactive-props (cdr layer-entry))) - ;; Check if tp-text in reactive-props uses this variable - (when (plist-member reactive-props 'tp-text) - (let ((tp-text-val (plist-get reactive-props 'tp-text))) - ;; Check if tp-text-val is a reactive symbol for this variable - (when (and (tp--reactive-symbol-p tp-text-val) - (eq (tp--reactive-var-symbol tp-text-val) var-sym)) - (throw 'found var-sym)))))))) - nil)) - -(defun tp--tp-text-transform (layer-name text) - "Return TEXT transformed by LAYER-NAME's `:transform', or TEXT. -Transform errors are reported and TEXT is returned unchanged; a -non-string transform result is ignored as well." - (let ((transform-fn (when layer-name - (cdr (assoc layer-name tp-layer-transforms))))) - (if (not transform-fn) - text - (condition-case err - (let ((result (funcall transform-fn text))) - (tp-debug-log " Transform %s: %S -> %S" layer-name text result) - (if (stringp result) result text)) - (error - (message "tp: transform error for %s: %s" layer-name err) - text))))) - -(defun tp--merge-embedded-props (embedded props) - "Merge the EMBEDDED string props plist under PROPS; PROPS win. -Like `tp--merge-string-props-into-plist' but takes the embedded plist -directly instead of sampling position 0 of a string, so callers can -merge per property interval. Face-family values (see -`tp-face-properties') are merged with PROPS taking precedence; other -conflicting keys keep the PROPS value; keys only in EMBEDDED are -added." - (let ((result (copy-sequence props))) - (cl-loop for (key val) on embedded by #'cddr - do (let ((existing (plist-get result key))) - (setq result - (plist-put result key - (if existing - (if (memq key tp-face-properties) - (tp--merge-face-values val existing) - existing) - val))))) - result)) - -(defun tp--apply-reactive-text-props (source props offset &optional target) - "Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET. -SOURCE is the (possibly propertized) replacement string; TARGET is a -string, or nil for the current buffer. For every embedded-property -interval of SOURCE the interval's props are merged under PROPS (see -`tp--merge-embedded-props') and the result is applied to the -corresponding span of TARGET shifted by OFFSET. This keeps -per-interval styling of propertized reactive strings intact instead -of smearing position-0 props across the whole region." - (tp--map-intervals - source nil nil - (lambda (istart iend str-props) - (let ((merged (if str-props - (tp--merge-embedded-props str-props props) - props))) - (cl-loop for (key val) on merged by #'cddr - do (put-text-property (+ offset istart) (+ offset iend) - key val target)))))) + 'tp-name layer-name) + ;; Write through to stack storage so hidden or buried + ;; copies of the layer do not go stale (HID-1). + (tp--write-layer-through-stack-storage layer-name + props))))))) + (tp--map-layer-buffers layer-name where update-buffer))) (defun tp--update-reactive-text (layer-name &optional where override-alist) "Update text regions that have tp-text property with LAYER-NAME applied. @@ -223,7 +238,10 @@ This is called when a reactive variable bound to tp-text changes. WHERE specifies which buffers to update: - If WHERE is a buffer, only update that buffer (setq-local case). - - If WHERE is nil, update all buffers that have the text property (setq case). + - If WHERE is nil, update the buffers registered for the layer in + the reactive buffer registry, falling back to one full + `buffer-list' scan when the registry has no knowledge of the + layer (see `tp--map-layer-buffers'). OVERRIDE-ALIST maps reactive variables to their new values when the watcher fires before the variables are set; the layer's props are @@ -241,179 +259,172 @@ it will be applied to the text before updating." (tp--tp-text-transform layer-name raw-text) raw-text))) (when (and new-text (stringp new-text)) - (save-excursion - (tp--replace-reactive-text-in-buffer - layer-name new-text props))))))))) - (if (and where (bufferp where) (buffer-live-p where)) - ;; setq-local case: only update the specific buffer - (tp-with-current-buffer where - (funcall update-buffer)) - ;; setq case: update all buffers that have the text property - (dolist (buf (buffer-list)) - (when (buffer-live-p buf) - (tp-with-current-buffer buf - (funcall update-buffer))))))) + ;; No save-excursion here: the replace function + ;; owns point restoration (its clamping semantics + ;; would be overridden by save-excursion's own + ;; drifting marker). + (tp--replace-reactive-text-in-buffer + layer-name new-text props)))))))) + (tp--map-layer-buffers layer-name where update-buffer))) + +(defun tp--edit-region-minimal-diff (m-start m-end plain-text skip-props) + "Make [M-START, M-END) of the current buffer read PLAIN-TEXT. +Only the differing span of the region is edited: the common prefix +and suffix of the old and new text are left untouched. The +replacement is inserted BEFORE the old span is deleted, so markers +sitting in unchanged text keep tracking their characters - including +a marker at the first character of the preserved suffix, which the +old delete-then-insert order collapsed onto the edit start (TXT-1). +Markers whose characters were deleted end up at the end of the edit. +Does nothing when the region already reads PLAIN-TEXT, so an +identical-text update does not mark the buffer as modified. +Properties present at M-START whose keys the plist SKIP-PROPS does +not contain are re-applied over the edited span (a nil SKIP-PROPS +carries every existing property); the untouched prefix and suffix +keep their own properties as is. +Returns the cons (EDIT-START . EDIT-END) of the replaced span in +PRE-edit coordinates - the caller uses it to clamp a remembered +point that sat inside the edit - or nil when nothing was edited." + (let ((old-text (buffer-substring-no-properties m-start m-end))) + (unless (equal old-text plain-text) + ;; Text content differs: trim the common prefix and suffix and + ;; edit only the span that actually differs, so point and + ;; markers in the unchanged parts survive the update. + (let* ((old-len (length old-text)) + (new-len (length plain-text)) + (min-len (min old-len new-len)) + (prefix 0) + (suffix 0)) + (while (and (< prefix min-len) + (eq (aref old-text prefix) (aref plain-text prefix))) + (setq prefix (1+ prefix))) + (while (and (< suffix (- min-len prefix)) + (eq (aref old-text (- old-len suffix 1)) + (aref plain-text (- new-len suffix 1)))) + (setq suffix (1+ suffix))) + (let ((edit-start (+ m-start prefix)) + (edit-end (- m-end suffix)) + (insert-text (substring plain-text prefix (- new-len suffix))) + (existing-props (text-properties-at m-start))) + ;; Insert first, then delete the (shifted) old span: an + ;; insertion-type-nil marker at the start of the preserved + ;; suffix sits strictly after EDIT-START, so the insertion + ;; shifts it right with its character, and the deletion of + ;; the old span just before it shifts it back into place. + (goto-char edit-start) + (insert insert-text) + (delete-region (point) (+ (point) (- edit-end edit-start))) + ;; Carry over existing properties whose keys SKIP-PROPS does + ;; not name onto the newly inserted span; the untouched + ;; prefix and suffix keep their own properties as is. + (let ((mid-end (+ edit-start (length insert-text)))) + (cl-loop for (key val) on existing-props by #'cddr + do (unless (plist-member skip-props key) + (put-text-property edit-start mid-end key + val)))) + (cons edit-start edit-end)))))) + +(defun tp--pos-holds-layer-in-storage-only-p (pos layer-name) + "Return non-nil when POS holds LAYER-NAME only inside `tp-layers'. +True when the `tp-layers' stack-storage property at POS has an entry +whose `tp-name' equals LAYER-NAME while the direct `tp-name' at POS +is a different layer or absent (a hidden layer in all-hidden storage, +or a layer buried below another rendered layer)." + (and (not (equal (get-text-property pos 'tp-name) layer-name)) + (cl-some (lambda (entry) + (equal (plist-get entry 'tp-name) layer-name)) + (get-text-property pos 'tp-layers)) + t)) (defun tp--replace-reactive-text-in-buffer (layer-name new-text props) "Replace text in current buffer for reactive text with LAYER-NAME. NEW-TEXT is the new text to replace with. PROPS are the properties to apply to the new text. +Only the differing span of each region is edited: the common prefix +and suffix of the old and new text are left untouched, so point and +markers sitting in unchanged text keep their positions (point inside +the edited span ends up at the start of the edit). An identical-text +update touches no buffer text at all and does not mark the buffer as +modified. Text properties embedded in NEW-TEXT are merged with PROPS per embedded interval, so a multi-interval propertized reactive string keeps its per-character styling. Existing text properties whose keys are set neither by PROPS nor by NEW-TEXT's embedded props are preserved, so one layer's text update does not erase other layers' -contributions on the same region." - (goto-char (point-min)) - (let ((match (text-property-search-forward 'tp-name layer-name t)) - (plain-text (substring-no-properties new-text))) - (while match - (let* ((m-start (prop-match-beginning match)) - (m-end (prop-match-end match)) - (old-text (buffer-substring-no-properties m-start m-end))) - (unless (equal old-text plain-text) - ;; Text content differs: replace it, carrying over the existing - ;; properties whose keys this layer does not set. - (let ((existing-props (text-properties-at m-start))) - (delete-region m-start m-end) - (goto-char m-start) - (insert plain-text) - (let ((new-end (+ m-start (length plain-text)))) - (cl-loop for (key val) on existing-props by #'cddr - do (unless (plist-member props key) - (put-text-property m-start new-end key val)))))) - ;; Apply the layer's props, merged per embedded interval of NEW-TEXT. - ;; Keys are replaced (not accumulated); unrelated keys are untouched. - (tp--apply-reactive-text-props new-text props m-start)) - ;; Search for next match - (setq match (text-property-search-forward 'tp-name layer-name t))))) - -(defun tp--tp-text-replace (start end final-text result-props object preserve-props) - "Replace [START, END) of OBJECT with FINAL-TEXT, handling props. -Implements the text replacement of `tp--handle-tp-text-property' and -returns its (PROPS NEW-END NEW-OBJECT) result. - -For a string OBJECT a NEW string is built as prefix + FINAL-TEXT + -suffix, so text outside the region survives. RESULT-PROPS (merged -per embedded interval of FINAL-TEXT) are applied to the replaced span -here, because callers can only apply props from index 0, which would -smear them over the preserved prefix; the returned NEW-END is 0 so -the caller's own application over [0, NEW-END) is a no-op. - -For buffers the region text is replaced in place and the returned -NEW-END is the end of the inserted text; the caller applies -RESULT-PROPS itself. - -When PRESERVE-PROPS is non-nil, properties present at START whose -keys RESULT-PROPS does not set are re-applied over the replacement." - (if (stringp object) - (let* ((plain (substring-no-properties final-text)) - ;; Splice: keep the string outside [start, end) intact. - (new-string (concat (substring object 0 start) - plain - (substring object end))) - (new-end (+ start (length plain))) - (existing-props (when preserve-props - (text-properties-at start object)))) - ;; Preserve non-conflicting existing props of the replaced region - (cl-loop for (key val) on existing-props by #'cddr - do (unless (plist-member result-props key) - (put-text-property start new-end key val new-string))) - ;; Apply the merged props per embedded interval of FINAL-TEXT - (tp--apply-reactive-text-props final-text result-props start new-string) - (list result-props 0 new-string)) - ;; Buffer object - (with-current-buffer (or object (current-buffer)) - (let ((old-text (buffer-substring-no-properties start end))) - (if (equal old-text (substring-no-properties final-text)) - ;; Same text content, no replacement needed - (list result-props end object) - ;; Need to replace text - (let ((existing-props (when preserve-props - (text-properties-at start))) - (inhibit-read-only t)) - (save-excursion - (delete-region start end) - (goto-char start) - ;; Insert without properties - the caller applies RESULT-PROPS - (insert (substring-no-properties final-text))) - (let ((new-end (+ start (length final-text)))) - ;; Re-apply existing properties to new text region if preserving - (cl-loop for (key val) on existing-props by #'cddr - do (unless (plist-member result-props key) - (put-text-property start new-end key val object))) - (list result-props new-end object)))))))) - -(defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode) - "Handle tp-text property in PROPS for region from START to END in OBJECT. -If tp-text is nil, initialize it to the current text in the region; -when the layer has a `:transform', the displayed text is the -transformed value (matching later reactive updates) while the model - -the reactive variable and the `tp-text' property - keeps the raw text. -If tp-text is a string different from current text, replace the text. -When PRESERVE-PROPS is non-nil, existing text properties are preserved -on the replaced text (used by tp-set and tp-add). -MERGE-MODE is retained for backward compatibility but no longer affects behavior. -All modes now preserve embedded text properties from tp-text, with props taking -precedence over embedded props when there's a conflict. -Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props, -NEW-END is the new end position after any text replacement, and -NEW-OBJECT is the new string object (only different for strings whose -text was replaced; see `tp--tp-text-replace' for the string-object -convention of a 0 NEW-END with pre-applied properties)." - (ignore merge-mode) - (if (not (plist-member props 'tp-text)) - ;; tp-text not in props - return unchanged - (list props end object) - (let ((tp-text-val (plist-get props 'tp-text)) - (layer-name (plist-get props 'tp-name))) - (cond - ;; tp-text is nil - initialize it to the current text - ((null tp-text-val) - (let ((current-text - (if (stringp object) - (substring-no-properties object start end) - (with-current-buffer (or object (current-buffer)) - (buffer-substring-no-properties start end))))) - ;; If tp-text uses a reactive variable, update that variable to match - ;; This ensures the reactive variable and buffer text stay in sync - (when layer-name - (when-let ((reactive-var (tp--find-tp-text-reactive-var layer-name))) - ;; Update the reactive variable with the current text - ;; Note: Using global `set` here because the layer definition is global. - ;; When the variable is changed, the reactive watcher will update all - ;; buffers that have this layer applied. - (set reactive-var current-text) - ;; Also update the layer definition so future accesses see the new value - (let ((layer-props (cdr (assoc layer-name tp-layer-alist)))) - (when layer-props - (tp--set-layer-props layer-name - (plist-put layer-props 'tp-text current-text)))))) - (setq props (plist-put props 'tp-text current-text)) - ;; Apply the layer's :transform to the DISPLAYED text on this first - ;; render too, so the initial rendering matches later reactive - ;; updates. The model value stays the raw text. - (let ((display-text (tp--tp-text-transform layer-name current-text))) - (if (equal display-text current-text) - (list props end object) - (tp--tp-text-replace - start end display-text - (tp--merge-string-props-into-plist display-text props) - object preserve-props))))) - ;; tp-text has a string value - replace the text in the region - ((stringp tp-text-val) - ;; Apply transform if layer has one registered - (let* ((final-text (tp--tp-text-transform layer-name tp-text-val)) - ;; Embedded text properties from tp-text are preserved in all - ;; cases. The props passed to this function take precedence - ;; over embedded props when there's a conflict (e.g. both have - ;; a `face' property). - (result-props - (tp--merge-string-props-into-plist final-text props))) - (tp--tp-text-replace start end final-text result-props - object preserve-props))) - ;; Other types - return unchanged - (t (list props end object)))))) +contributions on the same region. +Regions where the layer sits only inside `tp-layers' stack storage - +hidden (see `tp-hide-layer') or buried below another rendered layer - +are updated as well: text content is physical (hide/show toggles +properties, never text), so the model value still replaces the text +there, but the layer's props are not applied directly; instead its +stored stack entry, including the refreshed `tp-text', is written +through, so `tp-show-layer' or a reveal by a later stack operation +renders current values. +This function owns point restoration (callers must not wrap it in +`save-excursion', whose own marker would drift): point outside the +edits keeps tracking its character, and point inside an edited span +is clamped to the start of that edit." + (let ((plain-text (substring-no-properties new-text)) + ;; Remember where the user's point was; the marker tracks all + ;; edits, and edits that swallow point clamp it explicitly. + (orig-point (copy-marker (point)))) + (unwind-protect + (cl-flet ((edit-tracking-point (m-start m-end skip-props) + ;; Run the minimal-diff edit; when the remembered + ;; point sat inside the replaced span, clamp it to + ;; the start of the edit (the documented + ;; behavior). + (let* ((was (marker-position orig-point)) + (span (tp--edit-region-minimal-diff + m-start m-end plain-text skip-props))) + (when (and span + (>= was (car span)) + (< was (cdr span))) + (set-marker orig-point (car span)))))) + (goto-char (point-min)) + ;; Pass 1: regions where the layer is the rendered top layer + ;; (direct `tp-name'). + (let ((match (text-property-search-forward 'tp-name + layer-name t))) + (while match + (let* ((m-start (prop-match-beginning match)) + (m-end (prop-match-end match))) + (edit-tracking-point m-start m-end props) + ;; Apply the layer's props, merged per embedded interval + ;; of NEW-TEXT. Keys are replaced (not accumulated); + ;; unrelated keys are untouched. + (tp--apply-reactive-text-props new-text props m-start) + ;; Continue searching after the fully updated region: a + ;; preserved suffix still carries the layer's `tp-name', + ;; and restarting the search inside it would re-match + ;; this region. + (goto-char (+ m-start (length plain-text)))) + (setq match (text-property-search-forward 'tp-name + layer-name t)))) + ;; Pass 2: regions where the layer sits only inside stack + ;; storage. Replace their text too, carrying ALL existing + ;; properties (the visible top layer's render cache and the + ;; `tp-layers' storage) over the edited span; the + ;; hidden/buried layer's own props are not applied directly. + (let ((pos (point-min))) + (while (< pos (point-max)) + (if (tp--pos-holds-layer-in-storage-only-p pos layer-name) + (let ((region-end pos)) + (while (and (< region-end (point-max)) + (tp--pos-holds-layer-in-storage-only-p + region-end layer-name)) + (setq region-end (or (next-property-change + region-end) + (point-max)))) + (edit-tracking-point pos region-end nil) + (setq pos (+ pos (length plain-text)))) + (setq pos (or (next-property-change pos) (point-max)))))) + ;; Write the updated props - including the refreshed + ;; `tp-text' - through to the layer's entries in stack + ;; storage (HID-1). + (tp--write-layer-through-stack-storage layer-name props)) + (goto-char orig-point) + (set-marker orig-point nil)))) (defun tp--reactive-apply-update (layer-name reactive-props symbol newval where override-alist) @@ -442,59 +453,103 @@ installed as `tp--reactive-update-function'." (if tp--reactive-updating ;; Nested change fired from within an update: queue, don't recurse. (tp--queue-batch-update layer-name symbol where tp-text-affected) - (let ((tp--reactive-updating t)) - ;; Update computed properties for this layer - (let ((updated-override - (tp--update-layer-computed layer-name override-alist))) - ;; Update only the reactive properties in the layer definition. - ;; Buffer-local changes must not leak into the global definition; - ;; the buffer re-render below resolves against the buffer-local - ;; values instead. - (when (and reactive-props (not (bufferp where))) - (let ((resolved-props (tp--resolve-reactive-symbols - reactive-props updated-override)) - (current-props (cdr (assoc layer-name tp-layer-alist)))) - (when current-props - ;; Deep merge the resolved reactive props into the current - ;; layer props to preserve nested plist values (like face) - (tp--set-layer-props - layer-name - (tp--deep-merge-plist current-props resolved-props))))) - ;; Update text regions with this layer (or defer if batching) - (if tp--batch-update-active - ;; Batching: defer the buffer update - (progn - (tp-debug-log " Deferring buffer update for %s (batch mode)" - layer-name) - (tp--queue-batch-update layer-name symbol where - tp-text-affected)) - ;; Normal: update immediately - (tp-debug-log " Updating layer %s (tp-text affected: %s)" - layer-name (if tp-text-affected "yes" "no")) - (if tp-text-affected - (tp--update-reactive-text layer-name where updated-override) - (tp--update-layer-regions layer-name where updated-override))))) - ;; Re-renders queued by nested variable writes during this update are - ;; flushed now that the outermost update has finished. - (unless tp--batch-update-active - (when tp--batch-update-pending - (tp--flush-batch-updates)))))) + (unwind-protect + (let ((tp--reactive-updating t)) + ;; Update computed properties for this layer + (let ((updated-override + (tp--update-layer-computed layer-name override-alist))) + ;; Update only the reactive properties in the layer definition. + ;; Buffer-local changes must not leak into the global definition; + ;; the buffer re-render below resolves against the buffer-local + ;; values instead. + (when (and reactive-props (not (bufferp where))) + (let ((resolved-props (tp--resolve-reactive-symbols + reactive-props updated-override)) + (current-props (cdr (assoc layer-name tp-layer-alist)))) + (when current-props + ;; Deep merge the resolved reactive props into the current + ;; layer props to preserve nested plist values (like face) + (tp--set-layer-props + layer-name + (tp--deep-merge-plist current-props resolved-props))))) + ;; Update text regions with this layer (or defer if batching) + (if tp--batch-update-active + ;; Batching: defer the buffer update + (progn + (tp-debug-log " Deferring buffer update for %s (batch mode)" + layer-name) + (tp--queue-batch-update layer-name symbol where + tp-text-affected)) + ;; Normal: update immediately + (tp-debug-log " Updating layer %s (tp-text affected: %s)" + layer-name (if tp-text-affected "yes" "no")) + (if tp-text-affected + (tp--update-reactive-text layer-name where updated-override) + (tp--update-layer-regions layer-name where updated-override))))) + ;; Re-renders queued by nested variable writes during this update + ;; are flushed now that the outermost update has finished. The + ;; flush runs under unwind-protect so an error escaping the + ;; re-render (for example from a modification hook) cannot strand + ;; queued entries in the global queue (ARCH-4); the reentrancy + ;; guard has been unbound by now, so the flush re-renders + ;; normally. + (unless tp--batch-update-active + (when tp--batch-update-pending + (tp--flush-batch-updates))))))) (defun tp--reactive-flush-entry (layer-name where tp-text-affected) "Re-render LAYER-NAME's regions in WHERE (or all buffers when nil). TP-TEXT-AFFECTED non-nil means the layer's `tp-text' changed and the text itself must be replaced. Runs after the changed variables have actually been set, so layer props re-resolve against current -\(buffer-local aware) values. Installed as -`tp--reactive-flush-function'." +\(buffer-local aware) values. This is the per-entry worker of +`tp--flush-batch-updates'." (if tp-text-affected (tp--update-reactive-text layer-name where) (tp--update-layer-regions layer-name where))) +(defun tp--flush-batch-updates () + "Flush all pending batch updates. +This processes all updates collected during a `tp-with-batch-updates' form." + (tp-debug-log "Flushing %d pending batch updates" (length tp--batch-update-pending)) + (let ((processed-layers nil)) + ;; Process each pending update, avoiding duplicate layer updates + (dolist (pending (nreverse tp--batch-update-pending)) + (let ((layer-name (car pending)) + (where (caddr pending)) + (tp-text-affected (cadddr pending))) + (unless (memq layer-name processed-layers) + (push layer-name processed-layers) + (tp-debug-log " Batch updating layer %s (tp-text: %s)" + layer-name (if tp-text-affected "yes" "no")) + (tp--reactive-flush-entry layer-name where tp-text-affected))))) + (setq tp--batch-update-pending nil)) + +(defmacro tp-with-batch-updates (&rest body) + "Execute BODY with reactive updates batched. +Multiple variable changes within BODY are collected and applied +together at the end, avoiding redundant buffer modifications. + +This is useful when changing multiple reactive variables simultaneously: + + (tp-with-batch-updates + (setq my-color \"red\") + (setq my-size 14) + (setq my-text \"Hello\")) + +Without batching, each `setq' would trigger a separate buffer update. +With batching, all updates are consolidated and applied once at the end." + (declare (indent 0) (debug t)) + `(let ((tp--batch-update-active t) + (tp--batch-update-pending nil)) + (tp-debug-log "Starting batch updates") + (unwind-protect + (progn ,@body) + (tp-debug-log "Ending batch updates") + (tp--flush-batch-updates)))) + ;; Install the engine into the lower modules. (setq tp--reactive-update-function #'tp--reactive-apply-update) -(setq tp--reactive-flush-function #'tp--reactive-flush-entry) -(setq tp--tp-text-handler-function #'tp--handle-tp-text-property) (setq tp--layer-refresh-function #'tp--update-layer-regions) (provide 'tp-render) diff --git a/tp-run-shuffled.el b/tp-run-shuffled.el new file mode 100644 index 0000000..c761abc --- /dev/null +++ b/tp-run-shuffled.el @@ -0,0 +1,63 @@ +;;; tp-run-shuffled.el --- run the ERT suite in a shuffled order -*- lexical-binding: t -*- + +;; Copyright (C) 2024-2026 Geekinney + +;; Author: Geekinney (kinneyzhang666@gmail.com) + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3 of +;; the License, or (at your option) any later version. + +;;; Commentary: + +;; Development script (not part of the installed package): runs every +;; loaded ERT test individually in a shuffled order to catch +;; inter-test state leaks that the fixed definition order hides. +;; +;; ERT's `member' selector does NOT control execution order (tests +;; always run in definition order), so this script loops over the +;; shuffled names and runs each test on its own. +;; +;; Usage (after loading tp and all *-tests.el files): +;; emacs -Q --batch -L . -l tp.el -l tp-tests.el ... -l tp-run-shuffled.el +;; or: make test-shuffled +;; +;; The shuffle seed is printed; reproduce a failing order with +;; SHUFFLE_SEED= make test-shuffled + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defun tp-run-shuffled--permute (list state) + "Return LIST deterministically permuted from integer seed STATE." + (let* ((v (vconcat list)) + (n (length v))) + (dotimes (i (1- n)) + ;; Simple LCG so a printed seed reproduces the exact order. + (setq state (mod (+ (* state 1103515245) 12345) 2147483648)) + (let* ((j (+ i (mod state (- n i)))) + (tmp (aref v i))) + (aset v i (aref v j)) + (aset v j tmp))) + (append v nil))) + +(let* ((names (mapcar #'ert-test-name (ert-select-tests t t))) + (seed (let ((env (getenv "SHUFFLE_SEED"))) + (if (and env (not (string-empty-p env))) + (string-to-number env) + (progn (random t) (abs (random 1000000)))))) + (shuffled (tp-run-shuffled--permute names seed)) + (unexpected 0)) + (message "tp: running %d tests in shuffled order (SHUFFLE_SEED=%d)" + (length shuffled) seed) + (dolist (name shuffled) + (let ((stats (ert-run-tests-batch name))) + (cl-incf unexpected (ert-stats-completed-unexpected stats)))) + (message "tp: shuffled run complete: %d tests, %d unexpected (seed %d)" + (length shuffled) unexpected seed) + (kill-emacs (if (zerop unexpected) 0 1))) + +;;; tp-run-shuffled.el ends here diff --git a/tp-search-tests.el b/tp-search-tests.el index c51c2ad..e0e8d89 100644 --- a/tp-search-tests.el +++ b/tp-search-tests.el @@ -372,5 +372,418 @@ with predicate t, where VALUE nil matches property-absent runs." (should (equal (substring-no-properties str) "hello world")) (should (eq (get-text-property 0 'face str) 'bold))))) +;;; 0.3.0 A1: capture-group targeting via SUBEXP in tp-regexp-* + +(ert-deftest tp-search-test-regexp-subexp-string () + "SUBEXP applies properties to the capture group only (string path)." + (let ((s (tp-regexp-set "\\(foo\\)-bar" '(face bold) + "foo-bar foo-bar" nil nil 1))) + (should (eq (get-text-property 0 'face s) 'bold)) + (should (eq (get-text-property 2 'face s) 'bold)) + (should-not (get-text-property 3 'face s)) + (should-not (get-text-property 6 'face s)) + (should (eq (get-text-property 8 'face s) 'bold)) + (should-not (get-text-property 11 'face s)))) + +(ert-deftest tp-search-test-regexp-subexp-buffer () + "SUBEXP applies properties and reports regions for the group (buffer path)." + (with-temp-buffer + (insert "foo-bar") + (let ((regions (tp-regexp-set "\\(foo\\)-\\(bar\\)" '(face bold) + (current-buffer) nil nil 2))) + (should (equal regions '((5 . 8)))) + (should (eq (get-text-property 5 'face) 'bold)) + (should-not (get-text-property 1 'face)) + (should-not (get-text-property 4 'face))))) + +(ert-deftest tp-search-test-regexp-subexp-group-not-participating () + "A match where the SUBEXP group does not participate contributes nothing." + (with-temp-buffer + (insert "b a b") + (let ((regions (tp-regexp-set "\\(a\\)\\|b" '(face bold) + (current-buffer) nil nil 1))) + ;; Only the "a" match has group 1; the "b" matches contribute + ;; neither properties nor regions. + (should (equal regions '((3 . 4)))) + (should (eq (get-text-property 3 'face) 'bold)) + (should-not (get-text-property 1 'face)) + (should-not (get-text-property 5 'face)))) + ;; String path mirror. + (let ((s (tp-regexp-set "\\(a\\)\\|b" '(face bold) "b a b" nil nil 1))) + (should (eq (get-text-property 2 'face s) 'bold)) + (should-not (get-text-property 0 'face s)) + (should-not (get-text-property 4 'face s)))) + +(ert-deftest tp-search-test-regexp-subexp-zero-width-guard () + "The zero-width guard still terminates when SUBEXP is given." + ;; "\\(x\\)*" matches the empty string everywhere in "ab" with + ;; group 1 never participating; both paths must terminate cleanly. + (let ((s (tp-regexp-set "\\(x\\)*" '(face bold) "ab" nil nil 1))) + (should (equal (substring-no-properties s) "ab")) + (should-not (text-properties-at 0 s)) + (should-not (text-properties-at 1 s))) + (with-temp-buffer + (insert "ab") + (should-not (tp-regexp-set "\\(x\\)*" '(face bold) + (current-buffer) nil nil 1)) + (should-not (get-text-property 1 'face)))) + +;;; 0.3.0 A2: START/END bounds in tp-match-* / tp-regexp-* + +(ert-deftest tp-search-test-match-bounds-string () + "START/END restrict tp-match-set to [START, END) in a string (0-based)." + (let ((s (tp-match-set "foo" '(face bold) "foo foo foo" 4 11))) + (should-not (get-text-property 0 'face s)) + (should (eq (get-text-property 4 'face s) 'bold)) + (should (eq (get-text-property 8 'face s) 'bold)))) + +(ert-deftest tp-search-test-match-bounds-buffer () + "START/END restrict tp-match-set to [START, END) in a buffer (1-based)." + (with-temp-buffer + (insert "foo foo foo") + (let ((regions (tp-match-set "foo" '(face bold) (current-buffer) 5 12))) + (should (equal regions '((5 . 8) (9 . 12)))) + (should-not (get-text-property 1 'face)) + (should (eq (get-text-property 5 'face) 'bold)) + (should (eq (get-text-property 9 'face) 'bold))))) + +(ert-deftest tp-search-test-regexp-bounds-do-not-cross-boundary () + "Bounded regexp matching behaves as if only [START, END) existed." + ;; A greedy "a+" would match the whole object; with bounds it must + ;; match exactly the bounded portion instead of being discarded. + (let ((s (tp-regexp-set "a+" '(face bold) "aaaa" 1 3))) + (should-not (get-text-property 0 'face s)) + (should (eq (get-text-property 1 'face s) 'bold)) + (should (eq (get-text-property 2 'face s) 'bold)) + (should-not (get-text-property 3 'face s))) + (with-temp-buffer + (insert "aaaa") + (should (equal (tp-regexp-set "a+" '(face bold) (current-buffer) 2 4) + '((2 . 4)))) + (should-not (get-text-property 1 'face)) + (should (eq (get-text-property 2 'face) 'bold)) + (should-not (get-text-property 4 'face)))) + +(ert-deftest tp-search-test-match-reset-and-add-accept-bounds () + "tp-match-reset/add accept the same START/END bounds." + (let* ((base (tp-set "foo foo" 'face 'italic)) + (s (tp-match-reset "foo" '(face bold) base 4 7))) + (should (eq (get-text-property 0 'face s) 'italic)) + (should (eq (get-text-property 4 'face s) 'bold))) + (let ((s (tp-match-add "foo" '(face bold) "foo foo" 4 7))) + (should-not (get-text-property 0 'face s)) + (should (eq (get-text-property 4 'face s) 'bold)))) + +;;; 0.3.0 A3: PREDICATE / NOT-CURRENT exposure in tp-forward/tp-backward + +(defmacro tp-search-tests--with-lvl-buffer (&rest body) + "Run BODY in a temp buffer with `lvl' runs 1/2/3 over \"aaabbbccc\"." + (declare (indent 0)) + `(with-temp-buffer + (insert "aaabbbccc") + (put-text-property 1 4 'lvl 1) + (put-text-property 4 7 'lvl 2) + (put-text-property 7 10 'lvl 3) + ,@body)) + +(ert-deftest tp-search-test-forward-predicate-buffer () + "A function PREDICATE selects buffer matches by property value." + (tp-search-tests--with-lvl-buffer + (goto-char (point-min)) + (let ((m (tp-forward 'lvl nil nil 1 + (lambda (_ v) (and (numberp v) (> v 1)))))) + (should m) + (should (equal (list (prop-match-beginning m) + (prop-match-end m) + (prop-match-value m)) + '(4 7 2)))))) + +(ert-deftest tp-search-test-forward-predicate-string () + "A function PREDICATE selects string matches by property value." + (let ((s (copy-sequence "aaabbbccc"))) + (tp-set 0 3 '(lvl 1) s) + (tp-set 3 6 '(lvl 2) s) + (tp-set 6 9 '(lvl 3) s) + (should (equal (tp-forward 'lvl nil s 2 + (lambda (_ v) (and (numberp v) (> v 1)))) + '((3 6 2) (6 9 3)))))) + +(ert-deftest tp-search-test-backward-predicate-buffer () + "tp-backward accepts the same function PREDICATE as tp-forward." + (tp-search-tests--with-lvl-buffer + (goto-char (point-max)) + (let ((m (tp-backward 'lvl nil nil 1 + (lambda (_ v) (and (numberp v) (< v 3)))))) + (should m) + (should (equal (list (prop-match-beginning m) + (prop-match-end m) + (prop-match-value m)) + '(4 7 2)))))) + +(ert-deftest tp-search-test-backward-predicate-string () + "tp-backward with a PREDICATE returns string matches innermost first." + (let ((s (copy-sequence "aaabbbccc"))) + (tp-set 0 3 '(lvl 1) s) + (tp-set 3 6 '(lvl 2) s) + (tp-set 6 9 '(lvl 3) s) + (should (equal (tp-backward 'lvl nil s 2 + (lambda (_ v) (and (numberp v) (> v 1)))) + '((6 9 3) (3 6 2)))))) + +(ert-deftest tp-search-test-forward-not-current-skips-point-region () + "NOT-CURRENT makes tp-forward skip the matching region around point." + (with-temp-buffer + (insert "aabbaa") + (put-text-property 1 3 'k 'x) + (put-text-property 3 5 'k 'y) + (put-text-property 5 7 'k 'x) + (goto-char (point-min)) + (let ((m (tp-forward 'k 'x))) + (should (= (prop-match-beginning m) 1))) + (goto-char (point-min)) + (let ((m (tp-forward 'k 'x nil 1 nil t))) + (should (= (prop-match-beginning m) 5)) + (should (= (prop-match-end m) 7))))) + +(ert-deftest tp-search-test-backward-not-current-skips-point-region () + "NOT-CURRENT makes tp-backward skip the matching region at point." + (with-temp-buffer + (insert "aa bb") + (put-text-property 1 3 'k 'x) + (put-text-property 4 6 'k 'x) + (goto-char (point-max)) + ;; Default keeps the 0.2.0 behavior: the run ending at point wins. + (let ((m (save-excursion (tp-backward 'k 'x)))) + (should (equal (list (prop-match-beginning m) (prop-match-end m)) + '(4 6)))) + ;; NOT-CURRENT skips it and finds the previous matching run. + (let ((m (save-excursion (tp-backward 'k 'x nil 1 nil t)))) + (should (equal (list (prop-match-beginning m) (prop-match-end m)) + '(1 3)))))) + +(ert-deftest tp-search-test-predicate-t-equals-default () + "An explicit PREDICATE of t keeps the default `equal' matching." + (tp-search-tests--with-lvl-buffer + (goto-char (point-min)) + (let ((default-m (save-excursion (tp-forward 'lvl 2))) + (t-m (save-excursion (tp-forward 'lvl 2 nil 1 t)))) + (should (= (prop-match-beginning default-m) (prop-match-beginning t-m))) + (should (= (prop-match-end default-m) (prop-match-end t-m)))))) + +(ert-deftest tp-search-test-predicate-adjacent-runs-stay-separate () + "Adjacent matching runs with different values are separate matches. +Mirrors `text-property-search-forward', which ends a match where the +value changes when a non-nil predicate is given." + (let ((s (copy-sequence "abcdef"))) + (tp-set 0 3 '(lvl 1) s) + (tp-set 3 6 '(lvl 2) s) + (should (equal (tp-forward 'lvl nil s 5 (lambda (_ v) (numberp v))) + '((0 3 1) (3 6 2)))))) + +(ert-deftest tp-search-test-forward-do-predicate () + "tp-forward-do passes PREDICATE through to select the target match." + (let ((s (copy-sequence "abc def"))) + (tp-set 0 3 '(lvl 1) s) + (tp-set 4 7 '(lvl 2) s) + (should (= (tp-forward-do #'upcase 'lvl nil s 1 nil nil + (lambda (_ v) (eq v 2))) + 1)) + (should (equal (substring-no-properties s) "abc DEF")))) + +(ert-deftest tp-search-test-backward-do-predicate () + "tp-backward-do passes PREDICATE through to select the target match." + (with-temp-buffer + (insert "abc def") + (put-text-property 1 4 'lvl 1) + (put-text-property 5 8 'lvl 2) + (should (= (tp-backward-do #'upcase 'lvl nil (current-buffer) 1 nil nil + (lambda (_ v) (eq v 1))) + 1)) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + "ABC def")))) + +(ert-deftest tp-search-test-forward-do-defaults-unchanged () + "tp-forward-do without PREDICATE keeps the 0.2.0 `equal' matching." + (let ((s (copy-sequence "abc def"))) + (tp-set 0 3 '(lvl 1) s) + (tp-set 4 7 '(lvl 2) s) + (should (= (tp-forward-do #'upcase 'lvl 2 s) 1)) + (should (equal (substring-no-properties s) "abc DEF")))) + +;;; REG-1: pattern-apply paths must register buffers in the reactive registry + +(defvar tp-search-reg1-color nil) +(defvar tp-search-reg1b-color nil) + +(ert-deftest tp-search-test-regexp-add-registers-reactive-buffer () + "tp-regexp-add in a second buffer keeps reactive updates flowing there. +The deep-merge apply path stamps `tp-name' but never registered the +buffer, so once the layer was known from a `tp-set' elsewhere the +regexp-applied buffer went permanently stale (REG-1)." + (setq tp-search-reg1-color "red") + (unwind-protect + (progn + (tp-layer-reset) + (define-tp tp-search-reg1-layer () + :props '(face (:foreground $tp-search-reg1-color))) + (let ((a (generate-new-buffer " *tp-sreg1-a*")) + (b (generate-new-buffer " *tp-sreg1-b*"))) + (unwind-protect + (progn + (with-current-buffer a (insert "foo bar")) + (with-current-buffer b (insert "foo bar")) + (tp-set 1 4 'tp-search-reg1-layer a) ; registers A + (tp-regexp-add "foo" 'tp-search-reg1-layer b) + (let ((bufs (tp-reactive-layer-buffers + 'tp-search-reg1-layer))) + (should (memq a bufs)) + (should (memq b bufs))) + (setq tp-search-reg1-color "blue") + (should (equal (with-current-buffer a + (get-text-property 1 'face)) + '(:foreground "blue"))) + (should (equal (with-current-buffer b + (get-text-property 1 'face)) + '(:foreground "blue")))) + (kill-buffer a) + (kill-buffer b)))) + (tp-layer-reset) + (setq tp-search-reg1-color nil))) + +(ert-deftest tp-search-test-match-reset-registers-reactive-buffer () + "tp-match-reset in a second buffer keeps reactive updates flowing there. +The reset-apply path stamps `tp-name' via `set-text-properties' but +never registered the buffer (REG-1)." + (setq tp-search-reg1b-color "red") + (unwind-protect + (progn + (tp-layer-reset) + (define-tp tp-search-reg1b-layer () + :props '(face (:foreground $tp-search-reg1b-color))) + (let ((a (generate-new-buffer " *tp-sreg1b-a*")) + (b (generate-new-buffer " *tp-sreg1b-b*"))) + (unwind-protect + (progn + (with-current-buffer a (insert "foo bar")) + (with-current-buffer b (insert "foo bar")) + (tp-set 1 4 'tp-search-reg1b-layer a) + (tp-match-reset "foo" 'tp-search-reg1b-layer b) + (let ((bufs (tp-reactive-layer-buffers + 'tp-search-reg1b-layer))) + (should (memq a bufs)) + (should (memq b bufs))) + (setq tp-search-reg1b-color "blue") + (should (equal (with-current-buffer a + (get-text-property 1 'face)) + '(:foreground "blue"))) + (should (equal (with-current-buffer b + (get-text-property 1 'face)) + '(:foreground "blue")))) + (kill-buffer a) + (kill-buffer b)))) + (tp-layer-reset) + (setq tp-search-reg1b-color nil))) + +;;; SRC-1: reversed START/END bounds are swapped on both object paths + +(ert-deftest tp-search-test-reversed-bounds-string-swaps () + "String-path START > END is swapped instead of signaling out-of-range." + (let ((res (tp-match-set "o" '(face bold) "foo" 2 1))) + (should (eq (get-text-property 1 'face res) 'bold)) + (should-not (get-text-property 2 'face res))) + ;; Swapped bounds behave exactly like the same bounds in order. + (should (equal-including-properties + (tp-regexp-set "o+" '(face bold) "foo" 3 1) + (tp-regexp-set "o+" '(face bold) "foo" 1 3)))) + +(ert-deftest tp-search-test-reversed-bounds-buffer-swaps () + "Buffer-path START > END keeps its historical swap behavior." + (with-temp-buffer + (insert "foo") + (should (equal (tp-match-set "o" '(face bold) nil 3 2) + '((2 . 3)))) + (should (eq (get-text-property 2 'face) 'bold)) + (should-not (get-text-property 3 'face)))) + +;;; SRC-2: SUBEXP beyond the pattern's group count signals clearly + +(ert-deftest tp-search-test-subexp-beyond-group-count-errors () + "A SUBEXP larger than the pattern's group count errors on both paths." + (should-error (tp-regexp-set "abc" '(face bold) + (copy-sequence "abc") nil nil 5)) + (with-temp-buffer + (insert "abc") + (should-error (tp-regexp-add "a\\(b\\)c" '(face bold) nil nil nil 2)) + ;; Nothing was applied before the error. + (should-not (get-text-property 1 'face)))) + +(ert-deftest tp-search-test-subexp-non-participating-group-quiet () + "A legal group that never participates still returns nil quietly." + (with-temp-buffer + (insert "xbc") + (should (null (tp-regexp-set "\\(a\\)bc\\|xbc" '(face bold) + nil nil nil 1))) + (should-not (get-text-property 1 'face)))) + +;;; API-NAME-01: raw wrappers deprecated, behavior bit-identical + +(ert-deftest tp-search-test-raw-wrappers-marked-obsolete () + "The raw wrappers carry obsolescence info pointing at tp-forward/backward." + (should (eq (car (get 'tp-search-forward 'byte-obsolete-info)) + 'tp-forward)) + (should (eq (car (get 'tp-search-backward 'byte-obsolete-info)) + 'tp-backward))) + +(ert-deftest tp-search-test-raw-wrapper-forward-primitive-semantics () + "tp-search-forward still behaves exactly like the Emacs primitive. +The third argument stays PREDICATE (not tp-forward's OBJECT slot) and +the nil-PREDICATE default keeps the primitive's not-`equal' matching." + (with-temp-buffer + (insert "aaabbb") + (put-text-property 4 7 'k 'v) + (dolist (args '((k) (k v t) (k v t t) (k other) (k missing t))) + (goto-char (point-min)) + (let ((prim (apply #'text-property-search-forward args)) + (prim-pt (point))) + (goto-char (point-min)) + (let ((wrap (with-suppressed-warnings ((obsolete tp-search-forward)) + (apply #'tp-search-forward args)))) + (should (equal wrap prim)) + (should (= (point) prim-pt))))) + ;; One concrete anchor: nil PREDICATE with nil VALUE finds the + ;; non-nil run and moves point to its end. + (goto-char (point-min)) + (let ((m (with-suppressed-warnings ((obsolete tp-search-forward)) + (tp-search-forward 'k)))) + (should m) + (should (= (prop-match-beginning m) 4)) + (should (= (prop-match-end m) 7)) + (should (= (point) 7))))) + +(ert-deftest tp-search-test-raw-wrapper-backward-primitive-semantics () + "tp-search-backward still behaves exactly like the Emacs primitive." + (with-temp-buffer + (insert "aaabbb") + (put-text-property 1 4 'k 'v) + (dolist (args '((k) (k v t) (k v t t) (k other) (k missing t))) + (goto-char (point-max)) + (let ((prim (apply #'text-property-search-backward args)) + (prim-pt (point))) + (goto-char (point-max)) + (let ((wrap (with-suppressed-warnings ((obsolete tp-search-backward)) + (apply #'tp-search-backward args)))) + (should (equal wrap prim)) + (should (= (point) prim-pt))))))) + +(ert-deftest tp-search-test-forward-string-path-first-n-contract () + "tp-forward's string path returns the FIRST N matches from position 0." + (let ((s (copy-sequence "aabbaabb"))) + (put-text-property 0 2 'k 'v s) + (put-text-property 4 6 'k 'v s) + (should (equal (tp-forward 'k 'v s) '((0 2 v)))) + (should (equal (tp-forward 'k 'v s 2) '((0 2 v) (4 6 v)))) + ;; Fewer matches than N: return what exists, not nil. + (should (equal (tp-forward 'k 'v s 5) '((0 2 v) (4 6 v)))))) + (provide 'tp-search-tests) ;;; tp-search-tests.el ends here diff --git a/tp-search.el b/tp-search.el index f83b2cc..1614de9 100644 --- a/tp-search.el +++ b/tp-search.el @@ -20,14 +20,48 @@ (require 'cl-lib) (require 'text-property-search) (require 'tp-core) +(require 'tp-reactive) (require 'tp-layer) (require 'tp-ops) -(defun tp--pattern-apply-single (pattern properties apply-fn object literal) +(defun tp--search-register-layer-buffer (props object) + "Record OBJECT in the reactive buffer registry for PROPS's layers. +When OBJECT is a buffer or nil (the current buffer) and the applied +PROPS carry a `tp-name' - directly, or inside a `tp-layers' entry +from a group application - register that buffer under each layer name +via `tp-reactive--register-layer-buffer', so reactive updates keep +visiting buffers written through the pattern-apply paths. String +OBJECTs are not registered; see `tp-reactive-layer-buffers' for that +gap." + (when (or (null object) (bufferp object)) + (let ((buf (or object (current-buffer)))) + (when-let ((name (plist-get props 'tp-name))) + (tp-reactive--register-layer-buffer name buf)) + (dolist (layer (plist-get props 'tp-layers)) + (when-let ((name (plist-get layer 'tp-name))) + (tp-reactive--register-layer-buffer name buf)))))) + +(defun tp--pattern-apply-single (pattern properties apply-fn object literal + &optional start end subexp) "Apply APPLY-FN to matches of single PATTERN in OBJECT. When LITERAL is non-nil, PATTERN is matched literally; otherwise it is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for each match. +START and END restrict matching to the [START, END) portion of +OBJECT, in native coordinates (0-based for strings, 1-based for +buffers); nil means the object's bounds. If START > END the bounds +are swapped (matching the buffer path's historical narrow-to-region +behavior, now uniform across object types). Matching behaves as if +OBJECT consisted only of that portion (the buffer path narrows, the +string path matches against the substring), so no match crosses the +boundaries. +When SUBEXP is non-nil, it names a capture group of PATTERN: the +properties and returned regions cover (match-beginning SUBEXP) to +\(match-end SUBEXP) of each match, and a match in which that group +does not participate contributes nothing. The scan still advances +past the whole match. A SUBEXP larger than PATTERN's group count +\(per `regexp-opt-depth') signals an error instead of silently +matching nothing. For strings, returns a NEW string with properties applied \(non-destructive). For buffers, modifies in-place and returns list of regions. @@ -36,17 +70,37 @@ Zero-width matches (an empty literal pattern, or a regexp that can match the empty string) are recorded and the scan advances one position past them, so the search always terminates." (let ((regexp (if literal (regexp-quote pattern) pattern))) + ;; Reversed bounds are swapped, not signaled: the buffer path's + ;; narrow-to-region always did this, so the string path follows. + (when (and start end (> start end)) + (cl-rotatef start end)) + ;; A group number beyond the pattern's group count could never + ;; match; make the typo loud instead of a silent no-op. + (when (and subexp (> subexp (regexp-opt-depth regexp))) + (error "Regexp %S has no group %d" pattern subexp)) (cond ;; String object ((stringp object) - ;; First, collect all match positions from the original string - (let ((matches nil) - (pos 0) - (limit (length object))) - (while (and (<= pos limit) (string-match regexp object pos)) + ;; First, collect all match positions from the original string. + ;; Bounded searches run against the substring so matches cannot + ;; cross the [START, END) boundaries; positions are shifted back + ;; into whole-string coordinates afterwards. + (let* ((from (max (or start 0) 0)) + (to (min (or end (length object)) (length object))) + (searchable (if (and (= from 0) (= to (length object))) + object + (substring object from to))) + (matches nil) + (pos 0) + (limit (- to from))) + (while (and (<= pos limit) (string-match regexp searchable pos)) (let ((beg (match-beginning 0)) - (end (match-end 0))) - (push (cons beg end) matches) + (end (match-end 0)) + (sub-beg (match-beginning (or subexp 0))) + (sub-end (match-end (or subexp 0)))) + ;; A group that does not participate contributes nothing. + (when sub-beg + (push (cons (+ from sub-beg) (+ from sub-end)) matches)) (setq pos (if (= beg end) (1+ beg) end)))) ;; Apply function to each match in order (reverse to get correct order) ;; Make a copy to ensure original string is not modified @@ -62,26 +116,38 @@ position past them, so the search always terminates." (let ((buf (or object (current-buffer)))) (tp-with-current-buffer buf (save-excursion - (goto-char (point-min)) - (let (regions (keep-going t)) - (while (and keep-going (re-search-forward regexp nil t)) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (when properties - (funcall apply-fn beg end properties buf)) - (push (cons beg end) regions) - ;; Guard against zero-width matches looping forever - (when (= beg end) - (if (eobp) - (setq keep-going nil) - (forward-char 1))))) - (nreverse regions))))))))) + (save-restriction + (when (or start end) + (narrow-to-region (max (or start (point-min)) (point-min)) + (min (or end (point-max)) (point-max)))) + (goto-char (point-min)) + (let (regions (keep-going t)) + (while (and keep-going (re-search-forward regexp nil t)) + (let ((beg (match-beginning 0)) + (end (match-end 0)) + (sub-beg (match-beginning (or subexp 0))) + (sub-end (match-end (or subexp 0)))) + ;; A group that does not participate contributes nothing. + (when sub-beg + (when properties + (funcall apply-fn sub-beg sub-end properties buf)) + (push (cons sub-beg sub-end) regions)) + ;; Guard against zero-width matches looping forever + (when (= beg end) + (if (eobp) + (setq keep-going nil) + (forward-char 1))))) + (nreverse regions)))))))))) -(defun tp--pattern-apply (pattern properties apply-fn object literal) +(defun tp--pattern-apply (pattern properties apply-fn object literal + &optional start end subexp) "Apply APPLY-FN to matches of PATTERN (one pattern or a list). When LITERAL is non-nil, patterns are matched literally; otherwise they are regexps. APPLY-FN is called with (START END PROPS OBJECT) for each match. +START and END restrict matching to [START, END) in native +coordinates; SUBEXP names a capture group to target (see +`tp--pattern-apply-single'). For strings, returns a NEW string with properties applied \(non-destructive). For buffers, returns list of regions." @@ -92,47 +158,59 @@ For buffers, returns list of regions." (let ((result object)) (dolist (p patterns) (setq result (tp--pattern-apply-single p properties apply-fn - result literal))) + result literal + start end subexp))) result)) ;; Buffer or nil (current buffer) (t (let ((all-regions nil)) (dolist (p patterns) (let ((regions (tp--pattern-apply-single p properties apply-fn - object literal))) + object literal + start end subexp))) (setq all-regions (append all-regions regions)))) all-regions))))) -(defun tp--match-apply-single (pattern properties apply-fn object) +(defun tp--match-apply-single (pattern properties apply-fn object + &optional start end) "Apply APPLY-FN to literal matches of single PATTERN in OBJECT. +START and END restrict matching to [START, END) in native coordinates. For strings, returns a new string with properties applied (non-destructive). For buffers, modifies in-place and returns list of regions." - (tp--pattern-apply-single pattern properties apply-fn object t)) + (tp--pattern-apply-single pattern properties apply-fn object t start end)) -(defun tp--match-apply (pattern properties apply-fn &optional object) +(defun tp--match-apply (pattern properties apply-fn &optional object start end) "Internal function to apply APPLY-FN to matches of PATTERN. PATTERN can be a string or a list of strings (multiple patterns). When PATTERN is a list, each element is a pattern to match. APPLY-FN is called with (START END PROPS OBJECT) for each match. +START and END restrict matching to [START, END) in native coordinates. For strings, returns a NEW string with properties applied (non-destructive). For buffers, returns list of regions." - (tp--pattern-apply pattern properties apply-fn object t)) + (tp--pattern-apply pattern properties apply-fn object t start end)) -(defun tp--regexp-apply-single (pattern properties apply-fn object) +(defun tp--regexp-apply-single (pattern properties apply-fn object + &optional start end subexp) "Apply APPLY-FN to regexp matches of single PATTERN in OBJECT. APPLY-FN is called with (START END PROPS OBJECT) for each match. +START and END restrict matching to [START, END) in native +coordinates; SUBEXP names a capture group to target. For strings, returns a NEW string with properties applied (non-destructive). For buffers, modifies in-place and returns list of regions." - (tp--pattern-apply-single pattern properties apply-fn object nil)) + (tp--pattern-apply-single pattern properties apply-fn object nil + start end subexp)) -(defun tp--regexp-apply (pattern properties apply-fn &optional object) +(defun tp--regexp-apply (pattern properties apply-fn + &optional object start end subexp) "Internal function to apply APPLY-FN to regexp matches of PATTERN. PATTERN can be a string (single regexp) or a list of strings (multiple regexps). When PATTERN is a list, each element is a regexp to match. APPLY-FN is called with (START END PROPS OBJECT) for each match. +START and END restrict matching to [START, END) in native +coordinates; SUBEXP names a capture group to target. For strings, returns a NEW string with properties applied (non-destructive). For buffers, returns list of regions." - (tp--pattern-apply pattern properties apply-fn object nil)) + (tp--pattern-apply pattern properties apply-fn object nil start end subexp)) (defun tp--deep-merge-apply (start end props obj) "Apply PROPS to OBJ from START to END with deep merge. @@ -142,7 +220,10 @@ For buffers, modifies in-place." (if (stringp obj) ;; For strings: create a new propertized string using tp--apply-props-to-string with :add mode (tp--apply-props-to-string obj start end props :add) - ;; For buffers: modify in-place + ;; For buffers: modify in-place. This path stamps `tp-name' for + ;; resolved layer applications, so the buffer must be registered + ;; in the reactive registry or later updates would skip it (REG-1). + (tp--search-register-layer-buffer props obj) (let ((pos start)) (while (< pos end) (let* ((current-props (text-properties-at pos obj)) @@ -165,10 +246,10 @@ For buffers, modifies in-place." (setq pos next-pos)))) obj)) -(defun tp-match-set (pattern plist &optional object) +(defun tp-match-set (pattern plist &optional object start end) "Set properties on all occurrences of PATTERN. - (tp-match-set PATTERN PLIST &optional OBJECT) + (tp-match-set PATTERN PLIST &optional OBJECT START END) PATTERN is a string (single pattern) or list of strings (multiple patterns). Each pattern will be matched and have properties applied. @@ -176,30 +257,42 @@ PLIST is a property list like \\='(face bold help-echo \"tip\"), or a symbol representing a layer/group name defined by `define-tp' or `define-tp-group'. OBJECT is a buffer or string; nil means current buffer. +START and END restrict matching to the [START, END) portion of +OBJECT, in native coordinates (0-based for strings, 1-based for +buffers); nil means the object's bounds. If START > END the bounds +are swapped. Matching behaves as if OBJECT consisted only of that +portion, so no match crosses the boundaries. Returns: -- For strings: the modified string +- For strings: a NEW string with properties applied (the original + string is not modified) - For buffers: list of (START . END) pairs for all matches." - (tp--match-apply pattern (tp--ensure-props plist) #'tp-set object)) + (tp--match-apply pattern (tp--ensure-props plist) #'tp-set object + start end)) -(defun tp-match-reset (pattern plist &optional object) +(defun tp-match-reset (pattern plist &optional object start end) "Reset (completely replace) properties on all occurrences of PATTERN. - (tp-match-reset PATTERN PLIST &optional OBJECT) + (tp-match-reset PATTERN PLIST &optional OBJECT START END) PATTERN is a string (single pattern) or list of strings (multiple patterns). PLIST is a property list like \\='(face bold help-echo \"tip\"), or a symbol representing a layer/group name defined by `define-tp' or `define-tp-group'. OBJECT is a buffer or string; nil means current buffer. +START and END restrict matching to the [START, END) portion of +OBJECT, in native coordinates (0-based for strings, 1-based for +buffers); nil means the object's bounds. If START > END the bounds +are swapped. Unlike `tp-match-set', this completely replaces all existing properties. For strings, returns a NEW string (original is not modified). -For buffers, modifies in-place and returns list of regions." +For buffers, modifies in-place and returns list of (START . END) +regions." (tp--match-apply pattern (tp--ensure-props plist) #'tp--reset-apply - object)) + object start end)) (defun tp--reset-apply (start end props obj) "Apply PROPS to OBJ from START to END, completely replacing existing properties. @@ -208,26 +301,38 @@ For buffers, modifies in-place." (if (stringp obj) (tp--apply-props-to-string obj start end props :reset) (set-text-properties start end props obj) + ;; A resolved layer application stamps `tp-name': register the + ;; buffer so reactive updates keep visiting it (REG-1). + (tp--search-register-layer-buffer props obj) obj)) -(defun tp-match-add (pattern plist &optional object) +(defun tp-match-add (pattern plist &optional object start end) "Add/update properties on all occurrences of PATTERN. - (tp-match-add PATTERN PLIST &optional OBJECT) + (tp-match-add PATTERN PLIST &optional OBJECT START END) PATTERN is a string (single pattern) or list of strings (multiple patterns). PLIST is a property list like \\='(face bold help-echo \"tip\"), or a symbol representing a layer/group name defined by `define-tp' or `define-tp-group'. OBJECT is a buffer or string; nil means current buffer. +START and END restrict matching to the [START, END) portion of +OBJECT, in native coordinates (0-based for strings, 1-based for +buffers); nil means the object's bounds. If START > END the bounds +are swapped. -Unlike `tp-match-set', this deeply merges nested properties." - (tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object)) +Unlike `tp-match-set', this deeply merges nested properties. -(defun tp-regexp-set (pattern plist &optional object) +For strings, returns a NEW string (original is not modified). +For buffers, modifies in-place and returns list of (START . END) +regions." + (tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply + object start end)) + +(defun tp-regexp-set (pattern plist &optional object start end subexp) "Set properties on all matches of PATTERN (regexp). - (tp-regexp-set PATTERN PLIST &optional OBJECT) + (tp-regexp-set PATTERN PLIST &optional OBJECT START END SUBEXP) PATTERN is a string (single regexp) or list of strings (multiple regexps). Each pattern will be matched and have properties applied. @@ -235,66 +340,158 @@ PLIST is a property list like \\='(face bold help-echo \"tip\"), or a symbol representing a layer/group name defined by `define-tp' or `define-tp-group'. OBJECT is a buffer or string; nil means current buffer. +START and END restrict matching to the [START, END) portion of +OBJECT, in native coordinates (0-based for strings, 1-based for +buffers); nil means the object's bounds. If START > END the bounds +are swapped. Matching behaves as if OBJECT consisted only of that +portion, so no match crosses the boundaries. +When SUBEXP is non-nil, it names a capture group of PATTERN (1 for +the first group, like font-lock highlights): properties apply to that +group of each match instead of the whole match, and a match in which +the group does not participate contributes nothing. A SUBEXP larger +than PATTERN's group count signals an error. Returns: -- For strings: the modified string +- For strings: a NEW string with properties applied (the original + string is not modified) - For buffers: list of (START . END) pairs for all matches." - (tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object)) + (tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object + start end subexp)) -(defun tp-regexp-reset (pattern plist &optional object) +(defun tp-regexp-reset (pattern plist &optional object start end subexp) "Reset (completely replace) properties on all regexp matches of PATTERN. - (tp-regexp-reset PATTERN PLIST &optional OBJECT) + (tp-regexp-reset PATTERN PLIST &optional OBJECT START END SUBEXP) PATTERN is a string (single regexp) or list of strings (multiple regexps). PLIST is a property list like \\='(face bold help-echo \"tip\"), or a symbol representing a layer/group name defined by `define-tp' or `define-tp-group'. OBJECT is a buffer or string; nil means current buffer. +START and END restrict matching to the [START, END) portion of +OBJECT, in native coordinates (0-based for strings, 1-based for +buffers); nil means the object's bounds. If START > END the bounds +are swapped. +When SUBEXP is non-nil, properties apply to that capture group of +each match instead of the whole match; a match in which the group +does not participate contributes nothing. A SUBEXP larger than +PATTERN's group count signals an error. Unlike `tp-regexp-set', this completely replaces all existing properties. For strings, returns a NEW string (original is not modified). -For buffers, modifies in-place and returns list of regions." +For buffers, modifies in-place and returns list of (START . END) +regions." (tp--regexp-apply pattern (tp--ensure-props plist) #'tp--reset-apply - object)) + object start end subexp)) -(defun tp-regexp-add (pattern plist &optional object) +(defun tp-regexp-add (pattern plist &optional object start end subexp) "Add/update properties on all regexp matches of PATTERN. - (tp-regexp-add PATTERN PLIST &optional OBJECT) + (tp-regexp-add PATTERN PLIST &optional OBJECT START END SUBEXP) PATTERN is a string (single regexp) or list of strings (multiple regexps). PLIST is a property list like \\='(face bold help-echo \"tip\"), or a symbol representing a layer/group name defined by `define-tp' or `define-tp-group'. OBJECT is a buffer or string; nil means current buffer. +START and END restrict matching to the [START, END) portion of +OBJECT, in native coordinates (0-based for strings, 1-based for +buffers); nil means the object's bounds. If START > END the bounds +are swapped. +When SUBEXP is non-nil, properties apply to that capture group of +each match instead of the whole match; a match in which the group +does not participate contributes nothing. A SUBEXP larger than +PATTERN's group count signals an error. -Unlike `tp-regexp-set', this deeply merges nested properties." - (tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object)) +Unlike `tp-regexp-set', this deeply merges nested properties. + +For strings, returns a NEW string (original is not modified). +For buffers, modifies in-place and returns list of (START . END) +regions." + (tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply + object start end subexp)) (defun tp-search-forward (property &optional value predicate not-current) - "Search forward for text with PROPERTY. -Wraps `text-property-search-forward'." + "Search forward from point for text whose PROPERTY matches VALUE. +This is a raw wrapper: PROPERTY, VALUE, PREDICATE and NOT-CURRENT are +passed unchanged to `text-property-search-forward', whose semantics +apply in full - including the primitive's nil-PREDICATE default of +matching values that are non-nil and NOT `equal' to VALUE. On +success point moves to the end of the matched region and a prop-match +object is returned; otherwise nil. + +Obsolete since tp 0.3.0: call `tp-forward' for tp's `equal'-matching +search (which also supports string OBJECTs and repeat counts), or +call the Emacs primitive `text-property-search-forward' directly for +raw use - this wrapper adds nothing to it." (text-property-search-forward property value predicate not-current)) +(make-obsolete 'tp-search-forward 'tp-forward "0.3.0") (defun tp-search-backward (property &optional value predicate not-current) - "Search backward for text with PROPERTY. -Wraps `text-property-search-backward'." - (text-property-search-backward property value predicate not-current)) + "Search backward from point for text whose PROPERTY matches VALUE. +This is a raw wrapper: PROPERTY, VALUE, PREDICATE and NOT-CURRENT are +passed unchanged to `text-property-search-backward', whose semantics +apply in full - including the primitive's nil-PREDICATE default of +matching values that are non-nil and NOT `equal' to VALUE. On +success point moves to the beginning of the matched region and a +prop-match object is returned; otherwise nil. -(defun tp--property-search-backward (property value) - "Search backward for the previous region where PROPERTY `equal's VALUE. +Obsolete since tp 0.3.0: call `tp-backward' for tp's `equal'-matching +search (which also supports string OBJECTs and repeat counts), or +call the Emacs primitive `text-property-search-backward' directly for +raw use - this wrapper adds nothing to it." + (text-property-search-backward property value predicate not-current)) +(make-obsolete 'tp-search-backward 'tp-backward "0.3.0") + +(defun tp--property-match-p (value prop-value predicate) + "Return non-nil when PROP-VALUE matches VALUE under PREDICATE. +PREDICATE follows the convention tp uses for +`text-property-search-forward': nil and t both mean the values must +be `equal' (tp's 0.2.0 symmetric matching contract); a function is +called with VALUE and PROP-VALUE and matches when it returns +non-nil." + (if (functionp predicate) + (funcall predicate value prop-value) + (equal value prop-value))) + +(defun tp--string-property-matches (string property value predicate) + "Collect PROPERTY runs of STRING matching VALUE under PREDICATE. +Returns a list of (START END VALUE) lists with 0-based positions. A +run is a maximal stretch with one `eq' PROPERTY value, and it matches +when `tp--property-match-p' accepts that value. Adjacent matching +runs with different values stay separate entries, mirroring how +`text-property-search-forward' ends a match where the property value +changes when a non-nil predicate is given." + (let ((results nil)) + (tp--map-intervals + string 0 (length string) + (lambda (beg end val) + (when (tp--property-match-p value val predicate) + (push (list beg end val) results)) + nil) + property) + (nreverse results))) + +(defun tp--property-search-backward (property value + &optional predicate not-current) + "Search backward for the previous region where PROPERTY matches VALUE. This is the backward mirror of (text-property-search-forward PROPERTY -VALUE t): a region matches when its PROPERTY value is `equal' to -VALUE. It deliberately does not call +VALUE t): by default a region matches when its PROPERTY value is +`equal' to VALUE. It deliberately does not call `text-property-search-backward' with predicate t, because that primitive's non-default-predicate branch skips every other property run when non-matching runs intervene (observed through Emacs 30.2), silently missing valid matches. +PREDICATE follows `tp--property-match-p': nil and t both mean `equal' +matching (the 0.2.0 contract); a function is called with VALUE and +the region's PROPERTY value. When NOT-CURRENT is non-nil, the +matching region containing point (or ending exactly at point) is +skipped, mirroring the primitive's NOT-CURRENT argument. + If a matching region is found, move point to its beginning and return a `prop-match' object whose end is clipped to the starting point (matching the primitive's behavior when point starts inside a @@ -308,7 +505,10 @@ matching region). Otherwise return nil and leave point alone." (tp--map-intervals (current-buffer) (point-min) origin (lambda (ibeg iend val) - (when (equal value val) + (when (and (tp--property-match-p value val predicate) + ;; With NOT-CURRENT, the run point is inside (or + ;; just after) is not a candidate. + (not (and not-current (= iend origin)))) (setq found (list ibeg iend val))) nil) property) @@ -318,14 +518,40 @@ matching region). Otherwise return nil and leave point alone." :end (cadr found) :value (caddr found)))))) -(defun tp-forward (property &optional value object n) +(defun tp-forward (property &optional value object n predicate not-current) "Search forward N times for text with PROPERTY. -Returns prop-match for buffers or list of (START END VALUE) for strings." + +VALUE is the optional value to match; N is the number of searches, +defaulting to 1. +OBJECT can be a buffer or string; nil defaults to current buffer. +PREDICATE customizes matching: nil (the default) and t both keep the +0.2.0 contract where a region matches when its PROPERTY value is +`equal' to VALUE; a function is called with VALUE and the region's +PROPERTY value and matches when it returns non-nil. For buffers it +is passed to `text-property-search-forward'. +NOT-CURRENT is passed to `text-property-search-forward' and, when +non-nil, makes the search skip a matching region containing point. +It only applies to the buffer path; strings have no point, so it is +ignored there. + +For buffers, each search starts from point and each successful one +moves point to the end of its matched region; the return value is +the prop-match object of the N-th search, or nil when that search +found nothing. + +For strings, point is not involved at all: the return value is the +list of the FIRST N matching regions counted from position 0 of the +string, each a (START END VALUE) list with 0-based positions - not +the N-th match alone. Fewer than N matches return however many +exist." (let ((count (or n 1))) (cond - ;; String object - use tp-search + ;; String object - use tp-search (or the predicate-aware matcher) ((stringp object) - (let ((matches (tp-search object property value))) + (let ((matches (if (functionp predicate) + (tp--string-property-matches object property + value predicate) + (tp-search object property value)))) (seq-take matches count))) ;; Buffer or nil (t @@ -333,26 +559,41 @@ Returns prop-match for buffers or list of (START END VALUE) for strings." (buf (or object (current-buffer)))) (tp-with-current-buffer buf (dotimes (_ count) - (setq result (tp-search-forward property value t)))) + (setq result (text-property-search-forward + property value + (if (functionp predicate) predicate t) + not-current)))) result))))) -(defun tp-backward (property &optional value object n) +(defun tp-backward (property &optional value object n predicate not-current) "Search backward N times for text with PROPERTY. N is the number of searches, defaulting to 1. VALUE is the optional value to match. OBJECT can be a buffer or string; nil defaults to current buffer. +PREDICATE customizes matching: nil (the default) and t both keep the +0.2.0 contract where a region matches when its PROPERTY value is +`equal' to VALUE; a function is called with VALUE and the region's +PROPERTY value and matches when it returns non-nil. +NOT-CURRENT, when non-nil, skips a matching region containing point +\(or ending exactly at point), mirroring +`text-property-search-backward'. It only applies to the buffer +path; strings have no point, so it is ignored there. For buffers, returns the prop-match object from the last successful search. For strings, returns a list of (START END VALUE) for the last N matches in reverse order (from end to start). -Uses `tp-search-backward' for buffers and `tp-search' for strings." +Uses `tp--property-search-backward' for buffers and `tp-search' (or +the predicate-aware matcher) for strings." (let ((count (or n 1))) (cond ;; String object - use tp-search and reverse ((stringp object) - (let ((matches (nreverse (tp-search object property value)))) + (let ((matches (nreverse (if (functionp predicate) + (tp--string-property-matches + object property value predicate) + (tp-search object property value))))) (seq-take matches count))) ;; Buffer or nil (t @@ -360,14 +601,17 @@ Uses `tp-search-backward' for buffers and `tp-search' for strings." (buf (or object (current-buffer)))) (tp-with-current-buffer buf (dotimes (_ count) - ;; `equal' matching, mirroring the predicate t that - ;; `tp-forward' passes. The previous code used the default - ;; nil predicate, which matches values NOT `equal' to VALUE - ;; and so inverted the match when VALUE was non-nil. - (setq result (tp--property-search-backward property value)))) + ;; `equal' matching by default, mirroring the predicate t + ;; that `tp-forward' passes. The previous code used the + ;; default nil predicate, which matches values NOT `equal' + ;; to VALUE and so inverted the match when VALUE was + ;; non-nil. + (setq result (tp--property-search-backward + property value predicate not-current)))) result))))) -(defun tp--forward-do (function property &optional value object times start end) +(defun tp--forward-do (function property &optional value object times + start end predicate not-current) "Internal: search forward TIMES for PROPERTY, call FUNCTION on last match. FUNCTION receives two arguments: the prop-match object (or list for strings) @@ -376,6 +620,8 @@ TIMES is the number of searches, defaulting to 1. VALUE is the optional value to match. OBJECT can be a buffer or string; nil defaults to current buffer. START and END define the search range; defaults are object start and end. +PREDICATE and NOT-CURRENT are passed to each underlying search (see +`tp-forward'); nil PREDICATE keeps the 0.2.0 `equal' matching. FUNCTION is called only when the TIMES-th match exists; if fewer matches are available, nothing is applied. @@ -386,7 +632,10 @@ Returns the number of matches found (at most TIMES)." ((stringp object) (let* ((start-pos (or start 0)) (end-pos (or end (length object))) - (all-matches (tp-search object property value)) + (all-matches (if (functionp predicate) + (tp--string-property-matches object property + value predicate) + (tp-search object property value))) (filtered-matches (seq-filter (lambda (m) (and (>= (car m) start-pos) (<= (cadr m) end-pos))) @@ -408,7 +657,10 @@ Returns the number of matches found (at most TIMES)." (save-excursion (goto-char search-start) (dotimes (i count) - (when-let ((match (tp-search-forward property value t))) + (when-let ((match (text-property-search-forward + property value + (if (functionp predicate) predicate t) + not-current))) (when (<= (prop-match-end match) search-end) (when (= i (1- count)) (funcall function match buf)) @@ -483,8 +735,14 @@ length-changing replacements" new-text (length new-text) len)) (goto-char m-start) (insert new-text))))))) -(defun tp-forward-do (function property &optional value object times start end) - "Search forward for text with PROPERTY and apply FUNCTION to the last match. +(defun tp-forward-do (function property &optional value object times + start end predicate not-current) + "Search forward TIMES times for PROPERTY; apply FUNCTION at the Nth match. + +Despite the -do suffix this is NOT a for-each: the search advances +through TIMES matches and FUNCTION is applied only to the final +\(TIMES-th) one. Use `tp-search-map' to apply a function to EVERY +match. FUNCTION receives (TEXT &optional START END) where TEXT is the matched text, START and END are the positions of the match. The return value of FUNCTION @@ -497,6 +755,13 @@ OBJECT can be a buffer or string; nil defaults to current buffer. TIMES is the number of searches, defaulting to 1. The function searches TIMES times but only applies FUNCTION to the last (Nth) match found. START and END define the search range; defaults are object start and end. +PREDICATE customizes matching: nil (the default) and t both keep the +0.2.0 contract where a region matches when its PROPERTY value is +`equal' to VALUE; a function is called with VALUE and the region's +PROPERTY value and matches when it returns non-nil. +NOT-CURRENT is passed to each underlying +`text-property-search-forward' call; it only applies to the buffer +path (strings have no point). Returns the number of successful matches. @@ -523,9 +788,10 @@ Example: (tp--forward-do (lambda (match obj) (tp--replace-match-text function arity match obj)) - property value object times start end))) + property value object times start end predicate not-current))) -(defun tp--backward-do (function property &optional value object times start end) +(defun tp--backward-do (function property &optional value object times + start end predicate not-current) "Internal: search backward TIMES for PROPERTY, call FUNCTION on last match. FUNCTION receives two arguments: the prop-match object (or list for strings) @@ -534,6 +800,8 @@ TIMES is the number of searches, defaulting to 1. VALUE is the optional value to match. OBJECT can be a buffer or string; nil defaults to current buffer. START and END define the search range; defaults are object start and end. +PREDICATE and NOT-CURRENT are passed to each underlying search (see +`tp-backward'); nil PREDICATE keeps the 0.2.0 `equal' matching. FUNCTION is called only when the TIMES-th match exists; if fewer matches are available, nothing is applied. @@ -544,7 +812,10 @@ Returns the number of matches found (at most TIMES)." ((stringp object) (let* ((start-pos (or start 0)) (end-pos (or end (length object))) - (all-matches (tp-search object property value)) + (all-matches (if (functionp predicate) + (tp--string-property-matches object property + value predicate) + (tp-search object property value))) (filtered-matches (seq-filter (lambda (m) (and (>= (car m) start-pos) @@ -565,16 +836,24 @@ Returns the number of matches found (at most TIMES)." (save-excursion (goto-char search-end) (dotimes (i count) - ;; `equal' matching, same as tp--forward-do's predicate t. - (when-let ((match (tp--property-search-backward property value))) + ;; `equal' matching by default, same as tp--forward-do's + ;; predicate t. + (when-let ((match (tp--property-search-backward + property value predicate not-current))) (when (>= (prop-match-beginning match) search-start) (when (= i (1- count)) (funcall function match buf)) (cl-incf matches))))))) matches))))) -(defun tp-backward-do (function property &optional value object times start end) - "Search backward for text with PROPERTY and apply FUNCTION to the last match. +(defun tp-backward-do (function property &optional value object times + start end predicate not-current) + "Search backward TIMES times for PROPERTY; apply FUNCTION at the Nth match. + +Despite the -do suffix this is NOT a for-each: the search walks back +through TIMES matches and FUNCTION is applied only to the final +\(TIMES-th) one. Use `tp-search-map' to apply a function to EVERY +match. FUNCTION receives (TEXT &optional START END) where TEXT is the matched text, START and END are the positions of the match. The return value of FUNCTION @@ -587,6 +866,13 @@ OBJECT can be a buffer or string; nil defaults to current buffer. TIMES is the number of searches, defaulting to 1. The function searches TIMES times but only applies FUNCTION to the last (Nth) match found. START and END define the search range; defaults are object start and end. +PREDICATE customizes matching: nil (the default) and t both keep the +0.2.0 contract where a region matches when its PROPERTY value is +`equal' to VALUE; a function is called with VALUE and the region's +PROPERTY value and matches when it returns non-nil. +NOT-CURRENT, when non-nil, skips a matching region containing point +on each underlying search; it only applies to the buffer path +\(strings have no point). Returns the number of successful matches. @@ -613,7 +899,7 @@ Example: (tp--backward-do (lambda (match obj) (tp--replace-match-text function arity match obj)) - property value object times start end))) + property value object times start end predicate not-current))) (defun tp-search (start-or-string &optional end-or-property property-or-value value object) diff --git a/tp-stack-tests.el b/tp-stack-tests.el index 33da75f..8e11f3d 100644 --- a/tp-stack-tests.el +++ b/tp-stack-tests.el @@ -379,5 +379,886 @@ definitions cannot leak between tests." (should-error (tp-push-layer nil 'layer1)) (should-error (tp-delete-layer 'not-a-position 5 'layer1)))) +;;; 0.3.0 S1: layer visibility (tp-hide-layer / tp-show-layer) + +(ert-deftest tp-stack-test-hide-top-reveals-next-visible () + "Hiding the top layer renders the next visible layer's properties." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp lower () '(face bold)) + (define-tp upper () '(face italic)) + (tp-push-layer 1 6 'lower) + (tp-push-layer 1 6 'upper) + (should (= (tp-hide-layer 1 6 'upper) 1)) + ;; The text now renders the lower layer. + (should (eq (get-text-property 1 'face) 'bold)) + (should (eq (get-text-property 1 'tp-name) 'lower)) + ;; The hidden layer is still in the stack for the queries. + (should (= (tp-layer-count 1 6) 2)) + (should (equal (tp-layer-list 1 6) '(upper lower))) + (should (tp-layer-exists-p 1 6 'upper)))) + +(ert-deftest tp-stack-test-show-restores-hidden-top () + "Showing a hidden top layer restores its properties onto the text." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp lower () '(face bold)) + (define-tp upper () '(face italic)) + (tp-push-layer 1 6 'lower) + (tp-push-layer 1 6 'upper) + (tp-hide-layer 1 6 'upper) + (should (= (tp-show-layer 1 6 'upper) 1)) + (should (eq (get-text-property 1 'face) 'italic)) + (should (eq (get-text-property 1 'tp-name) 'upper)) + ;; No bookkeeping flag leaks into the rendered properties. + (should-not (tp-stack-tests--has-prop-p 1 'tp-hidden)))) + +(ert-deftest tp-stack-test-hide-all-layers-contract () + "With every layer hidden only the tp-layers bookkeeping remains." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp lower () '(face bold)) + (define-tp upper () '(face italic)) + (tp-push-layer 1 6 'lower) + (tp-push-layer 1 6 'upper) + (should (= (tp-hide-layer 1 6 'upper) 1)) + (should (= (tp-hide-layer 1 6 'lower) 1)) + ;; No layer props render, not even tp-name. + (should (null (get-text-property 1 'face))) + (should (null (get-text-property 1 'tp-name))) + (should (tp-stack-tests--has-prop-p 1 'tp-layers)) + ;; The whole stack stays queryable. + (should (= (tp-layer-count 1 6) 2)) + (should (equal (tp-layer-list 1 6) '(upper lower))) + ;; Showing one layer again renders it. + (should (= (tp-show-layer 1 6 'lower) 1)) + (should (eq (get-text-property 1 'face) 'bold)) + (should (eq (get-text-property 1 'tp-name) 'lower)))) + +(ert-deftest tp-stack-test-hide-missing-name-is-silent-noop () + "Hiding or showing a non-existent layer returns 0 without signaling." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp layer1 () '(face bold)) + (tp-push-layer 1 6 'layer1) + (let ((before (text-properties-at 1))) + (should (= (tp-hide-layer 1 6 'nope) 0)) + (should (= (tp-show-layer 1 6 'nope) 0)) + (should (equal (text-properties-at 1) before))))) + +(ert-deftest tp-stack-test-hide-already-hidden-returns-zero () + "Hiding an already-hidden layer (or showing a visible one) counts 0." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp lower () '(face bold)) + (define-tp upper () '(face italic)) + (tp-push-layer 1 6 'lower) + (tp-push-layer 1 6 'upper) + (should (= (tp-show-layer 1 6 'upper) 0)) ; visible already + (should (= (tp-hide-layer 1 6 'upper) 1)) + (should (= (tp-hide-layer 1 6 'upper) 0)) ; hidden already + (should (eq (get-text-property 1 'face) 'bold)))) + +(ert-deftest tp-stack-test-hide-string-forms () + "Whole-string and region-on-string forms of hide/show work 0-based." + (tp-stack-tests--with-env + (let ((str (copy-sequence "abcdef"))) + (define-tp lower () '(face bold)) + (define-tp upper () '(face italic)) + (tp-push-layer str 'lower) + (tp-push-layer str 'upper) + (should (= (tp-hide-layer str 'upper) 1)) + (should (eq (get-text-property 0 'tp-name str) 'lower)) + (should (= (tp-show-layer 0 6 'upper str) 1)) + (should (eq (get-text-property 0 'tp-name str) 'upper)) + ;; Region form only touches [2, 5). + (should (= (tp-hide-layer 2 5 'upper str) 1)) + (should (eq (get-text-property 0 'tp-name str) 'upper)) + (should (eq (get-text-property 2 'tp-name str) 'lower)) + (should (eq (get-text-property 5 'tp-name str) 'upper))))) + +(ert-deftest tp-stack-test-show-layer-above-visible-top () + "Showing a hidden layer above the visible top makes it render again." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (define-tp lc () '(face underline)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-push-layer 1 6 'lc) + (tp-hide-layer 1 6 'lc) + (tp-hide-layer 1 6 'lb) + (should (eq (get-text-property 1 'tp-name) 'la)) + ;; lc sits above the visible top (la); showing it wins again. + (should (= (tp-show-layer 1 6 'lc) 1)) + (should (eq (get-text-property 1 'tp-name) 'lc)) + (should (eq (get-text-property 1 'face) 'underline)))) + +(ert-deftest tp-stack-test-hidden-layer-can-be-raised () + "A hidden layer can be moved in the stack and shown later." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-hide-layer 1 6 'la) ; hide the bottom layer + (should (= (tp-raise-layer 1 6 'la 1) 1)) + ;; la is now on top but hidden, so lb still renders. + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lb))) + (should (eq (get-text-property 1 'tp-name) 'lb)) + (should (= (tp-show-layer 1 6 'la) 1)) + (should (eq (get-text-property 1 'tp-name) 'la)) + (should (eq (get-text-property 1 'face) 'bold)))) + +(ert-deftest tp-stack-test-hide-show-roundtrip-restores-storage () + "A hide/show roundtrip restores the exact original properties." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp layer1 () '(face bold)) + (tp-push-layer 1 6 'layer1) + (let ((before (text-properties-at 1))) + (tp-hide-layer 1 6 'layer1) + ;; All layers hidden: only bookkeeping remains. + (should (null (get-text-property 1 'tp-name))) + (tp-show-layer 1 6 'layer1) + (should (equal (text-properties-at 1) before)) + (should-not (tp-stack-tests--has-prop-p 1 'tp-layers))))) + +(ert-deftest tp-stack-test-flatten-drops-tp-hidden-flag () + "Flattening a stack with a hidden layer never leaks the tp-hidden flag. +HID-2: the hidden layer's props are discarded entirely, so the +flattened result renders the visible layer's face, not the hidden +one's." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp lower () '(face bold)) + (define-tp upper () '(face italic)) + (tp-push-layer 1 6 'lower) + (tp-push-layer 1 6 'upper) + (tp-hide-layer 1 6 'upper) + (should (= (tp-flatten-layers 1 6 'flat) 1)) + (should (eq (get-text-property 1 'tp-name) 'flat)) + (should-not (tp-stack-tests--has-prop-p 1 'tp-hidden)) + (should-not (tp-stack-tests--has-prop-p 1 'tp-layers)) + ;; The visible layer's face renders; the hidden italic is gone. + (should (eq (get-text-property 1 'face) 'bold)))) + +;;; HID-2: flatten/merge must not render hidden layers' properties + +(ert-deftest tp-stack-test-flatten-discards-hidden-layer-props () + "Flatten discards a hidden layer's props instead of rendering them. +Probe scenario A: red (hidden, with help-echo) over green over blue +\(with mouse-face); the flattened result must show green and keep +blue's mouse-face, with no trace of the hidden red layer." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp tp-st-h2-red () '(face (:foreground "red") help-echo "red")) + (define-tp tp-st-h2-green () '(face (:foreground "green"))) + (define-tp tp-st-h2-blue () '(face (:foreground "blue") + mouse-face highlight)) + (tp-push-layer 1 6 'tp-st-h2-blue) + (tp-push-layer 1 6 'tp-st-h2-green) + (tp-push-layer 1 6 'tp-st-h2-red) ; top->bottom: red green blue + (tp-hide-layer 1 6 'tp-st-h2-red) + (should (equal (get-text-property 1 'face) '(:foreground "green"))) + (should (= (tp-flatten-layers 1 6 'flat) 1)) + (should (equal (get-text-property 1 'face) '(:foreground "green"))) + (should-not (tp-stack-tests--has-prop-p 1 'help-echo)) + (should (eq (get-text-property 1 'mouse-face) 'highlight)))) + +(ert-deftest tp-stack-test-flatten-all-hidden-yields-bare-text () + "Flattening a run whose every layer is hidden clears all properties. +Consistent with the all-hidden rendering of `tp-hide-layer'; the run +still counts as modified in the returned count." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp tp-st-h2a-one () '(face bold)) + (define-tp tp-st-h2a-two () '(face italic)) + (tp-push-layer 1 6 'tp-st-h2a-one) + (tp-push-layer 1 6 'tp-st-h2a-two) + (tp-hide-layer 1 6 'tp-st-h2a-one) + (tp-hide-layer 1 6 'tp-st-h2a-two) + (should (= (tp-flatten-layers 1 6 'flat) 1)) + (should (null (text-properties-at 1))))) + +(ert-deftest tp-stack-test-merge-excludes-hidden-layer-props () + "Merging a hidden layer with a visible one excludes the hidden props. +Probe scenario B: merging hidden red with visible green removes both +from the stack but the merged layer renders green - a merge must +never un-hide what `tp-hide-layer' hid." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp tp-st-h2b-red () '(face (:foreground "red"))) + (define-tp tp-st-h2b-green () '(face (:foreground "green"))) + (define-tp tp-st-h2b-blue () '(face (:foreground "blue"))) + (tp-push-layer 1 6 'tp-st-h2b-blue) + (tp-push-layer 1 6 'tp-st-h2b-green) + (tp-push-layer 1 6 'tp-st-h2b-red) + (tp-hide-layer 1 6 'tp-st-h2b-red) + (should (= (tp-merge-layers 1 6 'merged '(tp-st-h2b-red tp-st-h2b-green)) + 1)) + (should (equal (get-text-property 1 'face) '(:foreground "green"))) + (should (eq (get-text-property 1 'tp-name) 'merged)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) + '(merged tp-st-h2b-blue))))) + +(ert-deftest tp-stack-test-merge-all-hidden-stays-hidden () + "Merging only hidden layers produces a hidden merged layer. +The merged layer keeps the hidden layers' merged props (data is +preserved) but carries tp-hidden itself, so nothing starts rendering; +`tp-show-layer' can reveal it later." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp tp-st-h2c-red () '(face (:foreground "red"))) + (define-tp tp-st-h2c-green () '(face (:foreground "green"))) + (define-tp tp-st-h2c-blue () '(face (:foreground "blue"))) + (tp-push-layer 1 6 'tp-st-h2c-blue) + (tp-push-layer 1 6 'tp-st-h2c-green) + (tp-push-layer 1 6 'tp-st-h2c-red) + (tp-hide-layer 1 6 'tp-st-h2c-red) + (tp-hide-layer 1 6 'tp-st-h2c-green) + (should (= (tp-merge-layers 1 6 'merged + '(tp-st-h2c-red tp-st-h2c-green)) + 1)) + ;; The merged layer does not render: blue stays visible. + (should (equal (get-text-property 1 'face) '(:foreground "blue"))) + ;; It is present, hidden, and carries the merged (red-wins) props. + (let ((entry (assq 'merged (tp-layer-stack-at 1)))) + (should entry) + (should (eq (plist-get (cdr entry) 'tp-hidden) t)) + (should (equal (plist-get (cdr entry) 'face) '(:foreground "red")))) + ;; Showing the merged layer renders it. + (tp-show-layer 1 6 'merged) + (should (equal (get-text-property 1 'face) '(:foreground "red"))))) + +;;; HID2-RET: merge/flatten return modified-run counts + +(ert-deftest tp-stack-test-merge-and-flatten-return-counts () + "tp-merge-layers / tp-flatten-layers return modified-run counts. +Counting matches `tp-delete-layer': one per rewritten run, 0 when +nothing matched." + (tp-stack-tests--with-env + (insert "abcdefghij") + (define-tp tp-st-ret-a () '(face bold)) + (define-tp tp-st-ret-b () '(face italic)) + ;; Two separate runs with different stacks. + (tp-push-layer 1 4 'tp-st-ret-a) + (tp-push-layer 1 4 'tp-st-ret-b) + (tp-push-layer 5 8 'tp-st-ret-a) + ;; Merge matches both layers in run 1, only one in run 2: both + ;; runs are rewritten. + (should (= (tp-merge-layers 1 8 'm '(tp-st-ret-a tp-st-ret-b)) 2)) + ;; Nothing matches on bare text. + (should (= (tp-merge-layers 8 11 'm2 '(tp-st-ret-a)) 0)) + ;; Flatten counts every run that had layers ([1,4) and [5,8) are + ;; separated by bare text); bare text does not count. + (should (= (tp-flatten-layers 1 8 'flat) 2)) + (should (= (tp-flatten-layers 8 11 'flat2) 0)))) + +;;; 0.3.0 S2: tp-lower-layer and extended tp-rotate-layer + +(ert-deftest tp-stack-test-lower-layer-moves-down () + "Lowering by 1 swaps the layer with the one below it." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (define-tp lc () '(face underline)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-push-layer 1 6 'lc) ; top->bottom: lc lb la + (should (= (tp-lower-layer 1 6 'lc 1) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb lc la))) + (should (eq (get-text-property 1 'tp-name) 'lb)))) + +(ert-deftest tp-stack-test-lower-layer-mirrors-raise () + "Lowering then raising by the same N restores the stack order." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (define-tp lc () '(face underline)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-push-layer 1 6 'lc) + (let ((before (mapcar #'car (tp-layer-stack-at 1)))) + (tp-lower-layer 1 6 'lc 2) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc))) + (tp-raise-layer 1 6 'lc 2) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) before))))) + +(ert-deftest tp-stack-test-lower-layer-clamps-and-negates () + "Lowering clamps at the bottom; a negative N raises instead." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (define-tp lc () '(face underline)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-push-layer 1 6 'lc) + (should (= (tp-lower-layer 1 6 'lc 99) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc))) + (should (= (tp-lower-layer 1 6 'lc -2) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la))))) + +(ert-deftest tp-stack-test-lower-layer-defaults-and-index () + "N defaults to 1 and integer indexes address the stack (0 = top)." + (tp-stack-tests--with-env + (let ((str (copy-sequence "abcdef"))) + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (tp-push-layer str 'la) + (tp-push-layer str 'lb) ; top->bottom: lb la + (should (= (tp-lower-layer str 0) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb))) + (should (eq (get-text-property 0 'tp-name str) 'la))))) + +(ert-deftest tp-stack-test-lower-layer-missing-returns-zero () + "Lowering a non-existent layer is a silent no-op returning 0." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (tp-push-layer 1 6 'la) + (let ((before (text-properties-at 1))) + (should (= (tp-lower-layer 1 6 'nope 1) 0)) + (should (equal (text-properties-at 1) before))))) + +(ert-deftest tp-stack-test-rotate-layer-default-unchanged () + "With no new arguments rotate still moves the top layer to bottom." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (define-tp lc () '(face underline)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-push-layer 1 6 'lc) ; top->bottom: lc lb la + (should (= (tp-rotate-layer 1 6) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc))) + (should (eq (get-text-property 1 'tp-name) 'lb)))) + +(ert-deftest tp-stack-test-rotate-layer-up-inverts-down () + "Rotating up moves the bottom layer to the top; up undoes down." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (define-tp lc () '(face underline)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-push-layer 1 6 'lc) + (should (= (tp-rotate-layer 1 6 nil 'up) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb))) + (should (= (tp-rotate-layer 1 6 nil 'down) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la))))) + +(ert-deftest tp-stack-test-rotate-layer-count-and-wraparound () + "COUNT rotates several steps; a full cycle restores the order." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (define-tp lc () '(face underline)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-push-layer 1 6 'lc) + (should (= (tp-rotate-layer 1 6 nil 'down 2) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb))) + (should (= (tp-rotate-layer 1 6 nil 'up 2) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la))) + (should (= (tp-rotate-layer 1 6 nil 'down 3) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la))))) + +(ert-deftest tp-stack-test-rotate-layer-string-form-direction () + "String form accepts DIRECTION and COUNT right after the string." + (tp-stack-tests--with-env + (let ((str (copy-sequence "abcdef"))) + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (tp-push-layer str 'la) + (tp-push-layer str 'lb) ; top->bottom: lb la + (should (= (tp-rotate-layer str 'up) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb))) + (should (= (tp-rotate-layer str 'down 1) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(lb la)))))) + +(ert-deftest tp-stack-test-rotate-layer-edge-arguments () + "Invalid DIRECTION signals; COUNT below 1 and bare text return 0." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (tp-push-layer 1 4 'la) + (should-error (tp-rotate-layer 1 4 nil 'sideways)) + (should (= (tp-rotate-layer 1 4 nil 'down 0) 0)) + (should (= (tp-rotate-layer 4 6) 0)) + (should (eq (get-text-property 1 'tp-name) 'la)))) + +;;; API-ARG-01: canonical (START END DIRECTION COUNT OBJECT) rotate order + +(ert-deftest tp-stack-test-rotate-layer-canonical-order () + "The canonical order needs no nil OBJECT placeholder." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (define-tp lc () '(face underline)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-push-layer 1 6 'lc) ; top->bottom: lc lb la + (should (= (tp-rotate-layer 1 6 'up) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb))) + (should (= (tp-rotate-layer 1 6 'down) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la))) + ;; COUNT rides fourth in the canonical order. + (should (= (tp-rotate-layer 1 6 'down 2) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb))) + (should (= (tp-rotate-layer 1 6 'up 2) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la))))) + +(ert-deftest tp-stack-test-rotate-layer-canonical-order-object-last () + "OBJECT rides last in the canonical order (buffer and string)." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) ; top->bottom: lb la + (let ((buf (current-buffer))) + (with-temp-buffer ; a different current buffer + (should (= (tp-rotate-layer 1 6 'up 1 buf) 1)))) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lb))) + ;; nil COUNT in the canonical order still defaults to 1. + (let ((buf (current-buffer))) + (with-temp-buffer + (should (= (tp-rotate-layer 1 6 'down nil buf) 1)))) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la))) + ;; A string OBJECT in the canonical order's last slot. + (let ((str (copy-sequence "xyz"))) + (tp-push-layer str 'la) + (tp-push-layer str 'lb) + (should (= (tp-rotate-layer 0 3 'up 1 str) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb)))))) + +(ert-deftest tp-stack-test-rotate-layer-legacy-order-still-works () + "The legacy (START END OBJECT DIRECTION COUNT) order keeps working. +A non-up/down third argument - nil, a buffer or a string - still +selects the legacy order." + (tp-stack-tests--with-env + (let ((str (copy-sequence "abcdef"))) + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (tp-push-layer str 'la) + (tp-push-layer str 'lb) ; top->bottom: lb la + (should (= (tp-rotate-layer 0 6 str 'up 1) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb)))) + (insert "abcdef") + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (should (= (tp-rotate-layer 1 6 nil 'up 1) 1)) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lb))) + ;; Canonical-order direction errors still signal. + (should-error (tp-rotate-layer 1 6 'sideways)))) + +;;; 0.3.0 S3: tp-layer-stack-at + +(ert-deftest tp-stack-test-layer-stack-at-shape () + "The stack at a position is (NAME . PROPS) conses, top first." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (should (equal (tp-layer-stack-at 1) + '((lb . (face italic)) + (la . (face bold))))))) + +(ert-deftest tp-stack-test-layer-stack-at-hidden-marker () + "Hidden layers carry a tp-hidden t entry in their PROPS." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (tp-hide-layer 1 6 'lb) + (let ((stack (tp-layer-stack-at 1))) + (should (equal (mapcar #'car stack) '(lb la))) + (should (eq (plist-get (cdr (nth 0 stack)) 'tp-hidden) t)) + (should-not (plist-member (cdr (nth 1 stack)) 'tp-hidden))))) + +(ert-deftest tp-stack-test-layer-stack-at-string-positions () + "String positions are 0-based; outside the layer the stack is nil." + (tp-stack-tests--with-env + (let ((str (copy-sequence "abcdef"))) + (define-tp la () '(face bold)) + (tp-put-layer 2 5 'la 0 str) + (should (null (tp-layer-stack-at 0 str))) + (should (equal (tp-layer-stack-at 2 str) '((la . (face bold))))) + (should (null (tp-layer-stack-at 5 str)))))) + +(ert-deftest tp-stack-test-layer-stack-at-unnamed-and-bare () + "Unnamed layers report a nil NAME; bare text reports nil." + (tp-stack-tests--with-env + (insert "abcdef") + (tp-push-layer 1 4 '(face bold)) + (should (equal (tp-layer-stack-at 1) '((nil . (face bold))))) + (should (null (tp-layer-stack-at 5))))) + +;;; 0.3.0 S4: modified-interval counts and NOERROR + +(ert-deftest tp-stack-test-delete-layer-returns-run-count () + "Delete returns how many property runs matched; 0 when none did." + (tp-stack-tests--with-env + (insert "abcdefghij") + (define-tp la () '(face bold)) + (tp-push-layer 1 4 'la) + (tp-push-layer 6 9 'la) + (should (= (tp-delete-layer 1 9 'nope) 0)) + (should (= (tp-delete-layer 1 9 'la) 2)) + (should-not (tp-layer-exists-p 1 9 'la)))) + +(ert-deftest tp-stack-test-pop-layer-returns-run-count () + "Pop returns the number of runs that had a layer to pop." + (tp-stack-tests--with-env + (let ((str (copy-sequence "abcdef"))) + (define-tp la () '(face bold)) + (tp-put-layer 0 3 'la 0 str) + (should (= (tp-pop-layer 0 6 str) 1)) + (should (= (tp-pop-layer 0 6 str) 0))))) + +(ert-deftest tp-stack-test-movement-ops-return-run-counts () + "Move, raise, pin and switch return matched-run counts." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (define-tp lb () '(face italic)) + (tp-push-layer 1 6 'la) + (tp-push-layer 1 6 'lb) + (should (= (tp-raise-layer 1 6 'nope 1) 0)) + (should (= (tp-raise-layer 1 6 'la 1) 1)) + (should (= (tp-pin-layer 1 6 'lb) 1)) + (should (= (tp-move-layer 1 6 'la 0) 1)) + (should (= (tp-move-layer 1 6 'nope 0) 0)) + (should (= (tp-switch-layer 1 6 'la 'lb) 1)) + (should (= (tp-switch-layer 1 6 'la 'nope) 0)))) + +(ert-deftest tp-stack-test-put-layer-noerror () + "With NOERROR an unresolvable LAYER returns nil and writes nothing." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp la () '(face bold)) + (should-error (tp-put-layer 1 6 'undefined-x 0)) + (should (null (tp-put-layer 1 6 'undefined-x 0 nil t))) + (should (null (text-properties-at 1))) + ;; A resolvable layer with NOERROR still applies normally. + (should (tp-put-layer 1 6 'la 0 nil t)) + (should (eq (get-text-property 1 'tp-name) 'la)))) + +(ert-deftest tp-stack-test-push-layer-noerror-both-forms () + "NOERROR works for push in region and string forms." + (tp-stack-tests--with-env + (let ((str (copy-sequence "abcdef"))) + (define-tp la () '(face bold)) + (should-error (tp-push-layer str 'undefined-x)) + (should (null (tp-push-layer str 'undefined-x t))) + (should (null (tp-put-layer str 'undefined-x 0 t))) + (should (null (text-properties-at 0 str))) + ;; The string form still returns the string on success. + (should (eq (tp-push-layer str 'la t) str)) + (should (eq (get-text-property 0 'tp-name str) 'la))) + (insert "abcdef") + (should (null (tp-push-layer 1 6 'undefined-x nil t))) + (should (null (text-properties-at 1))))) + +;;; Multi-argument parameterized specs through tp-put-layer + +(ert-deftest tp-stack-test-put-layer-multiarg-layer-flat () + "tp-put-layer accepts flat (LAYER ARG1 ARG2) for a 2-arity layer." + (tp-layer-reset) + (define-tp tp-st-colors (fg bg) + `(face (:foreground ,fg :background ,bg))) + (with-temp-buffer + (insert "Hello") + (tp-put-layer 1 5 '(tp-st-colors "red" "blue") 0) + (should (equal (tp-at 1 'face) + '(:foreground "red" :background "blue"))))) + +(ert-deftest tp-stack-test-put-layer-multiarg-layer-wrapped () + "tp-put-layer accepts wrapped (LAYER (ARG1 ARG2)) for a 2-arity layer." + (tp-layer-reset) + (define-tp tp-st-colors2 (fg bg) + `(face (:foreground ,fg :background ,bg))) + (with-temp-buffer + (insert "Hello") + (tp-put-layer 1 5 '(tp-st-colors2 ("green" "black")) 0) + (should (equal (tp-at 1 'face) + '(:foreground "green" :background "black"))))) + +(ert-deftest tp-stack-test-put-layer-multiarg-layer-symbol-args () + "Multi-arg specs are not misread as a list of layer names. +Arguments that are themselves defined layer names used to be +intercepted by the list-of-specs branch." + (tp-layer-reset) + (define-tp tp-st-a () '(help-echo "a")) + (define-tp tp-st-b () '(help-echo "b")) + (define-tp tp-st-pair (x y) + `(display (,x . ,y))) + (with-temp-buffer + (insert "Hello") + (tp-put-layer 1 5 '(tp-st-pair tp-st-a tp-st-b) 0) + (should (equal (tp-at 1 'display) '(tp-st-a . tp-st-b))) + (should (null (tp-at 1 'help-echo))))) + +(ert-deftest tp-stack-test-put-layer-multiarg-group () + "tp-put-layer accepts (GROUP ARG1 ARG2) for a 2-arity group." + (tp-layer-reset) + (define-tps tp-st-duo (fg bg) + `(face (:foreground ,fg)) + `(face (:background ,bg))) + (with-temp-buffer + (insert "Hello") + (tp-put-layer 1 5 '(tp-st-duo "red" "blue") 0) + (should (equal (tp-at 1 'face) '(:foreground "red"))) + (should (= (tp-layer-count 1 5) 2)))) + +(ert-deftest tp-stack-test-remove-multiarg-layer-by-name () + "tp-remove removes a multi-arg parameterized layer's props by name. +Applied via `tp-put-layer' so the region carries the layer's +`tp-name' (the `tp-set' plist forms do not stamp `tp-name' for +parameterized layers, so name-based removal cannot see those). +The key-extraction path must bind all parameters (dummy args), +not just the first." + (tp-layer-reset) + (define-tp tp-st-colors3 (fg bg) + `(face (:foreground ,fg :background ,bg))) + (with-temp-buffer + (insert "Hello") + (tp-put-layer 1 5 '(tp-st-colors3 "red" "blue") 0) + (put-text-property 1 5 'help-echo "tip") + (should (tp-at 1 'face)) + (should (eq (tp-at 1 'tp-name) 'tp-st-colors3)) + (tp-remove 1 5 'tp-st-colors3) + (should (null (tp-at 1 'face))) + (should (equal (tp-at 1 'help-echo) "tip")))) + +;;; HID-1/XM-01: reactive updates must write through to tp-layers storage + +(defvar tp-st-xm01-a-color nil) +(defvar tp-st-xm01-b-color nil) +(defvar tp-st-xm01-c-color nil) +(defvar tp-st-xm01-rt-color nil) +(defvar tp-st-xm01-t-text nil) +(defvar tp-st-xm01-x-color nil) + +(ert-deftest tp-stack-test-reactive-update-reaches-hidden-layer () + "XM-01 A3: an update received while a layer is hidden renders after show. +The hidden layer has no direct `tp-name', so the update must find and +refresh its entry inside `tp-layers' stack storage." + (tp-stack-tests--with-env + (setq tp-st-xm01-a-color "red") + (define-tp tp-st-xm01-lay-a () + :props '(face (:foreground $tp-st-xm01-a-color))) + (insert "AAAAAA") + (tp-push-layer 1 7 'tp-st-xm01-lay-a) + (tp-hide-layer 1 7 'tp-st-xm01-lay-a) + (setq tp-st-xm01-a-color "blue") + (tp-show-layer 1 7 'tp-st-xm01-lay-a) + (should (equal (get-text-property 1 'face) '(:foreground "blue"))))) + +(ert-deftest tp-stack-test-stack-op-never-reverts-reactive-update () + "XM-01 B1-B4: stack ops rebuild from CURRENT values, never stale ones. +With another layer hidden the storage switches to full-stack mode +where `tp-layers' is authoritative; a reactive update must refresh +the stored snapshot so a no-op stack operation cannot revert the +rendered value, and re-setting the SAME value (a watcher no-op) never +needs to repair anything." + (tp-stack-tests--with-env + (setq tp-st-xm01-b-color "red") + (define-tp tp-st-xm01-lay-b () + :props '(face (:foreground $tp-st-xm01-b-color))) + (define-tp tp-st-xm01-lay-bg () '(face (:background "gray"))) + (insert "BBBBBB") + (tp-push-layer 1 7 'tp-st-xm01-lay-bg) + (tp-push-layer 1 7 'tp-st-xm01-lay-b) + (tp-hide-layer 1 7 'tp-st-xm01-lay-bg) ; -> full-stack storage mode + (setq tp-st-xm01-b-color "blue") + ;; B1: the visible reactive top renders the new value... + (should (equal (get-text-property 1 'face) '(:foreground "blue"))) + ;; ...and the stored stack snapshot agrees (write-through). + (let ((entry (assq 'tp-st-xm01-lay-b (tp-layer-stack-at 1)))) + (should (equal (plist-get (cdr entry) 'face) '(:foreground "blue")))) + ;; B2: a no-op stack operation must not revert the update. + (tp-move-layer 1 7 'tp-st-xm01-lay-b 0) + (should (equal (get-text-property 1 'face) '(:foreground "blue"))) + ;; B3: re-setting the same value is a watcher no-op; the buffer is + ;; already correct (before the fix it stayed stuck on the old value). + (setq tp-st-xm01-b-color "blue") + (should (equal (get-text-property 1 'face) '(:foreground "blue"))) + ;; B4: a third value still updates normally. + (setq tp-st-xm01-b-color "green") + (should (equal (get-text-property 1 'face) '(:foreground "green"))))) + +(ert-deftest tp-stack-test-hidden-top-round-trip-keeps-reactive-value () + "XM-01/HID-1: show+hide of an UNRELATED layer keeps the reactive value. +Static top hidden, reactive layer rendered below: after a variable +change, a show/hide round trip of the top rebuilds from storage and +must not revert the reactive layer to a stale snapshot." + (tp-stack-tests--with-env + (setq tp-st-xm01-rt-color "red") + (define-tp tp-st-xm01-lay-rt () + :props '(face (:foreground $tp-st-xm01-rt-color))) + (define-tp tp-st-xm01-lay-cover () '(face (:background "yellow"))) + (insert "Hello") + (tp-push-layer 1 6 'tp-st-xm01-lay-rt) + (tp-push-layer 1 6 'tp-st-xm01-lay-cover) + (tp-hide-layer 1 6 'tp-st-xm01-lay-cover) + (setq tp-st-xm01-rt-color "blue") + (should (equal (get-text-property 1 'face) '(:foreground "blue"))) + (tp-show-layer 1 6 'tp-st-xm01-lay-cover) + (tp-hide-layer 1 6 'tp-st-xm01-lay-cover) + (should (equal (get-text-property 1 'face) '(:foreground "blue"))))) + +(ert-deftest tp-stack-test-pop-reveals-current-reactive-value () + "XM-01 C2: a below-top reactive layer revealed by tp-pop-layer is current. +The buried layer's entry lives inside `tp-layers'; the update must +refresh it there so the reveal renders current values." + (tp-stack-tests--with-env + (setq tp-st-xm01-c-color "red") + (define-tp tp-st-xm01-lay-c () + :props '(face (:foreground $tp-st-xm01-c-color))) + (define-tp tp-st-xm01-lay-top () '(face (:foreground "black"))) + (insert "DDDDDD") + (tp-push-layer 1 7 'tp-st-xm01-lay-c) + (tp-push-layer 1 7 'tp-st-xm01-lay-top) + (setq tp-st-xm01-c-color "blue") + (tp-pop-layer 1 7) + (should (equal (get-text-property 1 'face) '(:foreground "blue"))))) + +(ert-deftest tp-stack-test-reactive-tp-text-reaches-hidden-layer () + "XM-01 T1: a reactive tp-text update reaches a hidden layer's text. +Text content is physical - hide/show toggles properties, never text - +so the model value replaces the text while the layer is hidden, and +`tp-show-layer' then renders current props over current text." + (tp-stack-tests--with-env + (setq tp-st-xm01-t-text "AAA") + (define-tp tp-st-xm01-lay-t () + :props '(tp-text $tp-st-xm01-t-text face (:foreground "purple"))) + (insert "AAA") + (tp-push-layer 1 4 'tp-st-xm01-lay-t) + (tp-hide-layer 1 4 'tp-st-xm01-lay-t) + (setq tp-st-xm01-t-text "ZZZ") + (tp-show-layer 1 4 'tp-st-xm01-lay-t) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + "ZZZ")) + (should (equal (get-text-property 1 'tp-text) "ZZZ")) + (should (equal (get-text-property 1 'face) '(:foreground "purple"))))) + +(ert-deftest tp-stack-test-mixed-visible-hidden-regions-stay-in-sync () + "XM-01 X1: visible and hidden regions of one layer both end up current. +Before the fix one buffer could render two different values of the +same variable at once (split-brain)." + (tp-stack-tests--with-env + (setq tp-st-xm01-x-color "red") + (define-tp tp-st-xm01-lay-x () + :props '(face (:foreground $tp-st-xm01-x-color))) + (insert "XXXXXXXXXX") + (tp-push-layer 1 5 'tp-st-xm01-lay-x) + (tp-push-layer 6 11 'tp-st-xm01-lay-x) + (tp-hide-layer 6 11 'tp-st-xm01-lay-x) + (setq tp-st-xm01-x-color "blue") + (tp-show-layer 6 11 'tp-st-xm01-lay-x) + (should (equal (get-text-property 1 'face) '(:foreground "blue"))) + (should (equal (get-text-property 6 'face) '(:foreground "blue"))))) + +;;; REG-1: every stack write must register its buffer in the reactive registry + +(defvar tp-st-reg1-color nil) + +(ert-deftest tp-stack-test-push-layer-registers-reactive-buffer () + "tp-push-layer in a second buffer keeps reactive updates flowing there. +Once the registry knows a layer from a `tp-set' in one buffer, a +stack-path application in another buffer must register too; before +the REG-1 fix the second buffer was silently and permanently skipped +by every later update." + (setq tp-st-reg1-color "red") + (unwind-protect + (progn + (tp-layer-reset) + (define-tp tp-st-reg1-layer () + :props '(face (:foreground $tp-st-reg1-color))) + (let ((a (generate-new-buffer " *tp-reg1-a*")) + (b (generate-new-buffer " *tp-reg1-b*"))) + (unwind-protect + (progn + (with-current-buffer a (insert "hello")) + (with-current-buffer b (insert "hello")) + (tp-set 1 6 'tp-st-reg1-layer a) ; registers A + (with-current-buffer b + (tp-push-layer 1 6 'tp-st-reg1-layer)) + ;; The registry must know BOTH buffers. + (let ((bufs (tp-reactive-layer-buffers 'tp-st-reg1-layer))) + (should (memq a bufs)) + (should (memq b bufs))) + (setq tp-st-reg1-color "blue") + (should (equal (with-current-buffer a + (get-text-property 1 'face)) + '(:foreground "blue"))) + (should (equal (with-current-buffer b + (get-text-property 1 'face)) + '(:foreground "blue"))) + ;; And the registration is permanent, not a one-shot fluke. + (setq tp-st-reg1-color "green") + (should (equal (with-current-buffer b + (get-text-property 1 'face)) + '(:foreground "green")))) + (kill-buffer a) + (kill-buffer b)))) + (tp-layer-reset) + (setq tp-st-reg1-color nil))) + +(ert-deftest tp-stack-test-stack-write-registers-buried-and-hidden-layers () + "Stack writes register every named layer of the new stack, not just the top. +A buried layer (under a fresh push) and a hidden layer arrive in the +buffer via string insertion - a path that never registers - and the +next stack write on the region must register them (REG-1; GC-1's +liveness depends on this)." + (unwind-protect + (progn + (tp-layer-reset) + (define-tp tp-st-reg1-buried () '(face bold)) + (define-tp tp-st-reg1-top () '(face italic)) + (define-tp tp-st-reg1-hidden () '(face underline)) + (let ((buf (generate-new-buffer " *tp-reg1-c*"))) + (unwind-protect + (with-current-buffer buf + ;; Propertized string insertion bypasses registration. + (insert (let ((s (copy-sequence "hello"))) + (tp-push-layer s 'tp-st-reg1-buried) + s)) + (insert (let ((s (copy-sequence " world"))) + (tp-push-layer s 'tp-st-reg1-hidden) + s)) + (should (eq (tp-reactive-layer-buffers 'tp-st-reg1-buried) + 'unknown)) + ;; Pushing a new top rewrites the stack: the buried + ;; layer below it must be registered as well. + (tp-push-layer 1 6 'tp-st-reg1-top) + (should (memq buf (tp-reactive-layer-buffers + 'tp-st-reg1-buried))) + (should (memq buf (tp-reactive-layer-buffers + 'tp-st-reg1-top))) + ;; Hiding rewrites the stack: the now-hidden layer must + ;; stay registered even though it loses its direct + ;; tp-name. + (tp-hide-layer 7 12 'tp-st-reg1-hidden) + (should (memq buf (tp-reactive-layer-buffers + 'tp-st-reg1-hidden)))) + (kill-buffer buf)))) + (tp-layer-reset))) + (provide 'tp-stack-tests) ;;; tp-stack-tests.el ends here diff --git a/tp-stack.el b/tp-stack.el index 6e32bf6..0475f22 100644 --- a/tp-stack.el +++ b/tp-stack.el @@ -12,16 +12,16 @@ ;;; Commentary: ;; Photoshop-style layer stack operations on text regions: put/push/ -;; delete/pop/move/raise/rotate/pin/switch/merge/flatten, stack queries, -;; and bulk layer property manipulation. +;; delete/pop/move/raise/lower/rotate/pin/switch/hide/show/merge/ +;; flatten, stack queries, and bulk layer property manipulation. ;;; Code: (require 'cl-lib) (require 'dash) (require 'tp-core) +(require 'tp-reactive) (require 'tp-layer) -(require 'tp-ops) ;;; Shared argument parsing and region iteration @@ -50,6 +50,12 @@ buffers)." (seq-take (cdr rest) n))) (t (error "Invalid layer arguments: %S" (cons start-or-string rest))))) +(defun tp--plist-remove (plist key) + "Return a copy of PLIST without KEY and its value. +Comparison uses `eq'. PLIST itself is not modified." + (cl-loop for (k v) on plist by #'cddr + unless (eq k key) append (list k v))) + (defun tp--stack-map-region (start end object function) "Call FUNCTION over each property run of [START, END) in OBJECT. @@ -57,7 +63,8 @@ OBJECT is a string, a buffer, or nil for the current buffer. FUNCTION receives (ABS-START ABS-END STACK): the run's bounds, clipped to [START, END) and expressed in OBJECT's native coordinates (0-based for strings, 1-based for buffers), and the run's layer stack as a list -of layer plists, top layer first (empty for bare text). +of layer plists, top layer first (empty for bare text). Hidden layers +\(see `tp-hide-layer') are included at their stack position. Returns the list of FUNCTION's non-nil results, in order. @@ -69,26 +76,25 @@ previously property-less text." (tp--map-intervals object start end (lambda (i-start i-end props) - (let* ((idx (-elem-index 'tp-layers props)) - (top (if idx - (-remove-at-indices (list idx (1+ idx)) props) - props)) - (belows (plist-get props 'tp-layers))) - (funcall function i-start i-end - (tp--layer-stack-to-list top belows))))))) + (funcall function i-start i-end + (tp--stack-props-to-list props)))))) -(defun tp--stack-build-props (layer-list) - "Build text properties from LAYER-LIST (top layer first). -Like `tp--build-layer-props', but the `tp-layers' entry is only added -when there are below-layers, so single-layer stacks do not carry a -garbage (tp-layers nil) property. Consumers must therefore tolerate -an absent `tp-layers' property (both `plist-get' and -`tp--stack-map-region' do)." - (cond - ((null layer-list) nil) - ((null (cdr layer-list)) (copy-sequence (car layer-list))) - (t (append (car layer-list) - (list 'tp-layers (cdr layer-list)))))) +(defun tp--stack-register-layers (stack object) + "Register OBJECT in the reactive buffer registry for every layer in STACK. +STACK is a list of layer plists as stored by the stack operations. +When OBJECT is a buffer or nil (the current buffer), every plist +carrying a `tp-name' - buried and hidden layers included - registers +that buffer via `tp-reactive--register-layer-buffer', so reactive +updates and the anonymous-layer GC keep seeing buffers whose layers +were written by stack mutators rather than by `tp-set'. String +OBJECTs are not registered; see `tp-reactive-layer-buffers' for that +gap. Registration is idempotent, so calling this once per rewritten +run is cheap." + (when (or (null object) (bufferp object)) + (let ((buf (or object (current-buffer)))) + (dolist (layer stack) + (when-let ((name (plist-get layer 'tp-name))) + (tp-reactive--register-layer-buffer name buf)))))) ;;; Queries @@ -140,12 +146,36 @@ Scans the region's property runs in order and returns the `tp-name' of the first top layer that has one, so bare or unnamed runs (for example before a layer that starts mid-region) do not hide layers later in the region. Returns nil when no run in the region has a -named top layer. OBJECT defaults to current buffer." +named top layer. OBJECT defaults to current buffer. + +The topmost layer is reported in stack order even when it is hidden +\(see `tp-hide-layer'); use `tp-layer-stack-at' to distinguish hidden +layers from visible ones." (car (tp--stack-map-region start end object (lambda (_abs-start _abs-end stack) (plist-get (car stack) 'tp-name))))) +(defun tp-layer-stack-at (pos &optional object) + "Return the full ordered layer stack at POS in OBJECT. + +The result is a list with one element per layer, topmost layer first +and bottommost last, where each element is a cons (NAME . PROPS): +- NAME is the layer's `tp-name' symbol, or nil for an unnamed layer. +- PROPS is the layer's property plist without its `tp-name' entry. + A hidden layer (see `tp-hide-layer') is distinguishable by the + entry `tp-hidden' with value t in PROPS; visible layers never + carry a `tp-hidden' entry. + +Hidden layers are included at their stack position. Returns nil for +bare text. POS is in OBJECT's native coordinates (0-based for +strings, 1-based for buffers). OBJECT is a string, a buffer, or nil +for the current buffer." + (mapcar (lambda (layer) + (cons (plist-get layer 'tp-name) + (tp--plist-remove layer 'tp-name))) + (tp--stack-props-to-list (text-properties-at pos object)))) + ;;; Layer spec normalization for tp-put-layer (defun tp--put-layer-specs (layer-spec) @@ -173,6 +203,40 @@ defined layer or group name); a named inline layer has odd length ;; Any other symbol: a single layer name. ((symbolp layer-spec) (list (tp--normalize-layer-spec layer-spec))) + ;; (GROUP-NAME ARG1 ... ARGN) or (GROUP-NAME (ARG1 ... ARGN)): + ;; multi-argument parameterized group (arity >= 2). Checked before + ;; the single-arg forms so the wrapped variant is not mistaken for + ;; one list-valued argument. + ((and (consp layer-spec) + (symbolp (car layer-spec)) + (proper-list-p layer-spec) + (let ((arity (length (tp--group-arglist (car layer-spec))))) + (and (>= arity 2) + (or (= (length (cdr layer-spec)) arity) + (and (= (length (cdr layer-spec)) 1) + (proper-list-p (cadr layer-spec)) + (= (length (cadr layer-spec)) arity)))))) + (let* ((arity (length (tp--group-arglist (car layer-spec)))) + (args (if (= (length (cdr layer-spec)) arity) + (cdr layer-spec) + (cadr layer-spec)))) + (tp--group-props-with-args (car layer-spec) args t))) + ;; (LAYER-NAME ARG1 ... ARGN) or (LAYER-NAME (ARG1 ... ARGN)): + ;; multi-argument parameterized layer (arity >= 2). + ((and (consp layer-spec) + (symbolp (car layer-spec)) + (proper-list-p layer-spec) + (let ((arity (length (tp-layer-arglist (car layer-spec))))) + (and (>= arity 2) + (or (= (length (cdr layer-spec)) arity) + (and (= (length (cdr layer-spec)) 1) + (proper-list-p (cadr layer-spec)) + (= (length (cadr layer-spec)) arity)))))) + (let* ((arity (length (tp-layer-arglist (car layer-spec)))) + (args (if (= (length (cdr layer-spec)) arity) + (cdr layer-spec) + (cadr layer-spec)))) + (list (tp--normalize-layer-spec (cons (car layer-spec) args))))) ;; (GROUP-NAME ARG): parameterized group. ((and (consp layer-spec) (symbolp (car layer-spec)) @@ -212,15 +276,15 @@ defined layer or group name); a named inline layer has odd length ;;; Mutators -(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object) +(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object noerror) "Set layer(s) at a specific index position. Calling conventions: 1. Buffer/string region: - (tp-put-layer START END LAYER IDX OBJECT) + (tp-put-layer START END LAYER IDX OBJECT NOERROR) 2. Entire string: - (tp-put-layer STRING LAYER IDX) + (tp-put-layer STRING LAYER IDX NOERROR) LAYER can be: - A symbol (layer name from `tp-layer-alist' or `tp-layer-groups') @@ -236,43 +300,76 @@ IDX specifies where to insert: - Other values insert at that position OBJECT defaults to current buffer for region form. Only text inside -\[START, END) is modified." +\[START, END) is modified. + +A LAYER naming an undefined layer or group normally signals an +error. If NOERROR is non-nil, return nil instead of signaling when +LAYER cannot be resolved; nothing is modified in that case. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. The returned string is +that same mutated object. + +Returns OBJECT when one was given (in particular the string in +string forms), otherwise the cons (START . END)." (pcase-let ((`(,start ,end ,obj ,layer-spec ,idx) (tp--parse-layer-args start-or-string (list end-or-layer layer-or-idx idx-or-object object) 2))) (setq idx (or idx 0)) - (let ((layers-to-add (tp--put-layer-specs layer-spec))) - (tp--stack-map-region - start end obj - (lambda (abs-start abs-end stack) - (let* ((actual-idx (if (< idx 0) - (max 0 (+ (length stack) 1 idx)) - (min idx (length stack)))) - (new-stack (append (seq-take stack actual-idx) - layers-to-add - (seq-drop stack actual-idx)))) - (set-text-properties abs-start abs-end - (tp--stack-build-props new-stack) - obj))))) - (or obj (cons start end)))) + (let* ((noerr (if (stringp start-or-string) idx-or-object noerror)) + (layers-to-add + (if noerr + (condition-case nil + (tp--put-layer-specs layer-spec) + (error 'tp--unresolved)) + (tp--put-layer-specs layer-spec)))) + (unless (eq layers-to-add 'tp--unresolved) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (let* ((actual-idx (if (< idx 0) + (max 0 (+ (length stack) 1 idx)) + (min idx (length stack)))) + (new-stack (append (seq-take stack actual-idx) + layers-to-add + (seq-drop stack actual-idx)))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj)))) + (or obj (cons start end)))))) -(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object) +(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object noerror) "Push layer(s) to the top of the layer stack. This is equivalent to (tp-put-layer ... LAYER 0 ...). Calling conventions: 1. Buffer/string region: - (tp-push-layer START END LAYER OBJECT) + (tp-push-layer START END LAYER OBJECT NOERROR) 2. Entire string: - (tp-push-layer STRING LAYER)" + (tp-push-layer STRING LAYER NOERROR) + +A LAYER naming an undefined layer or group normally signals an +error. If NOERROR is non-nil, return nil instead of signaling when +LAYER cannot be resolved; nothing is modified in that case. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. The returned string is +that same mutated object. + +Returns what `tp-put-layer' returns: OBJECT when one was given (in +particular the string in string forms), otherwise (START . END)." (pcase-let ((`(,start ,end ,obj ,layer) (tp--parse-layer-args start-or-string (list end-or-layer layer-or-object object) 1))) - (tp-put-layer start end layer 0 obj))) + (let ((noerr (if (stringp start-or-string) layer-or-object noerror))) + (tp-put-layer start end layer 0 obj noerr)))) (defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object) "Delete layer by name or index. @@ -288,20 +385,31 @@ LAYER-NAME/IDX can be: - A symbol (layer name) - An integer (layer index, 0=top, -1=bottom) -Only text inside [START, END) is modified." +Only text inside [START, END) is modified. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified. A LAYER-NAME/IDX +matching no layer never signals: unmatched runs are silently left +alone and a return value of 0 means nothing matched at all." (pcase-let ((`(,start ,end ,obj ,layer-id) (tp--parse-layer-args start-or-string (list end-or-idx idx-or-object object) 1))) - (tp--stack-map-region - start end obj - (lambda (abs-start abs-end stack) - (when-let ((found (tp--get-layer-by-idx-or-name stack layer-id))) - (set-text-properties - abs-start abs-end - (tp--stack-build-props (-remove-at (car found) stack)) - obj)))) - nil)) + (let ((count 0)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((found (tp--get-layer-by-idx-or-name stack layer-id))) + (let ((new-stack (-remove-at (car found) stack))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj)) + (setq count (1+ count))))) + count))) (defun tp-pop-layer (start-or-string &optional end-or-object object) "Pop the top layer from the layer stack. @@ -313,7 +421,14 @@ Calling conventions: (tp-pop-layer START END OBJECT) 2. Entire string: - (tp-pop-layer STRING)" + (tp-pop-layer STRING) + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified; 0 means no run in the +region had a layer to pop." (pcase-let ((`(,start ,end ,obj) (tp--parse-layer-args start-or-string (list end-or-object object) 0))) @@ -398,19 +513,30 @@ TO-IDX is the target position (integer index): Both indices refer to positions before the move. The layer at FROM-ID is removed and inserted at TO-IDX position. -OBJECT defaults to current buffer for region form." +OBJECT defaults to current buffer for region form. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified. A FROM-ID matching no +layer never signals: unmatched runs are silently left alone and a +return value of 0 means nothing matched at all." (pcase-let ((`(,start ,end ,obj ,from-id ,to-idx) (tp--parse-layer-args start-or-string (list end-or-from from-or-to to-or-object object) 2))) - (tp--stack-map-region - start end obj - (lambda (abs-start abs-end stack) - (when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx))) - (set-text-properties abs-start abs-end - (tp--stack-build-props new-stack) - obj)))) - nil)) + (let ((count 0)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj) + (setq count (1+ count))))) + count))) (defun tp-raise-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object) "Raise a layer by N positions in the stack. @@ -424,41 +550,162 @@ Calling conventions: Positive N moves the layer up (toward top/visible). Negative N moves the layer down (toward bottom). +N defaults to 1. The resulting position is clamped to the stack. Uses `tp--raise-layer-in-stack' internally, which is built on -`tp--move-layer-in-stack'." +`tp--move-layer-in-stack'. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified. An IDX/LAYER-NAME +matching no layer never signals: unmatched runs are silently left +alone and a return value of 0 means nothing matched at all." (pcase-let ((`(,start ,end ,obj ,layer-id ,n) (tp--parse-layer-args start-or-string (list end-or-idx idx-or-n n-or-object object) 2))) (setq n (or n 1)) - (tp--stack-map-region - start end obj - (lambda (abs-start abs-end stack) - (when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n))) - (set-text-properties abs-start abs-end - (tp--stack-build-props new-stack) - obj)))) - nil)) + (let ((count 0)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj) + (setq count (1+ count))))) + count))) -(defun tp-rotate-layer (start-or-string &optional end-or-object object) - "Rotate layers, moving top layer to bottom. +(defun tp-lower-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object) + "Lower a layer by N positions in the stack. + +This is the mirror image of `tp-raise-layer': lowering by N is +raising by -N. Calling conventions: 1. Buffer/string region: - (tp-rotate-layer START END OBJECT) + (tp-lower-layer START END IDX/LAYER-NAME N OBJECT) 2. Entire string: - (tp-rotate-layer STRING) + (tp-lower-layer STRING IDX/LAYER-NAME N) -Uses `tp-move-layer' internally to move layer at index 0 to index -1." - (pcase-let ((`(,start ,end ,obj) +IDX/LAYER-NAME identifies the layer: a layer name symbol or an +integer index (0 = top, negative indices count from the bottom, so +-1 = bottom). + +Positive N moves the layer down (toward bottom). +Negative N moves the layer up (toward top/visible). +N defaults to 1. The resulting position is clamped to the stack. + +OBJECT defaults to current buffer for region form. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified. An IDX/LAYER-NAME +matching no layer never signals: unmatched runs are silently left +alone and a return value of 0 means nothing matched at all." + (pcase-let ((`(,start ,end ,obj ,layer-id ,n) (tp--parse-layer-args - start-or-string (list end-or-object object) 0))) - (tp-move-layer start end 0 -1 obj))) + start-or-string + (list end-or-idx idx-or-n n-or-object object) 2))) + (setq n (or n 1)) + (tp-raise-layer start end layer-id (- n) obj))) + +(defun tp-rotate-layer (start-or-string &optional end-or-direction + direction-object-or-count + count-or-direction object-or-count) + "Rotate layers, by default moving the top layer to the bottom. + +Calling conventions: +1. Buffer/string region (canonical order, OBJECT last like the rest + of the stack family): + (tp-rotate-layer START END DIRECTION &optional COUNT OBJECT) + +2. Entire string: + (tp-rotate-layer STRING DIRECTION COUNT) + +3. Buffer/string region (legacy 0.3.0 order, kept working forever): + (tp-rotate-layer START END OBJECT DIRECTION COUNT) + +The two region orders are told apart by the third argument: the +symbols `up' and `down' are never valid OBJECTs, so a third argument +of `up'/`down' unambiguously selects the canonical order, e.g. +\(tp-rotate-layer 1 5 \\='up) - no nil OBJECT placeholder needed. +Any other third argument (a buffer, a string, or nil for the current +buffer) selects the legacy order. + +DIRECTION is `down' or nil to move the top layer to the bottom (the +historical behavior), or `up' to move the bottom layer to the top; +any other value signals an error. COUNT is the number of rotation +steps and defaults to 1; a COUNT below 1 rotates nothing. Layers +keep their relative order; hidden layers rotate with the rest of the +stack. + +OBJECT defaults to current buffer for region forms. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified; 0 means no run in the +region had layers to rotate (or COUNT was below 1)." + (let (start end obj dir cnt) + (cond + ;; Entire string form: (STRING DIRECTION COUNT). + ((stringp start-or-string) + (setq start 0 + end (length start-or-string) + obj start-or-string + dir end-or-direction + cnt direction-object-or-count)) + ((numberp start-or-string) + (setq start start-or-string + end end-or-direction) + (if (memq direction-object-or-count '(up down)) + ;; Canonical region order: (START END DIRECTION COUNT OBJECT). + (setq dir direction-object-or-count + cnt count-or-direction + obj object-or-count) + ;; Legacy region order: (START END OBJECT DIRECTION COUNT). + (setq obj direction-object-or-count + dir count-or-direction + cnt object-or-count))) + (t (error "Invalid layer arguments: %S" + (cons start-or-string + (list end-or-direction direction-object-or-count))))) + (let ((applied 0)) + (setq dir (or dir 'down) + cnt (or cnt 1)) + (unless (memq dir '(up down)) + (error "Invalid rotate direction: %S" dir)) + (when (>= cnt 1) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when stack + (let* ((len (length stack)) + (k (mod (if (eq dir 'up) (- cnt) cnt) len)) + (new-stack (append (seq-drop stack k) + (seq-take stack k)))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj) + (setq applied (1+ applied))))))) + applied))) (defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object) - "Pin a layer to the top (make it visible). + "Move layer IDX/LAYER-NAME to the top of the stack (one-shot). + +Despite the name, nothing stays pinned: this is a single move to +index 0, exactly (tp-move-layer ... IDX/LAYER-NAME 0 ...), and +nothing prevents a later `tp-push-layer' or `tp-put-layer' from +covering the moved layer again. Calling conventions: 1. Buffer/string region: @@ -467,7 +714,13 @@ Calling conventions: 2. Entire string: (tp-pin-layer STRING IDX/LAYER-NAME) -Uses `tp-move-layer' internally to move the specified layer to index 0 (top)." +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified. An IDX/LAYER-NAME +matching no layer never signals: unmatched runs are silently left +alone and a return value of 0 means nothing matched at all." (pcase-let ((`(,start ,end ,obj ,layer-id) (tp--parse-layer-args start-or-string @@ -484,19 +737,134 @@ Calling conventions: 2. Entire string: (tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2) -Uses `tp--switch-layers-in-stack' internally." +Uses `tp--switch-layers-in-stack' internally. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified. When either layer is +missing from a run's stack nothing signals: such runs are silently +left alone and a return value of 0 means nothing matched at all." (pcase-let ((`(,start ,end ,obj ,id1 ,id2) (tp--parse-layer-args start-or-string (list end-or-id1 id1-or-id2 id2-or-object object) 2))) - (tp--stack-map-region - start end obj - (lambda (abs-start abs-end stack) - (when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2))) - (set-text-properties abs-start abs-end - (tp--stack-build-props new-stack) - obj)))) - nil)) + (let ((count 0)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj) + (setq count (1+ count))))) + count))) + +(defun tp-hide-layer (start-or-string &optional end-or-name name-or-object object) + "Hide layer NAME in region from START to END without removing it. + +Calling conventions: +1. Buffer/string region: + (tp-hide-layer START END NAME OBJECT) + +2. Entire string: + (tp-hide-layer STRING NAME) + +NAME identifies the layer: a layer name symbol or an integer index +into the full stack, hidden layers included (0 = top, -1 = bottom). + +A hidden layer stays in the stack -- it still counts for +`tp-layer-count', appears in `tp-layer-list' and `tp-layer-stack-at' +and can be moved, raised or lowered -- but it no longer renders: the +text shows the properties of the topmost non-hidden layer instead. +Hiding the currently visible top layer therefore reveals the next +visible layer below it. When every layer of a run is hidden the text +keeps only the `tp-layers' bookkeeping property (so not even +`tp-name' renders) while all layers stay queryable. Use +`tp-show-layer' to make a hidden layer render again. + +Hiddenness is stored as a `tp-hidden' flag entry inside the layer's +plist in the `tp-layers' stack storage, so `tp-hidden' is a reserved +property name inside layers, like `tp-name'. + +OBJECT defaults to current buffer for region form. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified. A NAME matching no +layer never signals; runs whose match is already hidden are left +alone as well, so a return value of 0 means nothing changed." + (pcase-let ((`(,start ,end ,obj ,name) + (tp--parse-layer-args + start-or-string + (list end-or-name name-or-object object) 1))) + (let ((count 0)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((found (tp--get-layer-by-idx-or-name stack name))) + (unless (tp--stack-hidden-p (cdr found)) + (let ((new-stack (-replace-at (car found) + (append (list 'tp-hidden t) + (cdr found)) + stack))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj) + (setq count (1+ count))))))) + count))) + +(defun tp-show-layer (start-or-string &optional end-or-name name-or-object object) + "Show layer NAME in region from START to END, undoing `tp-hide-layer'. + +Calling conventions: +1. Buffer/string region: + (tp-show-layer START END NAME OBJECT) + +2. Entire string: + (tp-show-layer STRING NAME) + +NAME identifies the layer: a layer name symbol or an integer index +into the full stack, hidden layers included (0 = top, -1 = bottom). + +The layer's `tp-hidden' flag is removed. When the shown layer sits +above the currently visible top layer it becomes the rendered layer +again, restoring its properties onto the text. + +OBJECT defaults to current buffer for region form. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified. A NAME matching no +layer never signals; runs whose match is not hidden are left alone +as well, so a return value of 0 means nothing changed." + (pcase-let ((`(,start ,end ,obj ,name) + (tp--parse-layer-args + start-or-string + (list end-or-name name-or-object object) 1))) + (let ((count 0)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((found (tp--get-layer-by-idx-or-name stack name))) + (when (tp--stack-hidden-p (cdr found)) + (let ((new-stack (-replace-at (car found) + (tp--plist-remove (cdr found) + 'tp-hidden) + stack))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj) + (setq count (1+ count))))))) + count))) (defun tp--merge-layer-props (layers initial) "Merge the plists of LAYERS into the INITIAL plist and return it. @@ -505,10 +873,11 @@ LAYERS is a list of (INDEX . PROPS) conses as returned by already present in the accumulator is never overwritten, and presence is tested with `plist-member' so an explicit nil value in a higher layer shadows lower layers' values. `tp-name' keys of the merged -layers are dropped (INITIAL may seed its own)." +layers are dropped (INITIAL may seed its own), as are `tp-hidden' +bookkeeping flags (see `tp-hide-layer')." (cl-reduce (lambda (acc layer) (cl-loop for (key val) on (cdr layer) by #'cddr - unless (eq key 'tp-name) + unless (memq key '(tp-name tp-hidden)) do (unless (plist-member acc key) (setq acc (plist-put acc key val)))) acc) @@ -527,35 +896,65 @@ Calling conventions: (tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...)) Earlier layers in the list take precedence; a property explicitly set -to nil in a higher-precedence layer stays nil in the merged layer." +to nil in a higher-precedence layer stays nil in the merged layer. + +Hidden matched layers (see `tp-hide-layer') are merged away with the +rest but contribute NO properties to the merged layer, so a merge can +never render what was hidden. When EVERY matched layer of a run is +hidden, the merged layer keeps their merged properties but carries +the `tp-hidden' flag itself: the data is preserved without un-hiding +anything, and `tp-show-layer' on the merged layer renders it. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified, counting like +`tp-delete-layer': a run counts when at least one listed layer +matched and the merge rewrote it, and 0 means nothing matched at +all." (pcase-let ((`(,start ,end ,obj ,new-name ,layer-ids) (tp--parse-layer-args start-or-string (list end-or-name name-or-ids ids-or-object object) 2))) - (tp--stack-map-region - start end obj - (lambda (abs-start abs-end stack) - (let* ((layers-to-merge - (cl-loop for id in layer-ids - for found = (tp--get-layer-by-idx-or-name stack id) - when found collect found)) - ;; Sort by index (descending) to remove from end first - (sorted-layers (sort (copy-sequence layers-to-merge) - (lambda (a b) (> (car a) (car b)))))) - (when layers-to-merge - ;; Merge properties (earlier in list takes precedence) - (let ((merged-props (tp--merge-layer-props - layers-to-merge (list 'tp-name new-name))) - (new-stack stack)) - ;; Remove old layers from stack - (dolist (idx (mapcar #'car sorted-layers)) - (setq new-stack (-remove-at idx new-stack))) - ;; Add merged layer at top - (setq new-stack (cons merged-props new-stack)) - (set-text-properties abs-start abs-end - (tp--stack-build-props new-stack) - obj)))))) - nil)) + (let ((count 0)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (let* ((layers-to-merge + (cl-loop for id in layer-ids + for found = (tp--get-layer-by-idx-or-name stack id) + when found collect found)) + ;; Sort by index (descending) to remove from end first + (sorted-layers (sort (copy-sequence layers-to-merge) + (lambda (a b) (> (car a) (car b)))))) + (when layers-to-merge + ;; Merge properties (earlier in list takes precedence). + ;; Hidden layers contribute no props unless ALL matched + ;; layers are hidden, in which case the merged layer + ;; keeps their props but stays hidden itself. + (let* ((visible (seq-remove (lambda (found) + (tp--stack-hidden-p (cdr found))) + layers-to-merge)) + (merged-props + (if visible + (tp--merge-layer-props + visible (list 'tp-name new-name)) + (tp--merge-layer-props + layers-to-merge + (list 'tp-name new-name 'tp-hidden t)))) + (new-stack stack)) + ;; Remove old layers from stack + (dolist (idx (mapcar #'car sorted-layers)) + (setq new-stack (-remove-at idx new-stack))) + ;; Add merged layer at top + (setq new-stack (cons merged-props new-stack)) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj) + (setq count (1+ count))))))) + count))) (defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object) "Flatten all layers into a single layer. @@ -569,22 +968,46 @@ Calling conventions: NAME can be nil for an unnamed layer. Higher layers take precedence; a property explicitly set to nil in a higher layer stays nil in the -flattened result." +flattened result. + +Hidden layers (see `tp-hide-layer') are DISCARDED, mirroring +image-editor flatten semantics: only the visible layers' properties +merge into the flattened result, so flattening can never render what +was hidden. When EVERY layer of a run is hidden, the run's +properties are cleared entirely (bare text), consistent with the +all-hidden rendering of `tp-hide-layer'. + +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. + +Returns the number of property runs modified, counting like +`tp-delete-layer': every run that had layers to flatten counts, and +0 means no run in the region had any layers." (pcase-let ((`(,start ,end ,obj ,name) (tp--parse-layer-args start-or-string (list end-or-name name-or-object object) 1))) - (tp--stack-map-region - start end obj - (lambda (abs-start abs-end stack) - (when stack - (let ((merged-props (tp--merge-layer-props - (cl-loop for layer in stack - for i from 0 - collect (cons i layer)) - (when name (list 'tp-name name))))) - (set-text-properties abs-start abs-end merged-props obj))))) - nil)) + (let ((count 0)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when stack + ;; Hidden layers are discarded; an all-hidden run flattens + ;; to bare text. + (let* ((visible (seq-remove #'tp--stack-hidden-p stack)) + (merged-props + (when visible + (tp--merge-layer-props + (cl-loop for layer in visible + for i from 0 + collect (cons i layer)) + (when name (list 'tp-name name)))))) + (set-text-properties abs-start abs-end merged-props obj) + (when merged-props + (tp--stack-register-layers (list merged-props) obj)) + (setq count (1+ count)))))) + count))) (defun tp-add-to-layers (idx-or-layer-name-list start-or-string &optional end-or-plist plist-or-object &rest rest) "Add/merge properties to specified layers. @@ -599,6 +1022,11 @@ Properties are deeply merged (nested plists are merged, not replaced). OBJECT defaults to current buffer for region form. +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. The returned string is +that same mutated object. + Returns the modified object (string) or nil for buffer operations." (let (start end plist obj layer-ids) (setq layer-ids idx-or-layer-name-list) @@ -648,7 +1076,8 @@ Returns the modified object (string) or nil for buffer operations." (when stack (set-text-properties abs-start abs-end (tp--stack-build-props modified-stack) - obj))))) + obj) + (tp--stack-register-layers modified-stack obj))))) (if (stringp obj) obj nil))) (defun tp-add-to-all-layers (start-or-string &optional end-or-plist plist-or-object &rest rest) @@ -671,6 +1100,11 @@ OBJECT defaults to current buffer for region form. This function uses `tp-add-to-layers' internally, collecting all layer indices and passing them to add the plist to every layer. +Unlike `tp-set', the string form modifies STRING destructively (in +place) rather than returning a propertized copy: never pass a string +literal or a shared string you do not own. The returned string is +that same mutated object. + Returns the modified object (string) or nil for buffer operations." (let (start end plist obj) (cond diff --git a/tp-tests.el b/tp-tests.el index a021dee..f4c84ba 100644 --- a/tp-tests.el +++ b/tp-tests.el @@ -34,6 +34,32 @@ leak between tests regardless of how BODY exits." ,@body) (tp-layer-reset))) +;; Reactive test variables set with `setq' inside tests. They must be +;; dynamically bound (variable watchers depend on it), so plain +;; `defvar' declarations are used. +(defvar tp-test-first-name nil "Test variable for computed properties.") +(defvar tp-test-last-name nil "Test variable for computed properties.") +(defvar tp-test-full-name nil "Test variable for computed properties.") +(defvar tp-test-dc-color nil "Test variable for data+compute layer.") +(defvar tp-test-dc-first nil "Test variable for data+compute layer.") +(defvar tp-test-dc-last nil "Test variable for data+compute layer.") +(defvar tp-test-dc-full-name nil "Test variable for data+compute layer.") +(defvar tp-test-init-color nil "Test variable for initial values.") +(defvar tp-test-init-name nil "Test variable for initial values.") +(defvar tp-test-init-other nil "Test variable for initial values.") +(defvar tp-test-global-color nil "Test variable for global updates.") +(defvar tp-test-redef-color nil "Test variable for layer re-definition.") +(defvar tp-test-watch-var nil "Test variable for watch callbacks.") +(defvar tp-test-compute-src nil "Test variable for compute source.") +(defvar tp-test-compute-out nil "Test variable for compute output.") +(defvar tp-test-group-color nil "Test variable for layer groups.") +(defvar tp-test-name-part1 nil "Test variable for tp-text updates.") +(defvar tp-test-name-part2 nil "Test variable for tp-text updates.") +(defvar tp-test-batch-color nil "Test variable for batch updates.") +(defvar tp-test-fg nil "Test variable for batch foreground.") +(defvar tp-test-bg nil "Test variable for batch background.") +(defvar tp-test-amount nil "Test variable for transform updates.") + ;;; ============================================================ ;;; Basic Text Property Functions Tests ;;; ============================================================ @@ -863,7 +889,7 @@ nothing and returns the available count." (tp-set 12 17 '(marker t) str) (let ((result nil)) (tp--search-do - (lambda (match obj) + (lambda (match _obj) (push (car match) result)) 'marker nil str) (should (= (length result) 2)) @@ -878,7 +904,7 @@ nothing and returns the available count." (tp-set 13 18 '(marker t)) (let ((result nil)) (tp--search-do - (lambda (match obj) + (lambda (match _obj) (push (car match) result)) 'marker nil nil 1 18) (should (= (length result) 2)) @@ -955,7 +981,7 @@ nothing and returns the available count." (tp-set 5 8 '(marker t)) (tp-set 9 12 '(marker t)) (let ((positions nil)) - (tp-search-map (lambda (txt start end idx) + (tp-search-map (lambda (_txt start end idx) (push (list start end idx) positions) (format "[%d]" idx)) 'marker nil nil 1 12) @@ -3212,7 +3238,7 @@ text content but different properties, the properties should be updated." ;; Should contain both the plist and symbol (should (member 'bold (if (listp face-val) face-val (list face-val)))) ;; Should have foreground red - (should (or (eq face-val '(:foreground "red")) + (should (or (equal face-val '(:foreground "red")) (and (listp face-val) (cl-some (lambda (f) (and (listp f) diff --git a/tp.el b/tp.el index 54d67d3..9678396 100644 --- a/tp.el +++ b/tp.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2024-2026 Geekinney -;; Version: 0.2.0 +;; Version: 0.3.0 ;; Keywords: convenience text-properties ;; Author: Geekinney (kinneyzhang666@gmail.com) ;; Package-Requires: ((emacs "28.1") (dash "2.19.1"))