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

Fix confirmed bugs in layer, stack, search, and reactive-render modules

Browse Source 
35 fixes across tp-layer.el, tp-stack.el, tp-search.el, tp-reactive.el
and tp-render.el, each empirically reproduced before and after:
layer-definition resolution/cycles/copying/cleanup, clipped region-local
stack mutators, symmetric backward search matching, length-changing
replacements, and reactive re-render correctness (replace-not-accumulate,
buffer-local isolation, batching union, per-interval props).

Adds four per-module regression suites (100 new tests); combined suite
is 438/438 green. tp-test-backward updated to the now-symmetric backward
matching contract it previously codified inverted. The string-vs-buffer
shortfall divergence in tp-forward-do/tp-backward-do is documented in
CHANGELOG as a known divergence rather than changed. Adds CHANGELOG.md.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
Kinneyzhang 2026-07-26 20:01:20 +08:00
parent 08b5d9aa1c
commit ceb0dfb0bc
11 changed files with 2867 additions and 878 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

199
CHANGELOG.md Normal file
View File

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

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

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

324
tp-layer.el
View File

@ -44,6 +44,45 @@ definition. When nil, redefinition only updates the registry.")
TRANSFORM-FN receives the value and returns the transformed value.
Used for tp-text transformations like formatting numbers or dates.")
(defvar tp--group-generated-layers nil
"Alist tracking layers generated by each group: (GROUP-NAME . LAYER-NAMES).
Only layers created by the group definition itself (anonymous and
named elements) are recorded here; layers merely referenced by name
are not. Used to clean up orphaned layers when a group is redefined
or undefined.")
(defvar tp--anonymous-layer-registry nil
"Alist interning anonymous reactive layers: (PROPS-SPEC . LAYER-NAME).
PROPS-SPEC is the original (unresolved) props spec passed to
`tp--resolve-props'; LAYER-NAME is the anonymous layer registered for
it. Lookup is `equal'-based, so resolving an identical spec reuses
the existing anonymous layer instead of minting a new registry entry
on every call.")
(defun tp--anonymous-layer-name-for (props)
"Return the interned anonymous layer name for reactive spec PROPS.
If an `equal' spec was registered before, reuse its layer name;
otherwise generate a fresh name via `tp--generate-anonymous-layer-name'
and record it in `tp--anonymous-layer-registry'."
(or (cdr (assoc props tp--anonymous-layer-registry))
(let ((name (tp--generate-anonymous-layer-name)))
(push (cons (copy-tree props) name) tp--anonymous-layer-registry)
name)))
(defvar tp--layer-expansion-stack nil
"Layer names currently being expanded, innermost first.
Dynamically bound during `tp-layer-props' / `tp-layer-props-with-arg'
to detect cyclic layer references.")
(defun tp--check-layer-cycle (layer-name)
"Signal a clear error if LAYER-NAME is already being expanded.
The error message names the full cycle, e.g. \"a -> b -> a\"."
(when (memq layer-name tp--layer-expansion-stack)
(error "tp: cyclic layer reference: %s"
(mapconcat #'symbol-name
(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
@ -302,6 +341,16 @@ BODY is either:
- Keyword arguments starting with :props, :data, :compute, :watch, or :transform
(reactive format - only for non-parameterized layers with $-prefixed variables)
In simple format, exactly one body form is accepted; supplying more
than one signals an error at macro-expansion time instead of silently
discarding the extra forms.
$-prefixed reactive symbols appearing in a PARAMETERIZED body do not
create reactive dependencies (parameterized layers cannot be
reactive); they are resolved to the current value of the corresponding
variable each time the layer is evaluated via
`tp-layer-props-with-arg'.
Note: NAME cannot be a built-in Emacs text property name like `face',
`display', `invisible', etc. See `tp--builtin-text-properties' for the
complete list of reserved names."
@ -321,17 +370,21 @@ complete list of reserved names."
;; Non-parameterized reactive: use tp--define-layer-internal directly
`(tp--define-layer-internal ',name ,@body))
;; Simple format (original behavior)
(let ((simple-body (car body)))
(cond
;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM)
((null arglist)
`(tp--define-layer-unified ',name nil ,simple-body))
;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM)
((and (= (length arglist) 1)
(symbolp (car arglist)))
`(tp--define-layer-unified ',name ',arglist ',simple-body))
(t
(error "define-tp ARGLIST must be empty or contain exactly one symbol")))))))
(progn
(when (cdr body)
(error "define-tp %s: simple format takes exactly one body form, got %d (use the :props keyword format to combine multiple components)"
name (length body)))
(let ((simple-body (car body)))
(cond
;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM)
((null arglist)
`(tp--define-layer-unified ',name nil ,simple-body))
;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM)
((and (= (length arglist) 1)
(symbolp (car arglist)))
`(tp--define-layer-unified ',name ',arglist ',simple-body))
(t
(error "define-tp ARGLIST must be empty or contain exactly one symbol"))))))))
(defun tp--define-layer-unified (name arglist body)
"Define a layer NAME with ARGLIST and BODY using unified structure.
@ -406,19 +459,22 @@ IDX is the index for anonymous elements.
Returns a cons cell (LAYER-NAME . PROPERTIES) or a symbol if ELEMENT
references an already-defined layer.
For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA :watch WATCH :compute COMPUTE)."
For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA
:watch WATCH :compute COMPUTE :transform TRANSFORM).
Unknown keywords in format-4 elements signal an error."
(let ((format (tp--layer-group-element-format element)))
(pcase format
('symbol element)
('format-4
;; Parse named layer with :props and optional :data/:watch/:compute
;; Parse named layer with :props and optional :data/:watch/:compute/:transform
(let* ((layer-suffix (car element))
(layer-name (intern (format "%s-%s" group-name layer-suffix)))
(rest (cdr element))
(props nil)
(data nil)
(watch nil)
(compute nil))
(compute nil)
(transform nil))
;; Parse keyword arguments
(while rest
(pcase (car rest)
@ -426,8 +482,12 @@ For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA :watch WATCH
(:data (setq data (cadr rest) rest (cddr rest)))
(:watch (setq watch (cadr rest) rest (cddr rest)))
(:compute (setq compute (cadr rest) rest (cddr rest)))
(_ (setq rest (cdr rest)))))
(list layer-name :props props :data data :watch watch :compute compute)))
(:transform (setq transform (cadr rest) rest (cddr rest)))
(unknown
(error "Unknown keyword %S in layer group element: %S"
unknown element))))
(list layer-name :props props :data data :watch watch
:compute compute :transform transform)))
('format-3
(let* ((layer-suffix (car element))
(layer-name (intern (format "%s-%s" group-name layer-suffix)))
@ -443,13 +503,22 @@ For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA :watch WATCH
(cons layer-name element)))
(_ (error "Invalid layer group element: %S" element)))))
(defun tp--define-layer-from-parsed (layer-name props data watch compute)
(defun tp--define-layer-from-parsed (layer-name props data watch compute &optional transform)
"Internal helper to define a layer from parsed components.
LAYER-NAME is the symbol name for the layer.
PROPS is the property list.
DATA is the list of data variables.
WATCH is the list of watcher definitions.
COMPUTE is the list of computed variable definitions."
COMPUTE is the list of computed variable definitions.
TRANSFORM, if non-nil, is registered in `tp-layer-transforms';
when nil, any previously registered transform for LAYER-NAME is
removed (mirroring `tp--define-layer-internal')."
;; Register or unregister transform function
(if transform
(if (assoc layer-name tp-layer-transforms)
(setcdr (assoc layer-name tp-layer-transforms) transform)
(push (cons layer-name transform) tp-layer-transforms))
(setq tp-layer-transforms (assq-delete-all layer-name tp-layer-transforms)))
(let* ((reactive-syms (tp--collect-reactive-symbols props))
(computed-vars (when compute (mapcar #'car compute)))
(all-reactive-syms (delete-dups reactive-syms))
@ -508,6 +577,7 @@ Individual layers created by the group are stored in `tp-layer-alist',
and the group itself is stored in `tp-layer-groups'."
(declare (indent defun))
(let ((layer-names nil)
(generated nil)
(idx 0))
(dolist (element elements)
(let ((parsed (tp--parse-layer-group-element name element idx)))
@ -515,25 +585,35 @@ and the group itself is stored in `tp-layer-groups'."
;; Reference to existing layer (symbol)
((symbolp parsed)
(push parsed layer-names))
;; Extended format with :data/:watch/:compute (format-4)
;; Extended format with :data/:watch/:compute/:transform (format-4)
((and (listp parsed) (plist-get (cdr parsed) :props))
(let* ((layer-name (car parsed))
(props (plist-get (cdr parsed) :props))
(data (plist-get (cdr parsed) :data))
(watch (plist-get (cdr parsed) :watch))
(compute (plist-get (cdr parsed) :compute)))
(tp--define-layer-from-parsed layer-name props data watch compute)
(push layer-name layer-names)))
(compute (plist-get (cdr parsed) :compute))
(transform (plist-get (cdr parsed) :transform)))
(tp--define-layer-from-parsed layer-name props data watch compute transform)
(push layer-name layer-names)
(push layer-name generated)))
;; Simple format (cons cell of name . props)
((consp parsed)
(let* ((layer-name (car parsed))
(props (cdr parsed)))
(tp--define-layer-from-parsed layer-name props nil nil nil)
(push layer-name layer-names)
(push layer-name generated)
;; Only increment idx for anonymous (Format 1) elements
(when (eq (tp--layer-group-element-format element) 'format-1)
(cl-incf idx)))))))
(setq layer-names (nreverse layer-names))
(setq generated (nreverse generated))
;; Undefine layers generated by a previous definition of this group
;; that are no longer part of it, so redefinition does not orphan them.
(let ((old-generated (cdr (assq name tp--group-generated-layers))))
(dolist (stale (cl-set-difference old-generated generated))
(tp-undefine-layer stale)))
(setf (alist-get name tp--group-generated-layers) generated)
(tp--set-group-layers name layer-names)
(assoc name tp-layer-groups)))
@ -554,7 +634,13 @@ 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)))
(tp-undefine-layer stale))
(setq tp--group-generated-layers
(assq-delete-all name tp--group-generated-layers))
(let ((entry (list arglist body-form)))
(if (assoc name tp-layer-groups)
(setf (cdr (assoc name tp-layer-groups)) entry)
@ -651,41 +737,47 @@ Handles two storage formats:
1. Old format (from tp--set-layer-props): (LAYER-NAME . PLIST) - flat plist
2. Unified format (from define-tp): (LAYER-NAME ARGLIST BODY-FORM)
For parameterized layers (ARGLIST non-nil), returns nil - use `tp-layer-props-with-arg'.
Recursively expands any nested layer names in the returned plist."
Recursively expands any nested layer names in the returned plist.
Signals an error naming the cycle if layer references are cyclic.
The returned plist is a fresh copy: mutating it does not affect the
stored layer definition."
(when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
(tp--check-layer-cycle layer-name)
;; Auto-include tp-name for layers with reactive deps
(let ((needs-tp-name (or include-tp-name
(let ((tp--layer-expansion-stack (cons layer-name tp--layer-expansion-stack))
(needs-tp-name (or include-tp-name
(tp--layer-has-reactive-deps-p layer-name))))
(cond
;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list
;; Check: exactly 2 elements and first is nil or a list of symbols
((and (= (length entry) 2)
(or (null (car entry))
(and (listp (car entry))
(cl-every #'symbolp (car entry)))))
(let ((arglist (car entry))
(body (cadr entry)))
(if arglist
;; Parameterized - needs argument, return nil
nil
;; Non-parameterized - evaluate body and return props
(let ((plist (eval body)))
(when plist
;; Recursively expand nested layer names
(when (tp--plist-has-layer-key-p plist)
(setq plist (tp--expand-layer-in-plist plist)))
(if needs-tp-name
(append plist (list 'tp-name layer-name))
plist))))))
;; Old format: entry is just a flat plist
(t
(let ((plist entry))
;; Recursively expand nested layer names
(when (tp--plist-has-layer-key-p plist)
(setq plist (tp--expand-layer-in-plist plist)))
(if needs-tp-name
(append plist (list 'tp-name layer-name))
plist)))))))
(copy-tree
(cond
;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list
;; Check: exactly 2 elements and first is nil or a list of symbols
((and (= (length entry) 2)
(or (null (car entry))
(and (listp (car entry))
(cl-every #'symbolp (car entry)))))
(let ((arglist (car entry))
(body (cadr entry)))
(if arglist
;; Parameterized - needs argument, return nil
nil
;; Non-parameterized - evaluate body and return props
(let ((plist (eval body)))
(when plist
;; Recursively expand nested layer names
(when (tp--plist-has-layer-key-p plist)
(setq plist (tp--expand-layer-in-plist plist)))
(if needs-tp-name
(append plist (list 'tp-name layer-name))
plist))))))
;; Old format: entry is just a flat plist
(t
(let ((plist entry))
;; Recursively expand nested layer names
(when (tp--plist-has-layer-key-p plist)
(setq plist (tp--expand-layer-in-plist plist)))
(if needs-tp-name
(append plist (list 'tp-name layer-name))
plist))))))))
(defun tp-layer-parameterized-p (layer-name)
"Return non-nil if LAYER-NAME is a parameterized layer.
@ -703,22 +795,36 @@ where ARGLIST is a non-nil list of argument symbols."
"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.
Recursively expands any nested layer names in the returned plist."
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
(let* ((arg-sym (car arglist))
(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)))
(if include-tp-name
(append plist (list 'tp-name layer-name))
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-group-props (group-name &optional include-tp-name)
"Return list of properties for all layers in GROUP-NAME.
@ -754,10 +860,64 @@ where ARGLIST is a non-nil list of argument symbols."
(not (null (car entry)))
(cl-every #'symbolp (car entry)))))
(defun tp--group-anonymous-props (plist)
"Normalize anonymous-layer PLIST from a parameterized group element.
Expands nested layer names, resolves $-prefixed reactive symbols to
their current values, and returns a fresh copy safe for caller
mutation. Returns nil if PLIST is nil."
(when plist
(let ((props plist))
(when (tp--plist-has-layer-key-p props)
(setq props (tp--expand-layer-in-plist props)))
(when (tp--collect-reactive-symbols props)
(setq props (tp--resolve-reactive-symbols props)))
(copy-tree props))))
(defun tp--group-spec-to-props (spec include-tp-name)
"Convert one evaluated parameterized-group element SPEC to a props plist.
SPEC may be:
- a symbol naming a defined layer;
- a list (LAYER-NAME ARG ...) whose head is a defined layer or group;
- a cons (\"NAME\" . PLIST) or a list (\"NAME\" :props PLIST);
- a raw property list (anonymous layer), optionally wrapped in one
extra set of parentheses as in the `define-tps' docstring example.
INCLUDE-TP-NAME is passed through for named layer references;
anonymous plists have no name, so it does not apply to them.
Returns nil if SPEC cannot be interpreted."
(cond
;; Layer name symbol
((symbolp spec)
(tp-layer-props spec include-tp-name))
((not (consp spec)) nil)
;; (LAYER-NAME ARG ...) - defined layer at the head
((and (symbolp (car spec)) (tp--is-layer-name-p (car spec)))
(let ((layer-name (car spec))
(layer-arg (cadr spec)))
(if (tp-layer-parameterized-p layer-name)
(tp-layer-props-with-arg layer-name layer-arg include-tp-name)
;; Non-parameterized layer - arg should be t or ignored
(tp-layer-props layer-name include-tp-name))))
;; ("NAME" :props PLIST) or ("NAME" . PLIST) - use the props part
((stringp (car spec))
(tp--group-anonymous-props
(if (eq (cadr spec) :props)
(caddr spec)
(cdr spec))))
;; One extra level of wrapping, e.g. ((face (:foreground "red")))
((and (consp (car spec)) (null (cdr spec)))
(tp--group-spec-to-props (car spec) include-tp-name))
;; Raw plist - anonymous layer
((symbolp (car spec))
(tp--group-anonymous-props spec))
(t nil)))
(defun tp-group-props-with-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.
Each evaluated element is a layer reference like (layer-name arg) or just layer-name.
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)
@ -769,19 +929,7 @@ Returns a list of property lists for each layer in the group."
(layer-specs (eval `(let ((,arg-sym ',arg)) ,body-form))))
;; Convert layer specs to property lists
(mapcar (lambda (spec)
(cond
;; spec is a symbol - just a layer name
((symbolp spec)
(tp-layer-props spec include-tp-name))
;; spec is (layer-name arg) - parameterized layer
((and (listp spec) (symbolp (car spec)))
(let ((layer-name (car spec))
(layer-arg (cadr spec)))
(if (tp-layer-parameterized-p layer-name)
(tp-layer-props-with-arg layer-name layer-arg include-tp-name)
;; Non-parameterized layer - arg should be t or ignored
(tp-layer-props layer-name include-tp-name))))
(t nil)))
(tp--group-spec-to-props spec include-tp-name))
layer-specs))))))
(defun tp--is-layer-name-p (sym)
@ -926,7 +1074,7 @@ For group names, includes `tp-layers' property with the full layer stack."
;; Has reactive symbols - need anonymous tp-name for reactive tracking
(let* ((existing-tp-name (plist-get props 'tp-name))
(layer-name (or existing-tp-name
(tp--generate-anonymous-layer-name)))
(tp--anonymous-layer-name-for props)))
;; Resolve reactive symbols in expanded props
(resolved-props (tp--resolve-reactive-symbols expanded-props)))
;; Register reactive dependencies
@ -958,7 +1106,7 @@ For group names, includes `tp-layers' property with the full layer stack."
;; Has reactive symbols - need anonymous tp-name for reactive tracking
(let* ((existing-tp-name (plist-get props 'tp-name))
(layer-name (or existing-tp-name
(tp--generate-anonymous-layer-name)))
(tp--anonymous-layer-name-for props)))
;; Resolve reactive symbols in expanded props
(resolved-props (tp--resolve-reactive-symbols expanded-props)))
;; Register reactive dependencies
@ -975,7 +1123,7 @@ For group names, includes `tp-layers' property with the full layer stack."
(if reactive-syms
;; Has reactive symbols - need to handle as anonymous reactive layer
(let* ((layer-name (or existing-tp-name
(tp--generate-anonymous-layer-name)))
(tp--anonymous-layer-name-for props)))
;; Resolve reactive symbols to get current values
(resolved-props (tp--resolve-reactive-symbols props)))
;; Register this anonymous layer in tp-layer-alist with resolved props
@ -1024,17 +1172,31 @@ Also resets all reactive text property watchers, dependencies, and transforms."
(tp-reactive-reset)
(setq tp-layer-alist nil)
(setq tp-layer-groups nil)
(setq tp-layer-transforms nil))
(setq tp-layer-transforms nil)
(setq tp--group-generated-layers nil)
(setq tp--anonymous-layer-registry nil))
(defun tp-undefine-layer (name)
"Remove layer NAME from `tp-layer-alist'.
Also unregisters any reactive dependencies and transforms for this layer."
Also unregisters any reactive dependencies and transforms for this layer,
and drops any anonymous-layer registry entries interned for it."
(tp--unregister-reactive-deps name)
(setq tp-layer-alist (assq-delete-all name tp-layer-alist))
(setq tp-layer-transforms (assq-delete-all name tp-layer-transforms)))
(setq tp-layer-transforms (assq-delete-all name tp-layer-transforms))
(setq tp--anonymous-layer-registry
(cl-remove-if (lambda (cell) (eq (cdr cell) name))
tp--anonymous-layer-registry)))
(defun tp-undefine-group (name)
"Remove layer group NAME from `tp-layer-groups'."
"Remove layer group NAME from `tp-layer-groups'.
Also undefines the layers that the group definition itself generated
(anonymous and named elements), including their reactive dependencies
and transforms. Layers merely referenced by the group are left
untouched."
(dolist (generated (cdr (assq name tp--group-generated-layers)))
(tp-undefine-layer generated))
(setq tp--group-generated-layers
(assq-delete-all name tp--group-generated-layers))
(setq tp-layer-groups (assq-delete-all name tp-layer-groups)))
(defun tp--normalize-layer-spec (layer-spec)

49
tp-reactive.el
View File

@ -36,12 +36,48 @@ Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).")
"Alist of data variables: (LAYER-NAME . (VAR-SYMBOL ...)).")
(defvar tp--batch-update-pending nil
"When non-nil, reactive updates are being batched.
This is a list of (LAYER-NAME . CHANGED-VARS) pairs pending update.")
"Queue of deferred reactive buffer re-renders.
Each entry is a list (LAYER-NAME CHANGED-SYMBOLS WHERE TP-TEXT-AFFECTED).
Entries are created and widened by `tp--queue-batch-update'.")
(defvar tp--batch-update-active nil
"When non-nil, we are inside a `tp-with-batch-updates' form.")
(defvar tp--reactive-updating nil
"Non-nil while a reactive update is being applied.
Used as a reentrancy guard: when a variable is set from within an
update (a computed variable being written, or the tp-text two-way
sync), the nested change still updates the variable, but its
re-render is queued in `tp--batch-update-pending' and flushed after
the outermost update completes instead of recursing.")
(defconst tp--compute-error (make-symbol "tp--compute-error")
"Sentinel distinguishing a failed compute from a legitimate nil result.
Compute functions may legitimately return nil (e.g. a boolean feeding
`invisible'), so error paths return this uninterned sentinel instead
of nil.")
(defun tp--queue-batch-update (layer-name symbol where tp-text-affected)
"Queue a deferred re-render of LAYER-NAME in `tp--batch-update-pending'.
SYMBOL is the changed variable, WHERE the buffer for buffer-local
changes (nil for global ones), TP-TEXT-AFFECTED non-nil when the
change touches the layer's `tp-text'. When the layer already has a
pending entry, the entry is widened to the union of both changes:
SYMBOL is added, TP-TEXT-AFFECTED is sticky (once set it stays set)
and WHERE widens to nil (all buffers) as soon as two changes disagree
on it."
(let ((existing (assoc layer-name tp--batch-update-pending)))
(if existing
(progn
(unless (memq symbol (nth 1 existing))
(setf (nth 1 existing) (cons symbol (nth 1 existing))))
(unless (eq (nth 2 existing) where)
(setf (nth 2 existing) nil))
(when tp-text-affected
(setf (nth 3 existing) t)))
(push (list layer-name (list symbol) where (and tp-text-affected t))
tp--batch-update-pending))))
(defun tp--register-reactive-deps (layer-name reactive-symbols props)
"Register REACTIVE-SYMBOLS as dependencies for LAYER-NAME.
PROPS is the original property specification with reactive symbols.
@ -246,7 +282,10 @@ COMPUTED is a list of (VAR-SYMBOL COMPUTE-FN) pairs."
(defun tp--apply-initial-computed (compute)
"Apply initial computed values using COMPUTE definitions.
COMPUTE is a list of (VAR-SYMBOL COMPUTE-FN) pairs.
Sets the global variables to their computed values."
Sets the global variables to their computed values.
A compute function returning nil is a legitimate result and is
applied; only computes that signal an error are skipped (see
`tp--compute-error')."
(dolist (comp compute)
(let* ((var-sym (car comp))
(compute-fn (cadr comp))
@ -254,8 +293,8 @@ Sets the global variables to their computed values."
(funcall compute-fn)
(error
(message "tp: initial compute error for %s: %s" var-sym err)
nil))))
(when val
tp--compute-error))))
(unless (eq val tp--compute-error)
(set var-sym val)))))
(defun tp--data-var-symbol (data-entry)

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

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

514
tp-render.el
View File

@ -26,9 +26,44 @@
(require 'tp-ops)
(require 'tp-search)
(defun tp--layer-reactive-props (layer-name)
"Collect LAYER-NAME's unresolved reactive props from `tp-reactive-deps'.
Each dependency entry stores only the portions of the layer's props
that reference one variable; this merges the fragments back into a
single plist with the `$var' markers intact. Returns nil when the
layer has no reactive props (data-only dependencies store nil)."
(let ((all nil))
(dolist (dep tp-reactive-deps)
(let ((layer-entry (assoc layer-name (cdr dep))))
(when (and layer-entry (cdr layer-entry))
(setq all (if all
(tp--deep-merge-plist all (cdr layer-entry))
(copy-sequence (cdr layer-entry)))))))
all))
(defun tp--layer-render-props (layer-name override-alist)
"Return LAYER-NAME's props for re-rendering in the current buffer.
Starts from the stored layer definition and deep-merges the layer's
reactive props re-resolved against the current variable values, so
buffer-local values are honored when the target buffer is current.
OVERRIDE-ALIST maps variables to not-yet-visible new values (the
variable watcher runs before the variable is actually set) and takes
precedence over `symbol-value'. Returns nil when the layer has no
usable definition."
(let ((base (tp-layer-props layer-name t))) ; include tp-name for tracking
(when base
(let ((reactive (tp--layer-reactive-props layer-name)))
(if reactive
(tp--deep-merge-plist
base (tp--resolve-reactive-symbols reactive override-alist))
base)))))
(defun tp--update-layer-computed (layer-name override-alist)
"Update computed reactive variables for LAYER-NAME with OVERRIDE-ALIST.
Evaluates compute functions and updates the reactive variable values.
A compute function returning nil is a legitimate result and is
propagated; only computes that signal an error are skipped (see
`tp--compute-error').
Returns an updated override-alist with the new computed values."
(when-let ((computed (cdr (assoc layer-name tp-layer-computed))))
(dolist (comp computed)
@ -45,8 +80,8 @@ Returns an updated override-alist with the new computed values."
(error
(message "tp: compute error for %s.%s: %s"
layer-name var-sym err)
nil))))
(when computed-val
tp--compute-error))))
(unless (eq computed-val tp--compute-error)
;; Update the global variable
(set var-sym computed-val)
;; Add to override-alist for property resolution
@ -54,50 +89,58 @@ Returns an updated override-alist with the new computed values."
;; Also update the layer properties if the computed var is used in props
(let ((current-props (cdr (assoc layer-name tp-layer-alist))))
(when current-props
;; Collect all reactive props for this layer from tp-reactive-deps
(let ((all-reactive-props nil))
(dolist (dep tp-reactive-deps)
(let ((layer-entry (assoc layer-name (cdr dep))))
(when (and layer-entry (cdr layer-entry))
;; Merge the reactive props
(cl-loop for (key val) on (cdr layer-entry) by #'cddr
do (setq all-reactive-props
(plist-put all-reactive-props key val))))))
(when all-reactive-props
(let ((resolved-props (tp--resolve-reactive-symbols
all-reactive-props override-alist)))
(when resolved-props
(cl-loop for (key val) on resolved-props by #'cddr
do (setq current-props (plist-put current-props key val)))
(tp--set-layer-props layer-name current-props)))))))))))
(when-let ((all-reactive-props (tp--layer-reactive-props layer-name)))
(let ((resolved-props (tp--resolve-reactive-symbols
all-reactive-props override-alist)))
(when resolved-props
;; Deep-merge the resolved props into the current layer
;; props so sibling static attributes nested in plists
;; (e.g. a :background next to a reactive :foreground)
;; survive the update.
(tp--set-layer-props
layer-name
(tp--deep-merge-plist current-props resolved-props)))))))))))
override-alist)
(defun tp--update-layer-regions (layer-name &optional where)
(defun tp--update-layer-regions (layer-name &optional where override-alist)
"Update text regions that have LAYER-NAME applied.
Re-applies the layer properties using tp-search-map and tp-add.
Re-applies the layer's current properties to every region tagged with
the layer's `tp-name'. The layer's OWN property keys are replaced
with their current values (so refresh is idempotent: a face variable
changing from bold to italic yields italic, not (italic bold)), while
properties contributed by other sources are left untouched.
WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update all buffers that have the text property (setq case)."
(let ((props (tp-layer-props layer-name t))) ; include tp-name for reactive tracking
(when props
;; Callback for tp-search-map: applies props to matched region.
;; _TEXT is unused (the matched text), START and END are buffer positions.
;; Returns nil to prevent tp-search-map from replacing the text.
(let ((apply-props-fn (lambda (_text start end)
(tp-add start end props)
nil)))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(save-excursion
(tp-search-map apply-props-fn 'tp-name layer-name)))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(save-excursion
(tp-search-map apply-props-fn 'tp-name layer-name))))))))))
- If WHERE is nil, update all buffers that have the text property.
OVERRIDE-ALIST maps reactive variables to their new values when the
watcher fires before the variables are set; layer props are
re-resolved against it in each target buffer, so buffer-local
variable values are honored."
(let ((update-buffer
(lambda ()
(let ((props (tp--layer-render-props layer-name override-alist)))
(when props
(save-excursion
;; Callback for tp-search-map: replaces the layer's own
;; property keys on the matched region. Returns nil to
;; prevent tp-search-map from replacing the text.
(tp-search-map
(lambda (_text start end)
(cl-loop for (key val) on props by #'cddr
do (put-text-property start end key val))
nil)
'tp-name layer-name)))))))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(funcall update-buffer))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(funcall update-buffer)))))))
(defun tp--find-tp-text-reactive-var (layer-name)
"Find the reactive variable symbol used for tp-text in LAYER-NAME.
@ -119,7 +162,62 @@ Searches through `tp-reactive-deps' to find the original reactive props."
(throw 'found var-sym))))))))
nil))
(defun tp--update-reactive-text (layer-name &optional where)
(defun tp--tp-text-transform (layer-name text)
"Return TEXT transformed by LAYER-NAME's `:transform', or TEXT.
Transform errors are reported and TEXT is returned unchanged; a
non-string transform result is ignored as well."
(let ((transform-fn (when layer-name
(cdr (assoc layer-name tp-layer-transforms)))))
(if (not transform-fn)
text
(condition-case err
(let ((result (funcall transform-fn text)))
(tp-debug-log " Transform %s: %S -> %S" layer-name text result)
(if (stringp result) result text))
(error
(message "tp: transform error for %s: %s" layer-name err)
text)))))
(defun tp--merge-embedded-props (embedded props)
"Merge the EMBEDDED string props plist under PROPS; PROPS win.
Like `tp--merge-string-props-into-plist' but takes the embedded plist
directly instead of sampling position 0 of a string, so callers can
merge per property interval. Face-family values (see
`tp-face-properties') are merged with PROPS taking precedence; other
conflicting keys keep the PROPS value; keys only in EMBEDDED are
added."
(let ((result (copy-sequence props)))
(cl-loop for (key val) on embedded by #'cddr
do (let ((existing (plist-get result key)))
(setq result
(plist-put result key
(if existing
(if (memq key tp-face-properties)
(tp--merge-face-values val existing)
existing)
val)))))
result))
(defun tp--apply-reactive-text-props (source props offset &optional target)
"Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET.
SOURCE is the (possibly propertized) replacement string; TARGET is a
string, or nil for the current buffer. For every embedded-property
interval of SOURCE the interval's props are merged under PROPS (see
`tp--merge-embedded-props') and the result is applied to the
corresponding span of TARGET shifted by OFFSET. This keeps
per-interval styling of propertized reactive strings intact instead
of smearing position-0 props across the whole region."
(tp--map-intervals
source nil nil
(lambda (istart iend str-props)
(let ((merged (if str-props
(tp--merge-embedded-props str-props props)
props)))
(cl-loop for (key val) on merged by #'cddr
do (put-text-property (+ offset istart) (+ offset iend)
key val target))))))
(defun tp--update-reactive-text (layer-name &optional where override-alist)
"Update text regions that have tp-text property with LAYER-NAME applied.
This is called when a reactive variable bound to tp-text changes.
@ -127,68 +225,131 @@ WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update all buffers that have the text property (setq case).
OVERRIDE-ALIST maps reactive variables to their new values when the
watcher fires before the variables are set; the layer's props are
re-resolved against it in each target buffer.
If a transform function is registered for LAYER-NAME via `:transform',
it will be applied to the text before updating."
(let ((props (tp-layer-props layer-name t))) ; include tp-name for reactive tracking
(when props
(let* ((raw-text (plist-get props 'tp-text))
;; Apply transformation if registered
(transform-fn (cdr (assoc layer-name tp-layer-transforms)))
(new-text (if (and transform-fn raw-text (stringp raw-text))
(condition-case err
(let ((result (funcall transform-fn raw-text)))
(tp-debug-log " Transform %s: %S -> %S"
layer-name raw-text result)
result)
(error
(message "tp: transform error for %s: %s"
layer-name err)
raw-text))
raw-text)))
(when (and new-text (stringp new-text))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(save-excursion
(tp--replace-reactive-text-in-buffer layer-name new-text props)))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(save-excursion
(tp--replace-reactive-text-in-buffer layer-name new-text props)))))))))))
(let ((update-buffer
(lambda ()
(let ((props (tp--layer-render-props layer-name override-alist)))
(when props
(let* ((raw-text (plist-get props 'tp-text))
;; Apply transformation if registered
(new-text (if (stringp raw-text)
(tp--tp-text-transform layer-name raw-text)
raw-text)))
(when (and new-text (stringp new-text))
(save-excursion
(tp--replace-reactive-text-in-buffer
layer-name new-text props)))))))))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(funcall update-buffer))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(funcall update-buffer)))))))
(defun tp--replace-reactive-text-in-buffer (layer-name new-text props)
"Replace text in current buffer for reactive text with LAYER-NAME.
NEW-TEXT is the new text to replace with.
PROPS are the properties to apply to the new text.
Text properties embedded in NEW-TEXT are merged with PROPS.
The new properties completely reset/replace the old properties."
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))
;; Merge embedded text properties from new-text into props
(merged-props (tp--merge-string-props-into-plist new-text props)))
(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)))
(if (equal old-text (substring-no-properties new-text))
;; Text content is the same, but properties may differ
;; Use set-text-properties to reset with new properties
(set-text-properties m-start m-end merged-props)
;; Text content is different - delete old text and insert new
(delete-region m-start m-end)
(goto-char m-start)
(insert (substring-no-properties new-text))
;; Apply new properties
(let ((new-end (+ m-start (length new-text))))
(set-text-properties m-start new-end merged-props))))
(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.
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).
@ -197,24 +358,26 @@ 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 with tp-text)."
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)))
(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 object start end)
(if object
(with-current-buffer object
(buffer-substring-no-properties start end))
(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-let ((layer-name (plist-get props 'tp-name)))
(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.
@ -226,68 +389,29 @@ NEW-OBJECT is the new string object (only different for strings with tp-text)."
(when layer-props
(tp--set-layer-props layer-name
(plist-put layer-props 'tp-text current-text))))))
(list (plist-put props 'tp-text current-text) end object)))
(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* ((layer-name (plist-get props 'tp-name))
(transform-fn (when layer-name
(cdr (assoc layer-name tp-layer-transforms))))
(final-text
(if transform-fn
(condition-case err
(funcall transform-fn tp-text-val)
(error
(message "tp: transform error for %s: %s" layer-name err)
tp-text-val))
tp-text-val))
;; Embedded text properties from tp-text are now preserved in all cases.
;; The props passed to this function take precedence over embedded props
;; when there's a conflict (e.g., both have 'face' property).
;; The merge-mode parameter is retained for backward compatibility but
;; no longer affects behavior in this function - all modes use the same
;; merging strategy via tp--merge-string-props-into-plist.
(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)))
(if (stringp object)
;; For strings: create a new string with tp-text content
;; Strip properties - result-props will be applied by the caller
(let ((new-string (substring-no-properties final-text)))
(list result-props (length new-string) new-string))
;; For buffers: replace text and adjust end position
(let ((old-text (if object
(with-current-buffer object
(buffer-substring-no-properties start end))
(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
(if object
(with-current-buffer object
(text-properties-at start))
(text-properties-at start)))))
(save-excursion
(if object
(with-current-buffer object
(let ((inhibit-read-only t))
(delete-region start end)
(goto-char start)
;; Insert without properties - we'll apply result-props later
(insert (substring-no-properties final-text))))
(let ((inhibit-read-only t))
(delete-region start end)
(goto-char start)
(insert (substring-no-properties final-text)))))
(let ((new-end (+ start (length final-text))))
;; Re-apply existing properties to new text region if preserving
(when existing-props
(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))))))))
(tp--tp-text-replace start end final-text result-props
object preserve-props)))
;; Other types - return unchanged
(t (list props end object))))))
@ -299,51 +423,69 @@ variable SYMBOL; NEWVAL is its new value. WHERE is the buffer for
`setq-local' changes, nil for global ones. OVERRIDE-ALIST maps SYMBOL
to NEWVAL (the watcher runs before the variable is actually set).
Buffer-local changes (WHERE a buffer) re-render only that buffer,
resolving the layer's props against the buffer-local values, and do
NOT touch the global layer definition, so `setq-local' cannot leak a
buffer's value into other buffers.
When `tp--batch-update-active' is non-nil the buffer update is queued
in `tp--batch-update-pending' instead of applied immediately.
in `tp--batch-update-pending' instead of applied immediately. When
this function is re-entered from a nested variable write issued
inside an update (a computed variable being set, or the tp-text
two-way sync), the nested re-render is queued the same way and
flushed once the outermost update completes, instead of recursing.
This is the engine behind `tp--reactive-variable-watcher'; it is
installed as `tp--reactive-update-function'."
(let ((tp-text-affected (plist-member reactive-props 'tp-text)))
;; Update computed properties for this layer
(let ((updated-override
(tp--update-layer-computed layer-name override-alist)))
(when reactive-props
;; Resolve the reactive props with the new value override
(let ((resolved-props (tp--resolve-reactive-symbols
reactive-props updated-override)))
;; Update only the reactive properties in the layer definition
(let ((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)
(setq current-props (tp--deep-merge-plist current-props
resolved-props))
(tp--set-layer-props layer-name current-props))))))
;; Update text regions with this layer (or defer if batching)
(if tp--batch-update-active
;; Batching: defer the buffer update
;; Pending format: (layer-name symbols-list where tp-text-affected)
(let ((existing (assoc layer-name tp--batch-update-pending)))
(tp-debug-log " Deferring buffer update for %s (batch mode)"
layer-name)
(if existing
;; Update existing entry: add symbol if not present
(let ((symbols (nth 1 existing)))
(unless (memq symbol symbols)
(setf (nth 1 existing) (cons symbol symbols))))
;; Create new entry
(push (list layer-name (list symbol) where tp-text-affected)
tp--batch-update-pending)))
;; Normal: update immediately
(tp-debug-log " Updating layer %s (tp-text affected: %s)"
layer-name (if tp-text-affected "yes" "no"))
(tp--reactive-flush-entry layer-name where tp-text-affected))))
(ignore newval)
(let ((tp-text-affected (and (plist-member reactive-props 'tp-text) t)))
(if tp--reactive-updating
;; Nested change fired from within an update: queue, don't recurse.
(tp--queue-batch-update layer-name symbol where tp-text-affected)
(let ((tp--reactive-updating t))
;; Update computed properties for this layer
(let ((updated-override
(tp--update-layer-computed layer-name override-alist)))
;; Update only the reactive properties in the layer definition.
;; Buffer-local changes must not leak into the global definition;
;; the buffer re-render below resolves against the buffer-local
;; values instead.
(when (and reactive-props (not (bufferp where)))
(let ((resolved-props (tp--resolve-reactive-symbols
reactive-props updated-override))
(current-props (cdr (assoc layer-name tp-layer-alist))))
(when current-props
;; Deep merge the resolved reactive props into the current
;; layer props to preserve nested plist values (like face)
(tp--set-layer-props
layer-name
(tp--deep-merge-plist current-props resolved-props)))))
;; Update text regions with this layer (or defer if batching)
(if tp--batch-update-active
;; Batching: defer the buffer update
(progn
(tp-debug-log " Deferring buffer update for %s (batch mode)"
layer-name)
(tp--queue-batch-update layer-name symbol where
tp-text-affected))
;; Normal: update immediately
(tp-debug-log " Updating layer %s (tp-text affected: %s)"
layer-name (if tp-text-affected "yes" "no"))
(if tp-text-affected
(tp--update-reactive-text layer-name where updated-override)
(tp--update-layer-regions layer-name where updated-override)))))
;; Re-renders queued by nested variable writes during this update are
;; flushed now that the outermost update has finished.
(unless tp--batch-update-active
(when tp--batch-update-pending
(tp--flush-batch-updates))))))
(defun tp--reactive-flush-entry (layer-name where tp-text-affected)
"Re-render LAYER-NAME's regions in WHERE (or all buffers when nil).
TP-TEXT-AFFECTED non-nil means the layer's `tp-text' changed and the
text itself must be replaced. Installed as
text itself must be replaced. Runs after the changed variables have
actually been set, so layer props re-resolve against current
\(buffer-local aware) values. Installed as
`tp--reactive-flush-function'."
(if tp-text-affected
(tp--update-reactive-text layer-name where)

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

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

501
tp-search.el
View File

@ -23,42 +23,91 @@
(require 'tp-layer)
(require 'tp-ops)
(defun tp--match-apply-single (pattern properties apply-fn object)
(defun tp--pattern-apply-single (pattern properties apply-fn object literal)
"Apply APPLY-FN to matches of single PATTERN in OBJECT.
When LITERAL is non-nil, PATTERN is matched literally; otherwise it
is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for
each match.
For strings, returns a NEW string with properties applied
\(non-destructive).
For buffers, modifies in-place and returns list of regions.
Zero-width matches (an empty literal pattern, or a regexp that can
match the empty string) are recorded and the scan advances one
position past them, so the search always terminates."
(let ((regexp (if literal (regexp-quote pattern) pattern)))
(cond
;; String object
((stringp object)
;; First, collect all match positions from the original string
(let ((matches nil)
(pos 0)
(limit (length object)))
(while (and (<= pos limit) (string-match regexp object pos))
(let ((beg (match-beginning 0))
(end (match-end 0)))
(push (cons beg end) matches)
(setq pos (if (= beg end) (1+ beg) end))))
;; Apply function to each match in order (reverse to get correct order)
;; Make a copy to ensure original string is not modified
(let ((result (copy-sequence object)))
(dolist (match (nreverse matches))
(when properties
(setq result (funcall apply-fn
(car match) (cdr match)
properties result))))
result)))
;; Buffer or nil (current buffer)
(t
(let ((buf (or object (current-buffer))))
(tp-with-current-buffer buf
(save-excursion
(goto-char (point-min))
(let (regions (keep-going t))
(while (and keep-going (re-search-forward regexp nil t))
(let ((beg (match-beginning 0))
(end (match-end 0)))
(when properties
(funcall apply-fn beg end properties buf))
(push (cons beg end) regions)
;; Guard against zero-width matches looping forever
(when (= beg end)
(if (eobp)
(setq keep-going nil)
(forward-char 1)))))
(nreverse regions)))))))))
(defun tp--pattern-apply (pattern properties apply-fn object literal)
"Apply APPLY-FN to matches of PATTERN (one pattern or a list).
When LITERAL is non-nil, patterns are matched literally; otherwise
they are regexps. APPLY-FN is called with (START END PROPS OBJECT)
for each match.
For strings, returns a NEW string with properties applied
\(non-destructive).
For buffers, returns list of regions."
(let ((patterns (if (listp pattern) pattern (list pattern))))
(cond
;; String object
((stringp object)
(let ((result object))
(dolist (p patterns)
(setq result (tp--pattern-apply-single p properties apply-fn
result literal)))
result))
;; Buffer or nil (current buffer)
(t
(let ((all-regions nil))
(dolist (p patterns)
(let ((regions (tp--pattern-apply-single p properties apply-fn
object literal)))
(setq all-regions (append all-regions regions))))
all-regions)))))
(defun tp--match-apply-single (pattern properties apply-fn object)
"Apply APPLY-FN to literal matches of single PATTERN in OBJECT.
For strings, returns a new string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(cond
;; String object
((stringp object)
;; First, collect all match positions from the original string
(let ((matches nil)
(pos 0))
(while (string-match (regexp-quote pattern) object pos)
(let ((beg (match-beginning 0))
(end (match-end 0)))
(push (cons beg end) matches)
(setq pos (if (= beg end) (1+ beg) end))))
;; Apply function to each match in order (reverse to get correct order)
;; Make a copy to ensure original string is not modified
(let ((result (copy-sequence object)))
(dolist (match (nreverse matches))
(when properties
(setq result (funcall apply-fn (car match) (cdr match) properties result))))
result)))
;; Buffer or nil (current buffer)
(t
(let ((buf (or object (current-buffer))))
(tp-with-current-buffer buf
(save-excursion
(goto-char (point-min))
(let (regions)
(while (search-forward pattern 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)))
(nreverse regions))))))))
(tp--pattern-apply-single pattern properties apply-fn object t))
(defun tp--match-apply (pattern properties apply-fn &optional object)
"Internal function to apply APPLY-FN to matches of PATTERN.
@ -67,61 +116,14 @@ When PATTERN is a list, each element is a pattern to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(let ((patterns (if (listp pattern) pattern (list pattern))))
(cond
;; String object
((stringp object)
(let ((result object))
(dolist (p patterns)
(setq result (tp--match-apply-single p properties apply-fn result)))
result))
;; Buffer or nil (current buffer)
(t
(let ((all-regions nil))
(dolist (p patterns)
(let ((regions (tp--match-apply-single p properties apply-fn object)))
(setq all-regions (append all-regions regions))))
all-regions)))))
(tp--pattern-apply pattern properties apply-fn object t))
(defun tp--regexp-apply-single (pattern properties apply-fn object)
"Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(cond
;; String object
((stringp object)
;; First, collect all match positions from the original string
(let ((matches nil)
(pos 0))
(while (string-match pattern object pos)
(let ((beg (match-beginning 0))
(end (match-end 0)))
(push (cons beg end) matches)
(setq pos (if (= beg end) (1+ beg) end))))
;; Apply function to each match in order (reverse to get correct order)
;; Make a copy to ensure original string is not modified
(let ((result (copy-sequence object)))
(dolist (match (nreverse matches))
(when properties
(setq result (funcall apply-fn
(car match) (cdr match)
properties result))))
result)))
;; Buffer or nil (current buffer)
(t
(let ((buf (or object (current-buffer))))
(tp-with-current-buffer buf
(save-excursion
(goto-char (point-min))
(let (regions)
(while (re-search-forward pattern 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)))
(nreverse regions))))))))
(tp--pattern-apply-single pattern properties apply-fn object nil))
(defun tp--regexp-apply (pattern properties apply-fn &optional object)
"Internal function to apply APPLY-FN to regexp matches of PATTERN.
@ -130,21 +132,7 @@ When PATTERN is a list, each element is a regexp to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(let ((patterns (if (listp pattern) pattern (list pattern))))
(cond
;; String object
((stringp object)
(let ((result object))
(dolist (p patterns)
(setq result (tp--regexp-apply-single p properties apply-fn result)))
result))
;; Buffer or nil (current buffer)
(t
(let ((all-regions nil))
(dolist (p patterns)
(let ((regions (tp--regexp-apply-single p properties apply-fn object)))
(setq all-regions (append all-regions regions))))
all-regions)))))
(tp--pattern-apply pattern properties apply-fn object nil))
(defun tp--deep-merge-apply (start end props obj)
"Apply PROPS to OBJ from START to END with deep merge.
@ -163,6 +151,11 @@ For buffers, modifies in-place."
do (let* ((current-val (plist-get current-props key))
(new-val
(cond
;; Face-family properties merge with the
;; incoming face taking precedence, same as
;; the string path (:add mode).
((memq key tp-face-properties)
(tp--prepend-face val current-val))
((and (listp val) (keywordp (car-safe val))
(listp current-val)
(keywordp (car-safe current-val)))
@ -291,6 +284,40 @@ Wraps `text-property-search-forward'."
Wraps `text-property-search-backward'."
(text-property-search-backward property value predicate not-current))
(defun tp--property-search-backward (property value)
"Search backward for the previous region where PROPERTY `equal's VALUE.
This is the backward mirror of (text-property-search-forward PROPERTY
VALUE t): a region matches when its PROPERTY value is `equal' to
VALUE. It deliberately does not call
`text-property-search-backward' with predicate t, because that
primitive's non-default-predicate branch skips every other property
run when non-matching runs intervene (observed through Emacs 30.2),
silently missing valid matches.
If a matching region is found, move point to its beginning and
return a `prop-match' object whose end is clipped to the starting
point (matching the primitive's behavior when point starts inside a
matching region). Otherwise return nil and leave point alone."
(if (bobp)
nil
(let ((origin (point))
(found nil))
;; Walk PROPERTY runs before point; remember the last matching one.
;; tp--map-intervals clips the run containing ORIGIN to end there.
(tp--map-intervals
(current-buffer) (point-min) origin
(lambda (ibeg iend val)
(when (equal value val)
(setq found (list ibeg iend val)))
nil)
property)
(when found
(goto-char (car found))
(make-prop-match :beginning (car found)
:end (cadr found)
:value (caddr found))))))
(defun tp-forward (property &optional value object n)
"Search forward N times for text with PROPERTY.
Returns prop-match for buffers or list of (START END VALUE) for strings."
@ -333,11 +360,15 @@ Uses `tp-search-backward' for buffers and `tp-search' for strings."
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
(setq result (tp-search-backward property value))))
;; `equal' matching, mirroring the predicate t that
;; `tp-forward' passes. The previous code used the default
;; nil predicate, which matches values NOT `equal' to VALUE
;; and so inverted the match when VALUE was non-nil.
(setq result (tp--property-search-backward property value))))
result)))))
(defun tp--forward-do (function property &optional value object times start end)
"Internal: Search forward TIMES for PROPERTY and apply FUNCTION to the last match.
"Internal: search forward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT.
@ -379,6 +410,74 @@ Returns the number of successful matches."
(cl-incf matches)))))))
matches)))))
(defun tp--replace-match-text (function arity match obj &optional idx)
"Replace the text of MATCH in OBJ with the result of calling FUNCTION.
MATCH is either a (START END VALUE) list (string matches) or a
prop-match struct (buffer matches). ARITY is the precomputed
\(func-arity FUNCTION); depending on it, FUNCTION is called with
\(TEXT), (TEXT START), (TEXT START END) or - when IDX is non-nil and
FUNCTION accepts a 4th argument - (TEXT START END IDX).
If FUNCTION returns a string, it replaces the matched text:
- For string OBJ the replacement happens in place; since strings have
fixed length, a longer replacement is truncated to the match length
and a shorter one only replaces that portion. The replacement's
text properties (including their absence) are copied onto the
replaced portion.
- For buffer OBJ the match is replaced via `delete-region' + `insert'
\(the buffer may grow or shrink).
Any non-string return value leaves OBJ untouched."
(let* ((m-start (if (listp match) (car match) (prop-match-beginning match)))
(m-end (if (listp match) (cadr match) (prop-match-end match)))
(text (if (stringp obj)
(substring obj m-start m-end)
(buffer-substring m-start m-end)))
(max-arity (cdr arity))
(can-accept-start (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 2))))
(can-accept-end (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 3))))
(can-accept-idx (and idx
(or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 4)))))
(new-text (cond
(can-accept-idx (funcall function text m-start m-end idx))
(can-accept-end (funcall function text m-start m-end))
(can-accept-start (funcall function text m-start))
(t (funcall function text)))))
(when (stringp new-text)
(if (stringp obj)
;; For strings: copy text content and properties separately
(let ((len (min (length new-text) (- m-end m-start))))
;; Copy text content, truncated to the available room so a
;; longer replacement cannot overflow the string (which
;; would clobber text after the match or signal
;; args-out-of-range).
(store-substring obj m-start
(if (> (length new-text) len)
(substring new-text 0 len)
new-text))
;; Copy properties from new-text to obj. Ranges with nil
;; properties are copied too, so FUNCTION can REMOVE
;; properties by returning a stripped string.
(let ((pos 0))
(while (< pos len)
(let* ((props (text-properties-at pos new-text))
(next-change (or (next-property-change pos new-text)
len)))
(set-text-properties (+ m-start pos)
(+ m-start (min next-change len))
props
obj)
(setq pos next-change)))))
;; For buffers, delete and insert
(unless (equal new-text text)
(save-excursion
(delete-region m-start m-end)
(goto-char m-start)
(insert new-text)))))))
(defun tp-forward-do (function property &optional value object times start end)
"Search forward for text with PROPERTY and apply FUNCTION to the last match.
@ -418,47 +517,11 @@ Example:
(let ((arity (func-arity function)))
(tp--forward-do
(lambda (match obj)
(let* ((m-start (if (listp match) (car match) (prop-match-beginning match)))
(m-end (if (listp match) (cadr match) (prop-match-end match)))
(text (if (stringp obj)
(substring obj m-start m-end)
(buffer-substring m-start m-end)))
(max-arity (cdr arity))
(can-accept-start (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 2))))
(can-accept-end (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 3))))
(new-text (cond
(can-accept-end (funcall function text m-start m-end))
(can-accept-start (funcall function text m-start))
(t (funcall function text)))))
(when (stringp new-text)
(if (stringp obj)
;; For strings: copy text content and properties separately
(let ((len (min (length new-text) (- m-end m-start))))
;; Copy text content
(store-substring obj m-start new-text)
;; Copy properties from new-text to obj
(let ((pos 0))
(while (< pos len)
(let* ((props (text-properties-at pos new-text))
(next-change (or (next-property-change pos new-text) len)))
(when props
(set-text-properties (+ m-start pos)
(+ m-start (min next-change len))
props
obj))
(setq pos next-change)))))
;; For buffers, delete and insert
(unless (equal new-text text)
(save-excursion
(delete-region m-start m-end)
(goto-char m-start)
(insert new-text)))))))
(tp--replace-match-text function arity match obj))
property value object times start end)))
(defun tp--backward-do (function property &optional value object times start end)
"Internal: Search backward TIMES for PROPERTY and apply FUNCTION to the last match.
"Internal: search backward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT.
@ -494,7 +557,8 @@ Returns the number of successful matches."
(save-excursion
(goto-char search-end)
(dotimes (i count)
(when-let ((match (tp-search-backward property value)))
;; `equal' matching, same as tp--forward-do's predicate t.
(when-let ((match (tp--property-search-backward property value)))
(when (>= (prop-match-beginning match) search-start)
(when (= i (1- count))
(funcall function match buf))
@ -540,43 +604,7 @@ Example:
(let ((arity (func-arity function)))
(tp--backward-do
(lambda (match obj)
(let* ((m-start (if (listp match) (car match) (prop-match-beginning match)))
(m-end (if (listp match) (cadr match) (prop-match-end match)))
(text (if (stringp obj)
(substring obj m-start m-end)
(buffer-substring m-start m-end)))
(max-arity (cdr arity))
(can-accept-start (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 2))))
(can-accept-end (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 3))))
(new-text (cond
(can-accept-end (funcall function text m-start m-end))
(can-accept-start (funcall function text m-start))
(t (funcall function text)))))
(when (stringp new-text)
(if (stringp obj)
;; For strings: copy text content and properties separately
(let ((len (min (length new-text) (- m-end m-start))))
;; Copy text content
(store-substring obj m-start new-text)
;; Copy properties from new-text to obj
(let ((pos 0))
(while (< pos len)
(let* ((props (text-properties-at pos new-text))
(next-change (or (next-property-change pos new-text) len)))
(when props
(set-text-properties (+ m-start pos)
(+ m-start (min next-change len))
props
obj))
(setq pos next-change)))))
;; For buffers, delete and insert
(unless (equal new-text text)
(save-excursion
(delete-region m-start m-end)
(goto-char m-start)
(insert new-text)))))))
(tp--replace-match-text function arity match obj))
property value object times start end)))
(defun tp-search (start-or-string
@ -674,36 +702,59 @@ Each element contains the start position, end position, and property value."
Signature: (tp--search-do FUNCTION PROPERTY &optional VALUE OBJECT START END)
FUNCTION receives two arguments: the prop-match (list of START END VALUE) and OBJECT.
FUNCTION receives two arguments: the match, as a (START END VALUE)
list, and OBJECT.
PROPERTY is the text property to search for.
VALUE is the optional value to match; nil means search for PROPERTY without matching value.
VALUE is the optional value to match; nil means search for PROPERTY
without matching value.
OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end.
Returns the number of matches processed."
(let* ((obj (or object (current-buffer)))
(all-matches (if (stringp obj)
(tp-search obj property value)
(let ((s (or start (point-min)))
(e (or end (point-max))))
(tp-search s e property value obj))))
(filtered-matches
(if (and (not (stringp obj)) start end)
(seq-filter (lambda (m)
(and (>= (car m) start)
(<= (cadr m) end)))
all-matches)
(if (stringp obj)
(let ((s (or start 0))
(e (or end (length obj))))
(seq-filter (lambda (m)
(and (>= (car m) s)
(<= (cadr m) e)))
all-matches))
all-matches))))
(dolist (match filtered-matches)
(funcall function match obj))
(length filtered-matches)))
Returns the number of matches processed.
For buffers, FUNCTION is called with OBJECT as the current buffer, and
the match positions handed to FUNCTION are tracked with markers, so
FUNCTION may safely change the length of earlier matches (e.g. replace
their text): later matches still receive their up-to-date positions."
(let ((obj (or object (current-buffer))))
(if (stringp obj)
(let* ((all-matches (tp-search obj property value))
(s (or start 0))
(e (or end (length obj)))
(filtered-matches
(seq-filter (lambda (m)
(and (>= (car m) s)
(<= (cadr m) e)))
all-matches)))
(dolist (match filtered-matches)
(funcall function match obj))
(length filtered-matches))
;; Buffer: do all the work with OBJ current, and track match
;; positions with markers so length-changing edits made by
;; FUNCTION on earlier matches don't invalidate later positions.
(tp-with-current-buffer obj
(let* ((s (or start (point-min)))
(e (or end (point-max)))
(matches (tp-search s e property value obj))
(marked (mapcar (lambda (m)
;; Begin markers advance on insertion at
;; their position so adjacent runs stay
;; correct after a replacement.
(list (copy-marker (car m) t)
(copy-marker (cadr m))
(caddr m)))
matches)))
(unwind-protect
(dolist (m marked)
(funcall function
(list (marker-position (car m))
(marker-position (cadr m))
(caddr m))
obj))
(dolist (m marked)
(set-marker (car m) nil)
(set-marker (cadr m) nil)))
(length marked))))))
(defun tp-search-map (function property &optional value object start end)
"Apply FUNCTION to all matches of PROPERTY in OBJECT.
@ -747,52 +798,12 @@ Example:
;; Search within a range
(tp-search-map #\\='upcase \\='marker nil my-string 0 10)"
(let* ((obj (or object (current-buffer)))
(idx 0)
(arity (func-arity function)))
(let ((idx 0)
(arity (func-arity function)))
(tp--search-do
(lambda (match obj)
(let* ((m-start (car match))
(m-end (cadr match))
(text (if (stringp obj)
(substring obj m-start m-end)
(buffer-substring m-start m-end)))
(max-arity (cdr arity))
(can-accept-start (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 2))))
(can-accept-end (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 3))))
(can-accept-idx (or (eq max-arity 'many)
(and (numberp max-arity) (>= max-arity 4))))
(new-text (cond
(can-accept-idx (funcall function text m-start m-end idx))
(can-accept-end (funcall function text m-start m-end))
(can-accept-start (funcall function text m-start))
(t (funcall function text)))))
(setq idx (1+ idx))
(when (stringp new-text)
(if (stringp obj)
;; For strings: copy text content and properties separately
(let ((len (min (length new-text) (- m-end m-start))))
;; Copy text content
(store-substring obj m-start new-text)
;; Copy properties from new-text to obj
(let ((pos 0))
(while (< pos len)
(let* ((props (text-properties-at pos new-text))
(next-change (or (next-property-change pos new-text) len)))
(when props
(set-text-properties (+ m-start pos)
(+ m-start (min next-change len))
props
obj))
(setq pos next-change)))))
;; For buffers, delete and insert
(unless (equal new-text text)
(save-excursion
(delete-region m-start m-end)
(goto-char m-start)
(insert new-text)))))))
(tp--replace-match-text function arity match obj idx)
(setq idx (1+ idx)))
property value object start end)))
(provide 'tp-search)

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

@ -0,0 +1,383 @@
;;; tp-stack-tests.el --- ERT regression tests for tp-stack.el -*- lexical-binding: t -*-
;;; Commentary:
;; Regression tests for confirmed bugs fixed in the layer-stack module
;; (tp-stack.el). Each section is tagged with the canonical bug id it
;; guards against.
;;; Code:
(require 'ert)
(require 'tp)
(defmacro tp-stack-tests--with-env (&rest body)
"Run BODY in a temp buffer with a clean tp layer state.
Layer registries are reset before BODY and again afterwards so
definitions cannot leak between tests."
(declare (indent 0))
`(unwind-protect
(with-temp-buffer
(tp-layer-reset)
,@body)
(tp-layer-reset)))
(defun tp-stack-tests--has-prop-p (pos prop &optional object)
"Return non-nil if PROP is present (even with value nil) at POS of OBJECT."
(and (plist-member (text-properties-at pos object) prop) t))
;;; B28: region ops must not mutate text outside [START, END)
(ert-deftest tp-stack-test-delete-layer-subregion-keeps-outside ()
"Deleting a layer on a sub-region leaves the rest of the stack alone."
(tp-stack-tests--with-env
(insert "abcdefghij")
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(tp-push-layer 1 11 'layer1)
(tp-push-layer 1 11 'layer2)
(tp-delete-layer 3 6 'layer2)
;; Inside [3, 6): layer2 gone, layer1 now on top.
(should (eq (get-text-property 3 'tp-name) 'layer1))
(should (eq (get-text-property 5 'tp-name) 'layer1))
(should-not (tp-layer-exists-p 3 6 'layer2))
;; Outside the region: the full 2-layer stack survives.
(should (eq (get-text-property 1 'tp-name) 'layer2))
(should (eq (get-text-property 2 'tp-name) 'layer2))
(should (eq (get-text-property 6 'tp-name) 'layer2))
(should (eq (get-text-property 10 'tp-name) 'layer2))
(should (tp-layer-exists-p 1 3 'layer1))
(should (tp-layer-exists-p 6 11 'layer1))))
(ert-deftest tp-stack-test-push-layer-subregion-keeps-outside ()
"Pushing onto a sub-region does not smear over the whole interval."
(tp-stack-tests--with-env
(insert "abcdefghij")
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(tp-push-layer 1 4 'layer1)
(tp-push-layer 3 8 'layer2)
;; [1, 3): still only layer1.
(should (eq (get-text-property 1 'tp-name) 'layer1))
(should (eq (get-text-property 2 'tp-name) 'layer1))
(should-not (tp-layer-exists-p 1 3 'layer2))
;; [3, 4): layer2 stacked over layer1.
(should (eq (get-text-property 3 'tp-name) 'layer2))
(should (tp-layer-exists-p 3 4 'layer1))
;; [4, 8): only layer2.
(should (eq (get-text-property 5 'tp-name) 'layer2))
(should-not (tp-layer-exists-p 4 8 'layer1))
;; [8, 11): untouched bare text.
(should (null (text-properties-at 8)))
(should (null (text-properties-at 10)))))
(ert-deftest tp-stack-test-push-layer-subregion-string ()
"Region-form push on a string only affects the requested sub-range."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp layer1 () '(face bold))
(tp-put-layer 2 5 'layer1 0 str)
(should (null (text-properties-at 0 str)))
(should (null (text-properties-at 1 str)))
(should (eq (get-text-property 2 'tp-name str) 'layer1))
(should (eq (get-text-property 4 'tp-name str) 'layer1))
(should (null (text-properties-at 5 str))))))
;;; B29: tp-put-layer must be region-local, not whole-object
(ert-deftest tp-stack-test-put-layer-bare-region-distant-props ()
"Putting a layer on a bare region ignores properties elsewhere."
(tp-stack-tests--with-env
(insert "abcdefghij")
(define-tp layer1 () '(face bold))
(put-text-property 8 10 'help-echo "far")
(tp-push-layer 1 4 'layer1)
;; The layer covers exactly [1, 4).
(should (eq (get-text-property 1 'tp-name) 'layer1))
(should (eq (get-text-property 3 'tp-name) 'layer1))
(should (null (text-properties-at 4)))
(should (null (text-properties-at 7)))
;; The distant properties are untouched.
(should (equal (get-text-property 8 'help-echo) "far"))
(should (null (get-text-property 8 'tp-name)))))
(ert-deftest tp-stack-test-put-layer-same-result-with-or-without-distant-props ()
"Distant unrelated properties do not change what put-layer writes."
(tp-stack-tests--with-env
(define-tp layer1 () '(face bold))
(let (props-bare props-distant)
(with-temp-buffer
(insert "abcdefghij")
(tp-push-layer 1 4 'layer1)
(setq props-bare (text-properties-at 1)))
(with-temp-buffer
(insert "abcdefghij")
(put-text-property 8 10 'help-echo "far")
(tp-push-layer 1 4 'layer1)
(setq props-distant (text-properties-at 1)))
(should (equal props-bare props-distant)))))
;;; B30: inline plists with ordinary (non-keyword) properties
(ert-deftest tp-stack-test-put-layer-inline-plist-plain ()
"An inline plist like (face bold) is a valid layer spec."
(tp-stack-tests--with-env
(insert "abcdef")
(tp-put-layer 1 6 '(face bold) 0)
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-put-layer-inline-plist-nested ()
"An inline plist with a nested value list is a valid layer spec."
(tp-stack-tests--with-env
(insert "abcdef")
(tp-put-layer 1 6 '(face (:foreground "red")) 0)
(should (equal (get-text-property 1 'face) '(:foreground "red")))))
(ert-deftest tp-stack-test-put-layer-inline-plist-multi-pair ()
"A multi-pair inline plist is applied as one layer."
(tp-stack-tests--with-env
(insert "abcdef")
(tp-put-layer 1 6 '(face bold help-echo "tip") 0)
(should (eq (get-text-property 1 'face) 'bold))
(should (equal (get-text-property 1 'help-echo) "tip"))
(should (= (tp-layer-count 1 6) 1))))
(ert-deftest tp-stack-test-put-layer-named-inline-still-works ()
"A named inline layer (NAME PROP VAL ...) keeps its old meaning."
(tp-stack-tests--with-env
(insert "abcdef")
(tp-put-layer 1 6 '(mylayer face bold) 0)
(should (eq (get-text-property 1 'tp-name) 'mylayer))
(should (eq (get-text-property 1 'face) 'bold))))
;;; B31: list of layer names
(ert-deftest tp-stack-test-put-layer-list-of-names ()
"A list of defined layer names pushes each as its own layer."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer-a () '(face bold))
(define-tp layer-b () '(help-echo "b"))
(tp-put-layer 1 5 '(layer-a layer-b) 0)
(should (= (tp-layer-count 1 5) 2))
(should (eq (tp-layer-top 1 5) 'layer-a))
(should (tp-layer-exists-p 1 5 'layer-a))
(should (tp-layer-exists-p 1 5 'layer-b))))
(ert-deftest tp-stack-test-put-layer-mixed-list ()
"A list mixing a layer name and an inline plist works."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer-a () '(face bold))
(tp-put-layer 1 5 '(layer-a (help-echo "inline")) 0)
(should (= (tp-layer-count 1 5) 2))
(should (eq (tp-layer-top 1 5) 'layer-a))))
;;; B32: parameterized groups
(ert-deftest tp-stack-test-put-layer-parameterized-group ()
"A (GROUP-NAME ARG) spec resolves a parameterized group."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp pcolor (c) `(face (:foreground ,c)))
(define-tps pgroup (c) `(pcolor ,c))
(tp-put-layer 1 6 '(pgroup "red") 0)
(should (equal (get-text-property 1 'face) '(:foreground "red")))
(should (eq (get-text-property 1 'tp-name) 'pcolor))))
(ert-deftest tp-stack-test-put-layer-parameterized-group-without-arg-errors ()
"A bare parameterized group name signals instead of silently no-oping."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp pcolor (c) `(face (:foreground ,c)))
(define-tps pgroup (c) `(pcolor ,c))
(should-error (tp-put-layer 1 6 'pgroup 0))))
;;; B33: tp-region-layer-props string positions
(ert-deftest tp-stack-test-region-layer-props-string-subrange ()
"String sub-range queries return absolute in-bounds string positions."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp layer1 () '(face bold))
(tp-push-layer str 'layer1)
(let ((result (tp-region-layer-props 2 5 'layer1 str)))
(should (= (length result) 1))
(should (= (nth 0 (car result)) 2))
(should (= (nth 1 (car result)) 5))
(should (<= (nth 1 (car result)) (length str)))
(should (eq (plist-get (nth 2 (car result)) 'tp-name) 'layer1))))))
(ert-deftest tp-stack-test-region-layer-props-buffer-subrange ()
"Buffer queries return 1-based positions clipped to the region."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 1 7 'layer1)
(let ((result (tp-region-layer-props 2 4 'layer1)))
(should (equal (list (nth 0 (car result)) (nth 1 (car result)))
'(2 4))))))
;;; string/buffer path convergence for region-form mutators
(ert-deftest tp-stack-test-delete-layer-string-region-form ()
"Region-form delete on a string works and stays inside the range."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(tp-push-layer str 'layer1)
(tp-push-layer str 'layer2)
(tp-delete-layer 2 5 'layer2 str)
(should (eq (get-text-property 2 'tp-name str) 'layer1))
(should (eq (get-text-property 4 'tp-name str) 'layer1))
;; Outside [2, 5) both layers survive.
(should (eq (get-text-property 0 'tp-name str) 'layer2))
(should (eq (get-text-property 5 'tp-name str) 'layer2))
(should (tp-layer-exists-p 0 2 'layer1 str))
(should (tp-layer-exists-p 5 6 'layer1 str)))))
;;; B34: explicit nil values survive merge/flatten precedence
(ert-deftest tp-stack-test-merge-layers-explicit-nil-wins ()
"An explicitly-nil value in a higher-precedence layer is kept."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face nil help-echo "u"))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(tp-merge-layers 1 6 'merged '(upper lower))
(should (tp-stack-tests--has-prop-p 1 'face))
(should (null (get-text-property 1 'face)))
(should (equal (get-text-property 1 'help-echo) "u"))
(should (eq (get-text-property 1 'tp-name) 'merged))))
(ert-deftest tp-stack-test-flatten-layers-explicit-nil-wins ()
"Flattening keeps an explicit nil from a higher layer over lower values."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold help-echo "low"))
(define-tp upper () '(face nil))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(tp-flatten-layers 1 6 'flat)
(should (tp-stack-tests--has-prop-p 1 'face))
(should (null (get-text-property 1 'face)))
(should (equal (get-text-property 1 'help-echo) "low"))
(should (eq (get-text-property 1 'tp-name) 'flat))))
;;; B35: no garbage (tp-layers nil) on single-layer stacks
(ert-deftest tp-stack-test-single-layer-no-tp-layers-prop ()
"Pushing one layer does not leave a (tp-layers nil) property behind."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 1 6 'layer1)
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers))
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-delete-to-single-layer-no-tp-layers-prop ()
"Deleting down to one layer drops the tp-layers property entirely."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(tp-push-layer 1 6 'layer1)
(tp-push-layer 1 6 'layer2)
;; With two layers the below-stack is a real, non-nil list.
(should (get-text-property 1 'tp-layers))
(tp-delete-layer 1 6 'layer2)
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers))
(should (eq (get-text-property 1 'tp-name) 'layer1))))
(ert-deftest tp-stack-test-pop-to-single-layer-no-tp-layers-prop ()
"Popping down to one layer drops the tp-layers property entirely."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(tp-push-layer str 'layer1)
(tp-push-layer str 'layer2)
(tp-pop-layer str)
(should-not (plist-member (text-properties-at 0 str) 'tp-layers))
(should (eq (get-text-property 0 'tp-name str) 'layer1)))))
(ert-deftest tp-stack-test-absent-tp-layers-tolerated-by-stack-ops ()
"Stacks without a tp-layers property still work with every operation."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(tp-push-layer 1 6 'layer1) ; single layer, no tp-layers prop
(should (= (tp-layer-count 1 6) 1))
(should (equal (tp-layer-list 1 6) '(layer1)))
(should (tp-layer-exists-p 1 6 'layer1))
(should (eq (tp-layer-top 1 6) 'layer1))
(tp-push-layer 1 6 'layer2) ; stacking on top still works
(should (= (tp-layer-count 1 6) 2))
(should (eq (tp-layer-top 1 6) 'layer2))
(should (tp-layer-exists-p 1 6 'layer1))))
;;; B36: tp-layer-top respects the whole region
(ert-deftest tp-stack-test-layer-top-mid-region-layer ()
"A layer starting after bare text is still found by tp-layer-top."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 3 6 'layer1)
(should (eq (tp-layer-top 1 6) 'layer1))))
(ert-deftest tp-stack-test-layer-top-respects-end ()
"tp-layer-top does not report layers that lie beyond END."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 4 6 'layer1)
(should (null (tp-layer-top 1 3)))))
(ert-deftest tp-stack-test-layer-top-first-named-run-wins ()
"The first run with a named top layer determines the result."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer-a () '(face bold))
(define-tp layer-b () '(face italic))
(tp-push-layer 1 3 'layer-a)
(tp-push-layer 3 6 'layer-b)
(should (eq (tp-layer-top 1 6) 'layer-a))
(should (eq (tp-layer-top 3 6) 'layer-b))))
;;; Shared argument normalizer: both calling conventions still work
(ert-deftest tp-stack-test-normalizer-string-forms ()
"Whole-string forms of the routed mutators behave as before."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp layer1 () '(face bold))
(define-tp layer2 () '(face italic))
(define-tp layer3 () '(face underline))
(tp-push-layer str 'layer1)
(tp-push-layer str 'layer2)
(tp-push-layer str 'layer3)
(should (eq (tp-layer-top 0 6 str) 'layer3))
(tp-rotate-layer str)
(should (eq (tp-layer-top 0 6 str) 'layer2))
(tp-pin-layer str 'layer1)
(should (eq (tp-layer-top 0 6 str) 'layer1))
(tp-pop-layer str)
(should (eq (tp-layer-top 0 6 str) 'layer2))
(tp-delete-layer str 'layer3)
(should (equal (tp-layer-list 0 6 str) '(layer2)))
(should (eq (tp-push-layer str 'layer1) str)))))
(ert-deftest tp-stack-test-normalizer-invalid-first-arg-signals ()
"A non-string, non-number first argument signals a clear error."
(tp-stack-tests--with-env
(define-tp layer1 () '(face bold))
(should-error (tp-push-layer nil 'layer1))
(should-error (tp-delete-layer 'not-a-position 5 'layer1))))
(provide 'tp-stack-tests)
;;; tp-stack-tests.el ends here

728
tp-stack.el
View File

@ -23,34 +23,194 @@
(require 'tp-layer)
(require 'tp-ops)
;;; Shared argument parsing and region iteration
(defun tp--parse-layer-args (start-or-string rest n)
"Normalize a layer operation's positional arguments.
START-OR-STRING is the caller's first positional argument and REST the
list of its remaining positional arguments, in order. N is the number
of operation-specific arguments the caller takes (for example 2 for
`tp-put-layer's LAYER and IDX).
Two calling conventions are supported:
- (STRING ARG1 ... ARGN): operate on the whole STRING.
- (START END ARG1 ... ARGN OBJECT): operate on a region of OBJECT,
where nil means the current buffer.
Returns the list (START END OBJECT ARG1 ... ARGN) with START/END in
OBJECT's native coordinates (0-based for strings, 1-based for
buffers)."
(cond
((stringp start-or-string)
(append (list 0 (length start-or-string) start-or-string)
(seq-take rest n)))
((numberp start-or-string)
(append (list start-or-string (car rest) (nth (1+ n) rest))
(seq-take (cdr rest) n)))
(t (error "Invalid layer arguments: %S" (cons start-or-string rest)))))
(defun tp--stack-map-region (start end object function)
"Call FUNCTION over each property run of [START, END) in OBJECT.
OBJECT is a string, a buffer, or nil for the current buffer.
FUNCTION receives (ABS-START ABS-END STACK): the run's bounds, clipped
to [START, END) and expressed in OBJECT's native coordinates (0-based
for strings, 1-based for buffers), and the run's layer stack as a list
of layer plists, top layer first (empty for bare text).
Returns the list of FUNCTION's non-nil results, in order.
Unlike `tp-intervals-map', runs never extend beyond the requested
region, positions are absolute for strings as well as buffers, and
bare text is visited (with an empty STACK) so layers can be applied to
previously property-less text."
(delq nil
(tp--map-intervals
object start end
(lambda (i-start i-end props)
(let* ((idx (-elem-index 'tp-layers props))
(top (if idx
(-remove-at-indices (list idx (1+ idx)) props)
props))
(belows (plist-get props 'tp-layers)))
(funcall function i-start i-end
(tp--layer-stack-to-list top belows)))))))
(defun tp--stack-build-props (layer-list)
"Build text properties from LAYER-LIST (top layer first).
Like `tp--build-layer-props', but the `tp-layers' entry is only added
when there are below-layers, so single-layer stacks do not carry a
garbage (tp-layers nil) property. Consumers must therefore tolerate
an absent `tp-layers' property (both `plist-get' and
`tp--stack-map-region' do)."
(cond
((null layer-list) nil)
((null (cdr layer-list)) (copy-sequence (car layer-list)))
(t (append (car layer-list)
(list 'tp-layers (cdr layer-list))))))
;;; Queries
(defun tp-region-layer-props (start end layer-name &optional object)
"Return layer properties for LAYER-NAME in region from START to END.
OBJECT defaults to current buffer.
Returns a list of (START END PROPERTIES) for matching intervals."
(tp-intervals-map
(lambda (i-start i-end top belows)
Returns a list of (START END PROPERTIES) for matching intervals, with
positions in OBJECT's native coordinates (0-based for strings, 1-based
for buffers) and clipped to the requested region."
(tp--stack-map-region
start end object
(lambda (abs-start abs-end stack)
(when-let ((props (seq-find
(lambda (props)
(equal layer-name
(plist-get props 'tp-name)))
(append (list top) belows))))
(list (+ start i-start) (+ start i-end) props)))
start end object))
stack)))
(list abs-start abs-end props)))))
(defun tp--parse-layer-args (args)
"Parse flexible layer function arguments.
Returns (START END LAYER-SPEC IDX OBJECT) for buffer/string range,
or (STRING LAYER-SPEC IDX nil nil) for entire string."
(defun tp-layer-list (start end &optional object)
"Return list of all layer names in region from START to END."
(let ((layers nil))
(tp--stack-map-region
start end object
(lambda (_abs-start _abs-end stack)
(dolist (layer stack)
(when-let ((name (plist-get layer 'tp-name)))
(cl-pushnew name layers :test #'equal)))))
(nreverse layers)))
(defun tp-layer-count (start end &optional object)
"Return number of layers in region from START to END.
OBJECT defaults to current buffer."
(let ((max-count 0))
(tp--stack-map-region
start end object
(lambda (_abs-start _abs-end stack)
(setq max-count (max max-count (length stack)))))
max-count))
(defun tp-layer-exists-p (start end name &optional object)
"Return t if layer NAME exists in region from START to END.
OBJECT defaults to current buffer."
(not (null (tp-region-layer-props start end name object))))
(defun tp-layer-top (start end &optional object)
"Return the name of the topmost named layer in START..END of OBJECT.
Scans the region's property runs in order and returns the `tp-name'
of the first top layer that has one, so bare or unnamed runs (for
example before a layer that starts mid-region) do not hide layers
later in the region. Returns nil when no run in the region has a
named top layer. OBJECT defaults to current buffer."
(car (tp--stack-map-region
start end object
(lambda (_abs-start _abs-end stack)
(plist-get (car stack) 'tp-name)))))
;;; Layer spec normalization for tp-put-layer
(defun tp--put-layer-specs (layer-spec)
"Normalize LAYER-SPEC into a list of layer plists for `tp-put-layer'.
LAYER-SPEC can be:
- a layer name or group name (symbol);
- (LAYER-NAME ARG) or (GROUP-NAME ARG) for parameterized layers/groups;
- an inline plist, e.g. (face bold) or (:foreground \"red\");
- (NAME PROP VAL ...) for a named inline layer;
- a list of any of the above.
An inline plist is recognized by its even length together with a head
that is a keyword or an ordinary property symbol (one that is not a
defined layer or group name); a named inline layer has odd length
\(NAME plus prop/value pairs)."
(cond
;; First arg is a string - apply to entire string
;; (tp-put-layer string layer idx)
((stringp (car args))
(list (car args) (cadr args) (caddr args) nil nil))
;; First arg is a number - buffer/string region
;; (tp-put-layer start end layer idx object)
((numberp (car args))
(list (car args) (cadr args) (caddr args) (cadddr args) (nth 4 args)))
(t (error "Invalid arguments: %S" args))))
;; Group name symbol.
((and (symbolp layer-spec)
(assoc layer-spec tp-layer-groups))
(if (tp-group-parameterized-p layer-spec)
(error "Parameterized group %S requires an argument, use '(%S ARG)"
layer-spec layer-spec)
(tp-group-props layer-spec t))) ; include tp-name for layer stack
;; Any other symbol: a single layer name.
((symbolp layer-spec)
(list (tp--normalize-layer-spec layer-spec)))
;; (GROUP-NAME ARG): parameterized group.
((and (consp layer-spec)
(symbolp (car layer-spec))
(= (safe-length layer-spec) 2)
(tp-group-parameterized-p (car layer-spec)))
(tp-group-props-with-arg (car layer-spec) (cadr layer-spec) t))
;; (LAYER-NAME ARG): parameterized layer.
((and (consp layer-spec)
(symbolp (car layer-spec))
(= (safe-length layer-spec) 2)
(tp-layer-parameterized-p (car layer-spec)))
(list (tp--normalize-layer-spec layer-spec)))
;; Keyword-headed plist: a single inline layer.
((and (consp layer-spec) (keywordp (car layer-spec)))
(list (tp--normalize-layer-spec layer-spec)))
;; Even-length plist headed by an ordinary (non-layer) property
;; symbol, e.g. (face bold): a single inline layer.
((and (consp layer-spec)
(car layer-spec)
(symbolp (car layer-spec))
(not (tp--is-layer-name-p (car layer-spec)))
(proper-list-p layer-spec)
(cl-evenp (length layer-spec)))
(list layer-spec))
;; List whose every element is itself a spec (a layer/group name or
;; a list): multiple layers.
((and (consp layer-spec)
(proper-list-p layer-spec)
(cl-every (lambda (el)
(or (consp el) (tp--is-layer-name-p el)))
layer-spec))
(apply #'append (mapcar #'tp--put-layer-specs layer-spec)))
;; Anything else, including (NAME PROP VAL ...) named inline
;; layers; tp--normalize-layer-spec signals on invalid specs.
(t
(list (tp--normalize-layer-spec layer-spec)))))
;;; Mutators
(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object)
"Set layer(s) at a specific index position.
@ -58,13 +218,15 @@ or (STRING LAYER-SPEC IDX nil nil) for entire string."
Calling conventions:
1. Buffer/string region:
(tp-put-layer START END LAYER IDX OBJECT)
2. Entire string:
(tp-put-layer STRING LAYER IDX)
LAYER can be:
- A symbol (layer name from tp-layer-alist or tp-layer-groups)
- A plist (inline layer definition)
- A symbol (layer name from `tp-layer-alist' or `tp-layer-groups')
- A list (LAYER-NAME ARG) or (GROUP-NAME ARG) for parameterized
layers or groups
- A plist (inline layer definition), e.g. (face bold)
- A list (NAME &rest PLIST) for named inline layer
- A list of the above for multiple layers
@ -73,68 +235,26 @@ IDX specifies where to insert:
- -1 means bottom
- Other values insert at that position
OBJECT defaults to current buffer for region form."
(let (start end layer-spec idx obj)
(cond
;; Entire string form: (tp-put-layer string layer idx)
((stringp start-or-string)
(setq obj start-or-string
start 0
end (length start-or-string)
layer-spec end-or-layer
idx (or layer-or-idx 0)))
;; Region form: (tp-put-layer start end layer idx object)
((numberp start-or-string)
(setq start start-or-string
end end-or-layer
layer-spec layer-or-idx
idx (or idx-or-object 0)
obj object)))
;; Normalize layer-spec to a list of layer property lists
(let ((layers-to-add
(cond
;; Check if it's a group name
((and (symbolp layer-spec)
(assoc layer-spec tp-layer-groups))
(tp-group-props layer-spec t)) ; include tp-name for layer stack
;; Single layer spec
((or (symbolp layer-spec)
(and (listp layer-spec)
(or (keywordp (car layer-spec))
(and (symbolp (car layer-spec))
(cdr layer-spec)
(not (listp (cadr layer-spec)))))))
(list (tp--normalize-layer-spec layer-spec)))
;; List of layer specs (multiple layers)
((and (listp layer-spec)
(listp (car layer-spec)))
(mapcar #'tp--normalize-layer-spec layer-spec))
(t (list (tp--normalize-layer-spec layer-spec))))))
;; Apply layers at specified index
(if (tp-empty-p (or obj (current-buffer)))
;; No existing properties
(set-text-properties start end
(tp--build-layer-props layers-to-add)
obj)
;; Has existing properties
(tp-intervals-map
(lambda (i-start i-end top belows)
(let* ((current-stack (tp--layer-stack-to-list top belows))
(actual-idx (cond
((= idx 0) 0)
((< idx 0) (max 0 (+ (length current-stack) 1 idx)))
(t (min idx (length current-stack)))))
;; Insert new layers at the specified position
(new-stack (append (seq-take current-stack actual-idx)
layers-to-add
(seq-drop current-stack actual-idx))))
(set-text-properties
(+ start i-start) (+ start i-end)
(tp--build-layer-props new-stack)
obj)))
start end obj)))
OBJECT defaults to current buffer for region form. Only text inside
\[START, END) is modified."
(pcase-let ((`(,start ,end ,obj ,layer-spec ,idx)
(tp--parse-layer-args
start-or-string
(list end-or-layer layer-or-idx idx-or-object object) 2)))
(setq idx (or idx 0))
(let ((layers-to-add (tp--put-layer-specs layer-spec)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((actual-idx (if (< idx 0)
(max 0 (+ (length stack) 1 idx))
(min idx (length stack))))
(new-stack (append (seq-take stack actual-idx)
layers-to-add
(seq-drop stack actual-idx))))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)))))
(or obj (cons start end))))
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object)
@ -145,14 +265,14 @@ This is equivalent to (tp-put-layer ... LAYER 0 ...).
Calling conventions:
1. Buffer/string region:
(tp-push-layer START END LAYER OBJECT)
2. Entire string:
(tp-push-layer STRING LAYER)"
(cond
((stringp start-or-string)
(tp-put-layer start-or-string end-or-layer 0))
((numberp start-or-string)
(tp-put-layer start-or-string end-or-layer layer-or-object 0 object))))
(pcase-let ((`(,start ,end ,obj ,layer)
(tp--parse-layer-args
start-or-string
(list end-or-layer layer-or-object object) 1)))
(tp-put-layer start end layer 0 obj)))
(defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object)
"Delete layer by name or index.
@ -160,37 +280,27 @@ Calling conventions:
Calling conventions:
1. Buffer/string region:
(tp-delete-layer START END LAYER-NAME/IDX OBJECT)
2. Entire string:
(tp-delete-layer STRING LAYER-NAME/IDX)
LAYER-NAME/IDX can be:
- A symbol (layer name)
- An integer (layer index, 0=top, -1=bottom)"
(let (start end layer-id obj)
(cond
((stringp start-or-string)
(setq obj start-or-string
start 0
end (length start-or-string)
layer-id end-or-idx))
((numberp start-or-string)
(setq start start-or-string
end end-or-idx
layer-id idx-or-object
obj object)))
(tp-intervals-map
(lambda (i-start i-end top belows)
(let* ((current-stack (tp--layer-stack-to-list top belows))
(found (tp--get-layer-by-idx-or-name current-stack layer-id)))
(when found
(let ((new-stack (-remove-at (car found) current-stack)))
(set-text-properties
(+ start i-start) (+ start i-end)
(tp--build-layer-props new-stack)
obj)))))
start end obj)
- An integer (layer index, 0=top, -1=bottom)
Only text inside [START, END) is modified."
(pcase-let ((`(,start ,end ,obj ,layer-id)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-object object) 1)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack layer-id)))
(set-text-properties
abs-start abs-end
(tp--stack-build-props (-remove-at (car found) stack))
obj))))
nil))
(defun tp-pop-layer (start-or-string &optional end-or-object object)
@ -201,20 +311,20 @@ This is equivalent to (tp-delete-layer ... 0 ...).
Calling conventions:
1. Buffer/string region:
(tp-pop-layer START END OBJECT)
2. Entire string:
(tp-pop-layer STRING)"
(cond
((stringp start-or-string)
(tp-delete-layer start-or-string 0))
((numberp start-or-string)
(tp-delete-layer start-or-string end-or-object 0 object))))
(pcase-let ((`(,start ,end ,obj)
(tp--parse-layer-args
start-or-string (list end-or-object object) 0)))
(tp-delete-layer start end 0 obj)))
(defun tp--move-layer-in-stack (stack from-id to-idx)
"Move layer at FROM-ID to TO-IDX position in STACK.
FROM-ID can be an integer index or a layer name symbol.
TO-IDX must be an integer index.
Both indices refer to positions before the move and can be negative (counting from end).
Both indices refer to positions before the move and can be negative
\(counting from end).
TO-IDX is clamped to valid range (0 to stack length - 1) if out of bounds.
Returns the new stack, or nil if FROM-ID is invalid."
(let* ((len (length stack))
@ -289,33 +399,17 @@ 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."
(let (start end from-id to-idx obj)
(cond
;; Entire string form: (tp-move-layer string from-id to-idx)
((stringp start-or-string)
(setq obj start-or-string
start 0
end (length start-or-string)
from-id end-or-from
to-idx from-or-to))
;; Region form: (tp-move-layer start end from-id to-idx object)
((numberp start-or-string)
(setq start start-or-string
end end-or-from
from-id from-or-to
to-idx to-or-object
obj object)))
(tp-intervals-map
(lambda (i-start i-end top belows)
(let* ((current-stack (tp--layer-stack-to-list top belows))
(new-stack (tp--move-layer-in-stack current-stack from-id to-idx)))
(when new-stack
(set-text-properties
(+ start i-start) (+ start i-end)
(tp--build-layer-props new-stack)
obj))))
start end obj)
(pcase-let ((`(,start ,end ,obj ,from-id ,to-idx)
(tp--parse-layer-args
start-or-string
(list end-or-from from-or-to to-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(defun tp-raise-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object)
@ -324,39 +418,27 @@ OBJECT defaults to current buffer for region form."
Calling conventions:
1. Buffer/string region:
(tp-raise-layer START END IDX/LAYER-NAME N OBJECT)
2. Entire string:
(tp-raise-layer STRING IDX/LAYER-NAME N)
Positive N moves the layer up (toward top/visible).
Negative N moves the layer down (toward bottom).
Uses `tp--raise-layer-in-stack' internally, which is built on `tp--move-layer-in-stack'."
(let (start end layer-id n obj)
(cond
((stringp start-or-string)
(setq obj start-or-string
start 0
end (length start-or-string)
layer-id end-or-idx
n (or idx-or-n 1)))
((numberp start-or-string)
(setq start start-or-string
end end-or-idx
layer-id idx-or-n
n (or n-or-object 1)
obj object)))
(tp-intervals-map
(lambda (i-start i-end top belows)
(let* ((current-stack (tp--layer-stack-to-list top belows))
(new-stack (tp--raise-layer-in-stack current-stack layer-id n)))
(when new-stack
(set-text-properties
(+ start i-start) (+ start i-end)
(tp--build-layer-props new-stack)
obj))))
start end obj)
Uses `tp--raise-layer-in-stack' internally, which is built on
`tp--move-layer-in-stack'."
(pcase-let ((`(,start ,end ,obj ,layer-id ,n)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-n n-or-object object) 2)))
(setq n (or n 1))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(defun tp-rotate-layer (start-or-string &optional end-or-object object)
@ -365,16 +447,15 @@ Uses `tp--raise-layer-in-stack' internally, which is built on `tp--move-layer-in
Calling conventions:
1. Buffer/string region:
(tp-rotate-layer START END OBJECT)
2. Entire string:
(tp-rotate-layer STRING)
Uses `tp-move-layer' internally to move layer at index 0 to index -1."
(cond
((stringp start-or-string)
(tp-move-layer start-or-string 0 -1))
((numberp start-or-string)
(tp-move-layer start-or-string end-or-object 0 -1 object))))
(pcase-let ((`(,start ,end ,obj)
(tp--parse-layer-args
start-or-string (list end-or-object object) 0)))
(tp-move-layer start end 0 -1 obj)))
(defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object)
"Pin a layer to the top (make it visible).
@ -382,16 +463,16 @@ Uses `tp-move-layer' internally to move layer at index 0 to index -1."
Calling conventions:
1. Buffer/string region:
(tp-pin-layer START END IDX/LAYER-NAME OBJECT)
2. Entire string:
(tp-pin-layer STRING IDX/LAYER-NAME)
Uses `tp-move-layer' internally to move the specified layer to index 0 (top)."
(cond
((stringp start-or-string)
(tp-move-layer start-or-string end-or-idx 0))
((numberp start-or-string)
(tp-move-layer start-or-string end-or-idx idx-or-object 0 object))))
(pcase-let ((`(,start ,end ,obj ,layer-id)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-object object) 1)))
(tp-move-layer start end layer-id 0 obj)))
(defun tp-switch-layer (start-or-string &optional end-or-id1 id1-or-id2 id2-or-object object)
"Switch between two layers by name or index.
@ -399,96 +480,81 @@ Uses `tp-move-layer' internally to move the specified layer to index 0 (top)."
Calling conventions:
1. Buffer/string region:
(tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT)
2. Entire string:
(tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)
Uses `tp--switch-layers-in-stack' internally."
(let (start end id1 id2 obj)
(cond
((stringp start-or-string)
(setq obj start-or-string
start 0
end (length start-or-string)
id1 end-or-id1
id2 id1-or-id2))
((numberp start-or-string)
(setq start start-or-string
end end-or-id1
id1 id1-or-id2
id2 id2-or-object
obj object)))
(tp-intervals-map
(lambda (i-start i-end top belows)
(let* ((current-stack (tp--layer-stack-to-list top belows))
(new-stack (tp--switch-layers-in-stack current-stack id1 id2)))
(when new-stack
(set-text-properties
(+ start i-start) (+ start i-end)
(tp--build-layer-props new-stack)
obj))))
start end obj)
(pcase-let ((`(,start ,end ,obj ,id1 ,id2)
(tp--parse-layer-args
start-or-string
(list end-or-id1 id1-or-id2 id2-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(defun tp--merge-layer-props (layers initial)
"Merge the plists of LAYERS into the INITIAL plist and return it.
LAYERS is a list of (INDEX . PROPS) conses as returned by
`tp--get-layer-by-idx-or-name'. Earlier layers take precedence: a key
already present in the accumulator is never overwritten, and presence
is tested with `plist-member' so an explicit nil value in a higher
layer shadows lower layers' values. `tp-name' keys of the merged
layers are dropped (INITIAL may seed its own)."
(cl-reduce (lambda (acc layer)
(cl-loop for (key val) on (cdr layer) by #'cddr
unless (eq key 'tp-name)
do (unless (plist-member acc key)
(setq acc (plist-put acc key val))))
acc)
layers
:initial-value initial))
(defun tp-merge-layers (start-or-string &optional end-or-name name-or-ids ids-or-object object)
"Merge specified layers into a new layer.
Calling conventions:
1. Buffer/string region:
(tp-merge-layers START END NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...) OBJECT)
(tp-merge-layers START END NEW-LAYER-NAME
\\='(IDX1 LAYER-NAME1 IDX2 ...) OBJECT)
2. Entire string:
(tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...))"
(let (start end new-name layer-ids obj)
(cond
((stringp start-or-string)
(setq obj start-or-string
start 0
end (length start-or-string)
new-name end-or-name
layer-ids name-or-ids))
((numberp start-or-string)
(setq start start-or-string
end end-or-name
new-name name-or-ids
layer-ids ids-or-object
obj object)))
(tp-intervals-map
(lambda (i-start i-end top belows)
(let* ((current-stack (tp--layer-stack-to-list top belows))
;; Find all layers to merge
(layers-to-merge
(tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...))
Earlier layers in the list take precedence; a property explicitly set
to nil in a higher-precedence layer stays nil in the merged layer."
(pcase-let ((`(,start ,end ,obj ,new-name ,layer-ids)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-ids ids-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((layers-to-merge
(cl-loop for id in layer-ids
for found = (tp--get-layer-by-idx-or-name current-stack id)
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
(cl-reduce (lambda (acc layer)
(let ((props (cdr layer)))
(cl-loop for (key val) on props by #'cddr
do (unless (plist-get acc key)
(setq acc (plist-put acc key val))))
acc))
layers-to-merge
:initial-value (list 'tp-name new-name)))
;; Remove old layers from stack
(indices-to-remove (mapcar #'car sorted-layers))
(new-stack current-stack))
(dolist (idx indices-to-remove)
(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
(+ start i-start) (+ start i-end)
(tp--build-layer-props new-stack)
obj)))))
start end obj)
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))))
nil))
(defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object)
@ -497,90 +563,29 @@ Calling conventions:
Calling conventions:
1. Buffer/string region:
(tp-flatten-layers START END NAME OBJECT)
2. Entire string:
(tp-flatten-layers STRING NAME)
NAME can be nil for an unnamed layer."
(let (start end name obj)
(cond
((stringp start-or-string)
(setq obj start-or-string
start 0
end (length start-or-string)
name end-or-name))
((numberp start-or-string)
(setq start start-or-string
end end-or-name
name name-or-object
obj object)))
(tp-intervals-map
(lambda (i-start i-end top belows)
(let* ((current-stack (tp--layer-stack-to-list top belows))
(layer-count (length current-stack)))
(when (> layer-count 0)
;; Create list of all indices
(let ((all-ids (cl-loop for i from 0 below layer-count collect i)))
;; Use merge with all layers
(let* ((layers-to-merge
(cl-loop for id in all-ids
for found = (tp--get-layer-by-idx-or-name
current-stack id)
when found collect found))
(merged-props
(cl-reduce (lambda (acc layer)
(let ((props (cdr layer)))
(cl-loop for (key val) on props by #'cddr
unless (eq key 'tp-name)
do (unless (plist-get acc key)
(setq acc (plist-put acc key val))))
acc))
layers-to-merge
:initial-value (if name (list 'tp-name name) nil))))
(set-text-properties
(+ start i-start) (+ start i-end)
merged-props
obj))))))
start end obj)
NAME can be nil for an unnamed layer. Higher layers take precedence;
a property explicitly set to nil in a higher layer stays nil in the
flattened result."
(pcase-let ((`(,start ,end ,obj ,name)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-object object) 1)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when stack
(let ((merged-props (tp--merge-layer-props
(cl-loop for layer in stack
for i from 0
collect (cons i layer))
(when name (list 'tp-name name)))))
(set-text-properties abs-start abs-end merged-props obj)))))
nil))
(defun tp-layer-list (start end &optional object)
"Return list of all layer names in region from START to END."
(let ((layers nil))
(tp-intervals-map
(lambda (_i-start _i-end top belows)
(when-let ((name (plist-get top 'tp-name)))
(cl-pushnew name layers :test #'equal))
(dolist (below belows)
(when-let ((name (plist-get below 'tp-name)))
(cl-pushnew name layers :test #'equal))))
start end object)
(nreverse layers)))
(defun tp-layer-count (start end &optional object)
"Return number of layers in region from START to END.
OBJECT defaults to current buffer."
(let ((max-count 0))
(tp-intervals-map
(lambda (_i-start _i-end top belows)
(let ((count (+ (if top 1 0) (length belows))))
(when (> count max-count)
(setq max-count count))))
start end object)
max-count))
(defun tp-layer-exists-p (start end name &optional object)
"Return t if layer NAME exists in region from START to END.
OBJECT defaults to current buffer."
(not (null (tp-region-layer-props start end name object))))
(defun tp-layer-top (start end &optional object)
"Return the name of the top layer at START in OBJECT.
OBJECT defaults to current buffer."
(when-let ((intervals (tp-intervals start end object)))
(plist-get (nth 2 (car intervals)) 'tp-name)))
(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.
@ -612,7 +617,9 @@ Returns the modified object (string) or nil for buffer operations."
(setq start start-or-string
end end-or-plist
plist plist-or-object
obj (car rest))))
obj (car rest)))
(t (error "Invalid layer arguments: %S"
(cons start-or-string (list end-or-plist plist-or-object)))))
;; Handle plist wrapped in a list (from region form)
(when (and (listp plist)
@ -621,28 +628,27 @@ Returns the modified object (string) or nil for buffer operations."
(setq plist (car plist)))
;; Process each interval
(tp-intervals-map
(lambda (i-start i-end top belows)
(let* ((current-stack (tp--layer-stack-to-list top belows))
(modified-stack
(cl-loop for layer in current-stack
for i from 0
collect
(if (cl-some
(lambda (id)
(let ((found (tp--get-layer-by-idx-or-name
current-stack id)))
(and found (= (car found) i))))
layer-ids)
;; Merge plist into this layer
(tp--deep-merge-plist layer plist)
;; Keep layer unchanged
layer))))
(set-text-properties
(+ start i-start) (+ start i-end)
(tp--build-layer-props modified-stack)
obj)))
start end obj)
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let ((modified-stack
(cl-loop for layer in stack
for i from 0
collect
(if (cl-some
(lambda (id)
(let ((found (tp--get-layer-by-idx-or-name
stack id)))
(and found (= (car found) i))))
layer-ids)
;; Merge plist into this layer
(tp--deep-merge-plist layer plist)
;; Keep layer unchanged
layer))))
(when stack
(set-text-properties abs-start abs-end
(tp--stack-build-props modified-stack)
obj)))))
(if (stringp obj) obj nil)))
(defun tp-add-to-all-layers (start-or-string &optional end-or-plist plist-or-object &rest rest)
@ -682,7 +688,9 @@ Returns the modified object (string) or nil for buffer operations."
(setq start start-or-string
end end-or-plist
plist plist-or-object
obj (car rest))))
obj (car rest)))
(t (error "Invalid layer arguments: %S"
(cons start-or-string (list end-or-plist plist-or-object)))))
;; Handle plist wrapped in a list (from region form)
(when (and (listp plist)

9
tp-tests.el
View File

@ -680,9 +680,16 @@ leak between tests regardless of how BODY exits."
(insert "Hello World")
(tp-set 1 6 '(face bold))
(goto-char 12)
;; Explicit VALUE finds the previous region carrying that value.
(let ((match (tp-backward 'face 'bold)))
(should match)
(should (= (prop-match-beginning match) 1)))
;; VALUE nil equal-matches the property-absent region, mirroring
;; tp-forward (see tp-test-forward).
(goto-char 12)
(let ((match (tp-backward 'face)))
(should match)
(should (= (prop-match-beginning match) 1)))))
(should (= (prop-match-beginning match) 6)))))
(ert-deftest tp-test-backward-on-string ()
"Test tp-backward works on string objects."