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. TRANSFORM-FN receives the value and returns the transformed value.
Used for tp-text transformations like formatting numbers or dates.") 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) (defun tp--expand-layer-to-props-list (layer-name str start)
"Expand LAYER-NAME to a list of property keys it contributes. "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 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 - Keyword arguments starting with :props, :data, :compute, :watch, or :transform
(reactive format - only for non-parameterized layers with $-prefixed variables) (reactive format - only for non-parameterized layers with $-prefixed variables)
In simple format, exactly one body form is accepted; supplying more
than one signals an error at macro-expansion time instead of silently
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', Note: NAME cannot be a built-in Emacs text property name like `face',
`display', `invisible', etc. See `tp--builtin-text-properties' for the `display', `invisible', etc. See `tp--builtin-text-properties' for the
complete list of reserved names." complete list of reserved names."
@ -321,17 +370,21 @@ complete list of reserved names."
;; Non-parameterized reactive: use tp--define-layer-internal directly ;; Non-parameterized reactive: use tp--define-layer-internal directly
`(tp--define-layer-internal ',name ,@body)) `(tp--define-layer-internal ',name ,@body))
;; Simple format (original behavior) ;; Simple format (original behavior)
(let ((simple-body (car body))) (progn
(cond (when (cdr body)
;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM) (error "define-tp %s: simple format takes exactly one body form, got %d (use the :props keyword format to combine multiple components)"
((null arglist) name (length body)))
`(tp--define-layer-unified ',name nil ,simple-body)) (let ((simple-body (car body)))
;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM) (cond
((and (= (length arglist) 1) ;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM)
(symbolp (car arglist))) ((null arglist)
`(tp--define-layer-unified ',name ',arglist ',simple-body)) `(tp--define-layer-unified ',name nil ,simple-body))
(t ;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM)
(error "define-tp ARGLIST must be empty or contain exactly one symbol"))))))) ((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) (defun tp--define-layer-unified (name arglist body)
"Define a layer NAME with ARGLIST and BODY using unified structure. "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 Returns a cons cell (LAYER-NAME . PROPERTIES) or a symbol if ELEMENT
references an already-defined layer. 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))) (let ((format (tp--layer-group-element-format element)))
(pcase format (pcase format
('symbol element) ('symbol element)
('format-4 ('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)) (let* ((layer-suffix (car element))
(layer-name (intern (format "%s-%s" group-name layer-suffix))) (layer-name (intern (format "%s-%s" group-name layer-suffix)))
(rest (cdr element)) (rest (cdr element))
(props nil) (props nil)
(data nil) (data nil)
(watch nil) (watch nil)
(compute nil)) (compute nil)
(transform nil))
;; Parse keyword arguments ;; Parse keyword arguments
(while rest (while rest
(pcase (car 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))) (:data (setq data (cadr rest) rest (cddr rest)))
(:watch (setq watch (cadr rest) rest (cddr rest))) (:watch (setq watch (cadr rest) rest (cddr rest)))
(:compute (setq compute (cadr rest) rest (cddr rest))) (:compute (setq compute (cadr rest) rest (cddr rest)))
(_ (setq rest (cdr rest))))) (:transform (setq transform (cadr rest) rest (cddr rest)))
(list layer-name :props props :data data :watch watch :compute compute))) (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 ('format-3
(let* ((layer-suffix (car element)) (let* ((layer-suffix (car element))
(layer-name (intern (format "%s-%s" group-name layer-suffix))) (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))) (cons layer-name element)))
(_ (error "Invalid layer group element: %S" 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. "Internal helper to define a layer from parsed components.
LAYER-NAME is the symbol name for the layer. LAYER-NAME is the symbol name for the layer.
PROPS is the property list. PROPS is the property list.
DATA is the list of data variables. DATA is the list of data variables.
WATCH is the list of watcher definitions. 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)) (let* ((reactive-syms (tp--collect-reactive-symbols props))
(computed-vars (when compute (mapcar #'car compute))) (computed-vars (when compute (mapcar #'car compute)))
(all-reactive-syms (delete-dups reactive-syms)) (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'." and the group itself is stored in `tp-layer-groups'."
(declare (indent defun)) (declare (indent defun))
(let ((layer-names nil) (let ((layer-names nil)
(generated nil)
(idx 0)) (idx 0))
(dolist (element elements) (dolist (element elements)
(let ((parsed (tp--parse-layer-group-element name element idx))) (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) ;; Reference to existing layer (symbol)
((symbolp parsed) ((symbolp parsed)
(push parsed layer-names)) (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)) ((and (listp parsed) (plist-get (cdr parsed) :props))
(let* ((layer-name (car parsed)) (let* ((layer-name (car parsed))
(props (plist-get (cdr parsed) :props)) (props (plist-get (cdr parsed) :props))
(data (plist-get (cdr parsed) :data)) (data (plist-get (cdr parsed) :data))
(watch (plist-get (cdr parsed) :watch)) (watch (plist-get (cdr parsed) :watch))
(compute (plist-get (cdr parsed) :compute))) (compute (plist-get (cdr parsed) :compute))
(tp--define-layer-from-parsed layer-name props data watch compute) (transform (plist-get (cdr parsed) :transform)))
(push layer-name layer-names))) (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) ;; Simple format (cons cell of name . props)
((consp parsed) ((consp parsed)
(let* ((layer-name (car parsed)) (let* ((layer-name (car parsed))
(props (cdr parsed))) (props (cdr parsed)))
(tp--define-layer-from-parsed layer-name props nil nil nil) (tp--define-layer-from-parsed layer-name props nil nil nil)
(push layer-name layer-names) (push layer-name layer-names)
(push layer-name generated)
;; Only increment idx for anonymous (Format 1) elements ;; Only increment idx for anonymous (Format 1) elements
(when (eq (tp--layer-group-element-format element) 'format-1) (when (eq (tp--layer-group-element-format element) 'format-1)
(cl-incf idx))))))) (cl-incf idx)))))))
(setq layer-names (nreverse layer-names)) (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) (tp--set-group-layers name layer-names)
(assoc name tp-layer-groups))) (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) (defun tp--define-layer-group-unified (name arglist body-form)
"Define a parameterized layer group NAME with ARGLIST and 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))) (let ((entry (list arglist body-form)))
(if (assoc name tp-layer-groups) (if (assoc name tp-layer-groups)
(setf (cdr (assoc name tp-layer-groups)) entry) (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 1. Old format (from tp--set-layer-props): (LAYER-NAME . PLIST) - flat plist
2. Unified format (from define-tp): (LAYER-NAME ARGLIST BODY-FORM) 2. Unified format (from define-tp): (LAYER-NAME ARGLIST BODY-FORM)
For parameterized layers (ARGLIST non-nil), returns nil - use `tp-layer-props-with-arg'. For parameterized layers (ARGLIST non-nil), returns nil - use `tp-layer-props-with-arg'.
Recursively expands any nested layer names in the returned plist." 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)))) (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 ;; 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)))) (tp--layer-has-reactive-deps-p layer-name))))
(cond (copy-tree
;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list (cond
;; Check: exactly 2 elements and first is nil or a list of symbols ;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list
((and (= (length entry) 2) ;; Check: exactly 2 elements and first is nil or a list of symbols
(or (null (car entry)) ((and (= (length entry) 2)
(and (listp (car entry)) (or (null (car entry))
(cl-every #'symbolp (car entry))))) (and (listp (car entry))
(let ((arglist (car entry)) (cl-every #'symbolp (car entry)))))
(body (cadr entry))) (let ((arglist (car entry))
(if arglist (body (cadr entry)))
;; Parameterized - needs argument, return nil (if arglist
nil ;; Parameterized - needs argument, return nil
;; Non-parameterized - evaluate body and return props nil
(let ((plist (eval body))) ;; Non-parameterized - evaluate body and return props
(when plist (let ((plist (eval body)))
;; Recursively expand nested layer names (when plist
(when (tp--plist-has-layer-key-p plist) ;; Recursively expand nested layer names
(setq plist (tp--expand-layer-in-plist plist))) (when (tp--plist-has-layer-key-p plist)
(if needs-tp-name (setq plist (tp--expand-layer-in-plist plist)))
(append plist (list 'tp-name layer-name)) (if needs-tp-name
plist)))))) (append plist (list 'tp-name layer-name))
;; Old format: entry is just a flat plist plist))))))
(t ;; Old format: entry is just a flat plist
(let ((plist entry)) (t
;; Recursively expand nested layer names (let ((plist entry))
(when (tp--plist-has-layer-key-p plist) ;; Recursively expand nested layer names
(setq plist (tp--expand-layer-in-plist plist))) (when (tp--plist-has-layer-key-p plist)
(if needs-tp-name (setq plist (tp--expand-layer-in-plist plist)))
(append plist (list 'tp-name layer-name)) (if needs-tp-name
plist))))))) (append plist (list 'tp-name layer-name))
plist))))))))
(defun tp-layer-parameterized-p (layer-name) (defun tp-layer-parameterized-p (layer-name)
"Return non-nil if LAYER-NAME is a parameterized layer. "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. "Return properties for parameterized layer LAYER-NAME with ARG.
Evaluates the body form with the argument bound to the parameter. 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. 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)))) (when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
;; entry is (ARGLIST BODY-FORM) ;; entry is (ARGLIST BODY-FORM)
(let ((arglist (car entry)) (let ((arglist (car entry))
(body (cadr entry))) (body (cadr entry)))
(when arglist ; Only for parameterized layers (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 ;; Evaluate the body with the argument bound
(plist (eval `(let ((,arg-sym ',arg)) ,body)))) (plist (eval `(let ((,arg-sym ',arg)) ,body))))
(when plist (when plist
;; Recursively expand nested layer names ;; Recursively expand nested layer names
(when (tp--plist-has-layer-key-p plist) (when (tp--plist-has-layer-key-p plist)
(setq plist (tp--expand-layer-in-plist plist))) (setq plist (tp--expand-layer-in-plist plist)))
(if include-tp-name ;; Resolve $-prefixed reactive symbols to their current values
(append plist (list 'tp-name layer-name)) ;; so they never leak literally into the returned props.
plist))))))) (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) (defun tp-group-props (group-name &optional include-tp-name)
"Return list of properties for all layers in GROUP-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))) (not (null (car entry)))
(cl-every #'symbolp (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) (defun tp-group-props-with-arg (group-name arg &optional include-tp-name)
"Return list of properties for parameterized group GROUP-NAME with ARG. "Return list of properties for parameterized group GROUP-NAME with ARG.
Evaluates the body form with the argument bound to the parameter. 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." Returns a list of property lists for each layer in the group."
(when-let ((entry (cdr (assoc group-name tp-layer-groups)))) (when-let ((entry (cdr (assoc group-name tp-layer-groups))))
;; entry is (ARGLIST BODY-FORM) ;; 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)))) (layer-specs (eval `(let ((,arg-sym ',arg)) ,body-form))))
;; Convert layer specs to property lists ;; Convert layer specs to property lists
(mapcar (lambda (spec) (mapcar (lambda (spec)
(cond (tp--group-spec-to-props spec include-tp-name))
;; 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)))
layer-specs)))))) layer-specs))))))
(defun tp--is-layer-name-p (sym) (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 ;; Has reactive symbols - need anonymous tp-name for reactive tracking
(let* ((existing-tp-name (plist-get props 'tp-name)) (let* ((existing-tp-name (plist-get props 'tp-name))
(layer-name (or existing-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 ;; Resolve reactive symbols in expanded props
(resolved-props (tp--resolve-reactive-symbols expanded-props))) (resolved-props (tp--resolve-reactive-symbols expanded-props)))
;; Register reactive dependencies ;; 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 ;; Has reactive symbols - need anonymous tp-name for reactive tracking
(let* ((existing-tp-name (plist-get props 'tp-name)) (let* ((existing-tp-name (plist-get props 'tp-name))
(layer-name (or existing-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 ;; Resolve reactive symbols in expanded props
(resolved-props (tp--resolve-reactive-symbols expanded-props))) (resolved-props (tp--resolve-reactive-symbols expanded-props)))
;; Register reactive dependencies ;; Register reactive dependencies
@ -975,7 +1123,7 @@ For group names, includes `tp-layers' property with the full layer stack."
(if reactive-syms (if reactive-syms
;; Has reactive symbols - need to handle as anonymous reactive layer ;; Has reactive symbols - need to handle as anonymous reactive layer
(let* ((layer-name (or existing-tp-name (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 ;; Resolve reactive symbols to get current values
(resolved-props (tp--resolve-reactive-symbols props))) (resolved-props (tp--resolve-reactive-symbols props)))
;; Register this anonymous layer in tp-layer-alist with resolved 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) (tp-reactive-reset)
(setq tp-layer-alist nil) (setq tp-layer-alist nil)
(setq tp-layer-groups 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) (defun tp-undefine-layer (name)
"Remove layer NAME from `tp-layer-alist'. "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) (tp--unregister-reactive-deps name)
(setq tp-layer-alist (assq-delete-all name tp-layer-alist)) (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) (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))) (setq tp-layer-groups (assq-delete-all name tp-layer-groups)))
(defun tp--normalize-layer-spec (layer-spec) (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 ...)).") "Alist of data variables: (LAYER-NAME . (VAR-SYMBOL ...)).")
(defvar tp--batch-update-pending nil (defvar tp--batch-update-pending nil
"When non-nil, reactive updates are being batched. "Queue of deferred reactive buffer re-renders.
This is a list of (LAYER-NAME . CHANGED-VARS) pairs pending update.") 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 (defvar tp--batch-update-active nil
"When non-nil, we are inside a `tp-with-batch-updates' form.") "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) (defun tp--register-reactive-deps (layer-name reactive-symbols props)
"Register REACTIVE-SYMBOLS as dependencies for LAYER-NAME. "Register REACTIVE-SYMBOLS as dependencies for LAYER-NAME.
PROPS is the original property specification with reactive symbols. 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) (defun tp--apply-initial-computed (compute)
"Apply initial computed values using COMPUTE definitions. "Apply initial computed values using COMPUTE definitions.
COMPUTE is a list of (VAR-SYMBOL COMPUTE-FN) pairs. 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) (dolist (comp compute)
(let* ((var-sym (car comp)) (let* ((var-sym (car comp))
(compute-fn (cadr comp)) (compute-fn (cadr comp))
@ -254,8 +293,8 @@ Sets the global variables to their computed values."
(funcall compute-fn) (funcall compute-fn)
(error (error
(message "tp: initial compute error for %s: %s" var-sym err) (message "tp: initial compute error for %s: %s" var-sym err)
nil)))) tp--compute-error))))
(when val (unless (eq val tp--compute-error)
(set var-sym val))))) (set var-sym val)))))
(defun tp--data-var-symbol (data-entry) (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-ops)
(require 'tp-search) (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) (defun tp--update-layer-computed (layer-name override-alist)
"Update computed reactive variables for LAYER-NAME with OVERRIDE-ALIST. "Update computed reactive variables for LAYER-NAME with OVERRIDE-ALIST.
Evaluates compute functions and updates the reactive variable values. 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." Returns an updated override-alist with the new computed values."
(when-let ((computed (cdr (assoc layer-name tp-layer-computed)))) (when-let ((computed (cdr (assoc layer-name tp-layer-computed))))
(dolist (comp computed) (dolist (comp computed)
@ -45,8 +80,8 @@ Returns an updated override-alist with the new computed values."
(error (error
(message "tp: compute error for %s.%s: %s" (message "tp: compute error for %s.%s: %s"
layer-name var-sym err) layer-name var-sym err)
nil)))) tp--compute-error))))
(when computed-val (unless (eq computed-val tp--compute-error)
;; Update the global variable ;; Update the global variable
(set var-sym computed-val) (set var-sym computed-val)
;; Add to override-alist for property resolution ;; 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 ;; Also update the layer properties if the computed var is used in props
(let ((current-props (cdr (assoc layer-name tp-layer-alist)))) (let ((current-props (cdr (assoc layer-name tp-layer-alist))))
(when current-props (when current-props
;; Collect all reactive props for this layer from tp-reactive-deps (when-let ((all-reactive-props (tp--layer-reactive-props layer-name)))
(let ((all-reactive-props nil)) (let ((resolved-props (tp--resolve-reactive-symbols
(dolist (dep tp-reactive-deps) all-reactive-props override-alist)))
(let ((layer-entry (assoc layer-name (cdr dep)))) (when resolved-props
(when (and layer-entry (cdr layer-entry)) ;; Deep-merge the resolved props into the current layer
;; Merge the reactive props ;; props so sibling static attributes nested in plists
(cl-loop for (key val) on (cdr layer-entry) by #'cddr ;; (e.g. a :background next to a reactive :foreground)
do (setq all-reactive-props ;; survive the update.
(plist-put all-reactive-props key val)))))) (tp--set-layer-props
(when all-reactive-props layer-name
(let ((resolved-props (tp--resolve-reactive-symbols (tp--deep-merge-plist current-props resolved-props)))))))))))
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)))))))))))
override-alist) 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. "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: WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case). - If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update all buffers that have the text property (setq case)." - If WHERE is nil, update all buffers that have the text property.
(let ((props (tp-layer-props layer-name t))) ; include tp-name for reactive tracking
(when props OVERRIDE-ALIST maps reactive variables to their new values when the
;; Callback for tp-search-map: applies props to matched region. watcher fires before the variables are set; layer props are
;; _TEXT is unused (the matched text), START and END are buffer positions. re-resolved against it in each target buffer, so buffer-local
;; Returns nil to prevent tp-search-map from replacing the text. variable values are honored."
(let ((apply-props-fn (lambda (_text start end) (let ((update-buffer
(tp-add start end props) (lambda ()
nil))) (let ((props (tp--layer-render-props layer-name override-alist)))
(if (and where (bufferp where) (buffer-live-p where)) (when props
;; setq-local case: only update the specific buffer (save-excursion
(tp-with-current-buffer where ;; Callback for tp-search-map: replaces the layer's own
(save-excursion ;; property keys on the matched region. Returns nil to
(tp-search-map apply-props-fn 'tp-name layer-name))) ;; prevent tp-search-map from replacing the text.
;; setq case: update all buffers that have the text property (tp-search-map
(dolist (buf (buffer-list)) (lambda (_text start end)
(when (buffer-live-p buf) (cl-loop for (key val) on props by #'cddr
(tp-with-current-buffer buf do (put-text-property start end key val))
(save-excursion nil)
(tp-search-map apply-props-fn 'tp-name layer-name)))))))))) '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) (defun tp--find-tp-text-reactive-var (layer-name)
"Find the reactive variable symbol used for tp-text in 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)))))))) (throw 'found var-sym))))))))
nil)) 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. "Update text regions that have tp-text property with LAYER-NAME applied.
This is called when a reactive variable bound to tp-text changes. 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 a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update all buffers that have the text property (setq case). - If WHERE is nil, update 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', If a transform function is registered for LAYER-NAME via `:transform',
it will be applied to the text before updating." it will be applied to the text before updating."
(let ((props (tp-layer-props layer-name t))) ; include tp-name for reactive tracking (let ((update-buffer
(when props (lambda ()
(let* ((raw-text (plist-get props 'tp-text)) (let ((props (tp--layer-render-props layer-name override-alist)))
;; Apply transformation if registered (when props
(transform-fn (cdr (assoc layer-name tp-layer-transforms))) (let* ((raw-text (plist-get props 'tp-text))
(new-text (if (and transform-fn raw-text (stringp raw-text)) ;; Apply transformation if registered
(condition-case err (new-text (if (stringp raw-text)
(let ((result (funcall transform-fn raw-text))) (tp--tp-text-transform layer-name raw-text)
(tp-debug-log " Transform %s: %S -> %S" raw-text)))
layer-name raw-text result) (when (and new-text (stringp new-text))
result) (save-excursion
(error (tp--replace-reactive-text-in-buffer
(message "tp: transform error for %s: %s" layer-name new-text props)))))))))
layer-name err) (if (and where (bufferp where) (buffer-live-p where))
raw-text)) ;; setq-local case: only update the specific buffer
raw-text))) (tp-with-current-buffer where
(when (and new-text (stringp new-text)) (funcall update-buffer))
(if (and where (bufferp where) (buffer-live-p where)) ;; setq case: update all buffers that have the text property
;; setq-local case: only update the specific buffer (dolist (buf (buffer-list))
(tp-with-current-buffer where (when (buffer-live-p buf)
(save-excursion (tp-with-current-buffer buf
(tp--replace-reactive-text-in-buffer layer-name new-text props))) (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
(save-excursion
(tp--replace-reactive-text-in-buffer layer-name new-text props)))))))))))
(defun tp--replace-reactive-text-in-buffer (layer-name new-text props) (defun tp--replace-reactive-text-in-buffer (layer-name new-text props)
"Replace text in current buffer for reactive text with LAYER-NAME. "Replace text in current buffer for reactive text with LAYER-NAME.
NEW-TEXT is the new text to replace with. NEW-TEXT is the new text to replace with.
PROPS are the properties to apply to the new text. PROPS are the properties to apply to the new text.
Text properties embedded in NEW-TEXT are merged with PROPS. Text properties embedded in NEW-TEXT are merged with PROPS per
The new properties completely reset/replace the old properties." 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)) (goto-char (point-min))
(let ((match (text-property-search-forward 'tp-name layer-name t)) (let ((match (text-property-search-forward 'tp-name layer-name t))
;; Merge embedded text properties from new-text into props (plain-text (substring-no-properties new-text)))
(merged-props (tp--merge-string-props-into-plist new-text props)))
(while match (while match
(let* ((m-start (prop-match-beginning match)) (let* ((m-start (prop-match-beginning match))
(m-end (prop-match-end match)) (m-end (prop-match-end match))
(old-text (buffer-substring-no-properties m-start m-end))) (old-text (buffer-substring-no-properties m-start m-end)))
(if (equal old-text (substring-no-properties new-text)) (unless (equal old-text plain-text)
;; Text content is the same, but properties may differ ;; Text content differs: replace it, carrying over the existing
;; Use set-text-properties to reset with new properties ;; properties whose keys this layer does not set.
(set-text-properties m-start m-end merged-props) (let ((existing-props (text-properties-at m-start)))
;; Text content is different - delete old text and insert new (delete-region m-start m-end)
(delete-region m-start m-end) (goto-char m-start)
(goto-char m-start) (insert plain-text)
(insert (substring-no-properties new-text)) (let ((new-end (+ m-start (length plain-text))))
;; Apply new properties (cl-loop for (key val) on existing-props by #'cddr
(let ((new-end (+ m-start (length new-text)))) do (unless (plist-member props key)
(set-text-properties m-start new-end merged-props)))) (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 ;; Search for next match
(setq match (text-property-search-forward 'tp-name layer-name t))))) (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) (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. "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. If tp-text is a string different from current text, replace the text.
When PRESERVE-PROPS is non-nil, existing text properties are preserved When PRESERVE-PROPS is non-nil, existing text properties are preserved
on the replaced text (used by tp-set and tp-add). 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. precedence over embedded props when there's a conflict.
Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props, 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-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)) (if (not (plist-member props 'tp-text))
;; tp-text not in props - return unchanged ;; tp-text not in props - return unchanged
(list props end object) (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 (cond
;; tp-text is nil - initialize it to the current text ;; tp-text is nil - initialize it to the current text
((null tp-text-val) ((null tp-text-val)
(let ((current-text (let ((current-text
(if (stringp object) (if (stringp object)
(substring object start end) (substring-no-properties object start end)
(if object (with-current-buffer (or object (current-buffer))
(with-current-buffer object
(buffer-substring-no-properties start end))
(buffer-substring-no-properties start end))))) (buffer-substring-no-properties start end)))))
;; If tp-text uses a reactive variable, update that variable to match ;; If tp-text uses a reactive variable, update that variable to match
;; This ensures the reactive variable and buffer text stay in sync ;; 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))) (when-let ((reactive-var (tp--find-tp-text-reactive-var layer-name)))
;; Update the reactive variable with the current text ;; Update the reactive variable with the current text
;; Note: Using global `set` here because the layer definition is global. ;; 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 (when layer-props
(tp--set-layer-props layer-name (tp--set-layer-props layer-name
(plist-put layer-props 'tp-text current-text)))))) (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 ;; tp-text has a string value - replace the text in the region
((stringp tp-text-val) ((stringp tp-text-val)
;; Apply transform if layer has one registered ;; Apply transform if layer has one registered
(let* ((layer-name (plist-get props 'tp-name)) (let* ((final-text (tp--tp-text-transform layer-name tp-text-val))
(transform-fn (when layer-name ;; Embedded text properties from tp-text are preserved in all
(cdr (assoc layer-name tp-layer-transforms)))) ;; cases. The props passed to this function take precedence
(final-text ;; over embedded props when there's a conflict (e.g. both have
(if transform-fn ;; a `face' property).
(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.
(result-props (result-props
(tp--merge-string-props-into-plist final-text props))) (tp--merge-string-props-into-plist final-text props)))
(if (stringp object) (tp--tp-text-replace start end final-text result-props
;; For strings: create a new string with tp-text content object preserve-props)))
;; 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))))))))
;; Other types - return unchanged ;; Other types - return unchanged
(t (list props end object)))))) (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 `setq-local' changes, nil for global ones. OVERRIDE-ALIST maps SYMBOL
to NEWVAL (the watcher runs before the variable is actually set). 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 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 This is the engine behind `tp--reactive-variable-watcher'; it is
installed as `tp--reactive-update-function'." installed as `tp--reactive-update-function'."
(let ((tp-text-affected (plist-member reactive-props 'tp-text))) (ignore newval)
;; Update computed properties for this layer (let ((tp-text-affected (and (plist-member reactive-props 'tp-text) t)))
(let ((updated-override (if tp--reactive-updating
(tp--update-layer-computed layer-name override-alist))) ;; Nested change fired from within an update: queue, don't recurse.
(when reactive-props (tp--queue-batch-update layer-name symbol where tp-text-affected)
;; Resolve the reactive props with the new value override (let ((tp--reactive-updating t))
(let ((resolved-props (tp--resolve-reactive-symbols ;; Update computed properties for this layer
reactive-props updated-override))) (let ((updated-override
;; Update only the reactive properties in the layer definition (tp--update-layer-computed layer-name override-alist)))
(let ((current-props (cdr (assoc layer-name tp-layer-alist)))) ;; Update only the reactive properties in the layer definition.
(when current-props ;; Buffer-local changes must not leak into the global definition;
;; Deep merge the resolved reactive props into the current ;; the buffer re-render below resolves against the buffer-local
;; layer props to preserve nested plist values (like face) ;; values instead.
(setq current-props (tp--deep-merge-plist current-props (when (and reactive-props (not (bufferp where)))
resolved-props)) (let ((resolved-props (tp--resolve-reactive-symbols
(tp--set-layer-props layer-name current-props)))))) reactive-props updated-override))
;; Update text regions with this layer (or defer if batching) (current-props (cdr (assoc layer-name tp-layer-alist))))
(if tp--batch-update-active (when current-props
;; Batching: defer the buffer update ;; Deep merge the resolved reactive props into the current
;; Pending format: (layer-name symbols-list where tp-text-affected) ;; layer props to preserve nested plist values (like face)
(let ((existing (assoc layer-name tp--batch-update-pending))) (tp--set-layer-props
(tp-debug-log " Deferring buffer update for %s (batch mode)" layer-name
layer-name) (tp--deep-merge-plist current-props resolved-props)))))
(if existing ;; Update text regions with this layer (or defer if batching)
;; Update existing entry: add symbol if not present (if tp--batch-update-active
(let ((symbols (nth 1 existing))) ;; Batching: defer the buffer update
(unless (memq symbol symbols) (progn
(setf (nth 1 existing) (cons symbol symbols)))) (tp-debug-log " Deferring buffer update for %s (batch mode)"
;; Create new entry layer-name)
(push (list layer-name (list symbol) where tp-text-affected) (tp--queue-batch-update layer-name symbol where
tp--batch-update-pending))) tp-text-affected))
;; Normal: update immediately ;; Normal: update immediately
(tp-debug-log " Updating layer %s (tp-text affected: %s)" (tp-debug-log " Updating layer %s (tp-text affected: %s)"
layer-name (if tp-text-affected "yes" "no")) layer-name (if tp-text-affected "yes" "no"))
(tp--reactive-flush-entry layer-name where tp-text-affected)))) (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) (defun tp--reactive-flush-entry (layer-name where tp-text-affected)
"Re-render LAYER-NAME's regions in WHERE (or all buffers when nil). "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 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'." `tp--reactive-flush-function'."
(if tp-text-affected (if tp-text-affected
(tp--update-reactive-text layer-name where) (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-layer)
(require 'tp-ops) (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. "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 strings, returns a new string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions." For buffers, modifies in-place and returns list of regions."
(cond (tp--pattern-apply-single pattern properties apply-fn object t))
;; 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))))))))
(defun tp--match-apply (pattern properties apply-fn &optional object) (defun tp--match-apply (pattern properties apply-fn &optional object)
"Internal function to apply APPLY-FN to matches of PATTERN. "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. APPLY-FN is called with (START END PROPS OBJECT) for each match.
For strings, returns a NEW string with properties applied (non-destructive). For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions." For buffers, returns list of regions."
(let ((patterns (if (listp pattern) pattern (list pattern)))) (tp--pattern-apply pattern properties apply-fn object t))
(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)))))
(defun tp--regexp-apply-single (pattern properties apply-fn object) (defun tp--regexp-apply-single (pattern properties apply-fn object)
"Apply APPLY-FN to regexp matches of single PATTERN in OBJECT. "Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
APPLY-FN is called with (START END PROPS OBJECT) for each 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 strings, returns a NEW string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions." For buffers, modifies in-place and returns list of regions."
(cond (tp--pattern-apply-single pattern properties apply-fn object nil))
;; 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))))))))
(defun tp--regexp-apply (pattern properties apply-fn &optional object) (defun tp--regexp-apply (pattern properties apply-fn &optional object)
"Internal function to apply APPLY-FN to regexp matches of PATTERN. "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. APPLY-FN is called with (START END PROPS OBJECT) for each match.
For strings, returns a NEW string with properties applied (non-destructive). For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions." For buffers, returns list of regions."
(let ((patterns (if (listp pattern) pattern (list pattern)))) (tp--pattern-apply pattern properties apply-fn object nil))
(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)))))
(defun tp--deep-merge-apply (start end props obj) (defun tp--deep-merge-apply (start end props obj)
"Apply PROPS to OBJ from START to END with deep merge. "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)) do (let* ((current-val (plist-get current-props key))
(new-val (new-val
(cond (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)) ((and (listp val) (keywordp (car-safe val))
(listp current-val) (listp current-val)
(keywordp (car-safe current-val))) (keywordp (car-safe current-val)))
@ -291,6 +284,40 @@ Wraps `text-property-search-forward'."
Wraps `text-property-search-backward'." Wraps `text-property-search-backward'."
(text-property-search-backward property value predicate not-current)) (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) (defun tp-forward (property &optional value object n)
"Search forward N times for text with PROPERTY. "Search forward N times for text with PROPERTY.
Returns prop-match for buffers or list of (START END VALUE) for strings." 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)))) (buf (or object (current-buffer))))
(tp-with-current-buffer buf (tp-with-current-buffer buf
(dotimes (_ count) (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))))) result)))))
(defun tp--forward-do (function property &optional value object times start end) (defun tp--forward-do (function property &optional value object times start end)
"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) FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT. and OBJECT.
@ -379,6 +410,74 @@ Returns the number of successful matches."
(cl-incf matches))))))) (cl-incf matches)))))))
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) (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. "Search forward for text with PROPERTY and apply FUNCTION to the last match.
@ -418,47 +517,11 @@ Example:
(let ((arity (func-arity function))) (let ((arity (func-arity function)))
(tp--forward-do (tp--forward-do
(lambda (match obj) (lambda (match obj)
(let* ((m-start (if (listp match) (car match) (prop-match-beginning match))) (tp--replace-match-text function arity match obj))
(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)))))))
property value object times start end))) property value object times start end)))
(defun tp--backward-do (function property &optional 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) FUNCTION receives two arguments: the prop-match object (or list for strings)
and OBJECT. and OBJECT.
@ -494,7 +557,8 @@ Returns the number of successful matches."
(save-excursion (save-excursion
(goto-char search-end) (goto-char search-end)
(dotimes (i count) (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 (>= (prop-match-beginning match) search-start)
(when (= i (1- count)) (when (= i (1- count))
(funcall function match buf)) (funcall function match buf))
@ -540,43 +604,7 @@ Example:
(let ((arity (func-arity function))) (let ((arity (func-arity function)))
(tp--backward-do (tp--backward-do
(lambda (match obj) (lambda (match obj)
(let* ((m-start (if (listp match) (car match) (prop-match-beginning match))) (tp--replace-match-text function arity match obj))
(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)))))))
property value object times start end))) property value object times start end)))
(defun tp-search (start-or-string (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) 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. 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. 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. START and END define the search range; defaults are object start and end.
Returns the number of matches processed." Returns the number of matches processed.
(let* ((obj (or object (current-buffer)))
(all-matches (if (stringp obj) For buffers, FUNCTION is called with OBJECT as the current buffer, and
(tp-search obj property value) the match positions handed to FUNCTION are tracked with markers, so
(let ((s (or start (point-min))) FUNCTION may safely change the length of earlier matches (e.g. replace
(e (or end (point-max)))) their text): later matches still receive their up-to-date positions."
(tp-search s e property value obj)))) (let ((obj (or object (current-buffer))))
(filtered-matches (if (stringp obj)
(if (and (not (stringp obj)) start end) (let* ((all-matches (tp-search obj property value))
(seq-filter (lambda (m) (s (or start 0))
(and (>= (car m) start) (e (or end (length obj)))
(<= (cadr m) end))) (filtered-matches
all-matches) (seq-filter (lambda (m)
(if (stringp obj) (and (>= (car m) s)
(let ((s (or start 0)) (<= (cadr m) e)))
(e (or end (length obj)))) all-matches)))
(seq-filter (lambda (m) (dolist (match filtered-matches)
(and (>= (car m) s) (funcall function match obj))
(<= (cadr m) e))) (length filtered-matches))
all-matches)) ;; Buffer: do all the work with OBJ current, and track match
all-matches)))) ;; positions with markers so length-changing edits made by
(dolist (match filtered-matches) ;; FUNCTION on earlier matches don't invalidate later positions.
(funcall function match obj)) (tp-with-current-buffer obj
(length filtered-matches))) (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) (defun tp-search-map (function property &optional value object start end)
"Apply FUNCTION to all matches of PROPERTY in OBJECT. "Apply FUNCTION to all matches of PROPERTY in OBJECT.
@ -747,52 +798,12 @@ Example:
;; Search within a range ;; Search within a range
(tp-search-map #\\='upcase \\='marker nil my-string 0 10)" (tp-search-map #\\='upcase \\='marker nil my-string 0 10)"
(let* ((obj (or object (current-buffer))) (let ((idx 0)
(idx 0) (arity (func-arity function)))
(arity (func-arity function)))
(tp--search-do (tp--search-do
(lambda (match obj) (lambda (match obj)
(let* ((m-start (car match)) (tp--replace-match-text function arity match obj idx)
(m-end (cadr match)) (setq idx (1+ idx)))
(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)))))))
property value object start end))) property value object start end)))
(provide 'tp-search) (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-layer)
(require 'tp-ops) (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) (defun tp-region-layer-props (start end layer-name &optional object)
"Return layer properties for LAYER-NAME in region from START to END. "Return layer properties for LAYER-NAME in region from START to END.
OBJECT defaults to current buffer. OBJECT defaults to current buffer.
Returns a list of (START END PROPERTIES) for matching intervals." Returns a list of (START END PROPERTIES) for matching intervals, with
(tp-intervals-map positions in OBJECT's native coordinates (0-based for strings, 1-based
(lambda (i-start i-end top belows) 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 (when-let ((props (seq-find
(lambda (props) (lambda (props)
(equal layer-name (equal layer-name
(plist-get props 'tp-name))) (plist-get props 'tp-name)))
(append (list top) belows)))) stack)))
(list (+ start i-start) (+ start i-end) props))) (list abs-start abs-end props)))))
start end object))
(defun tp--parse-layer-args (args) (defun tp-layer-list (start end &optional object)
"Parse flexible layer function arguments. "Return list of all layer names in region from START to END."
Returns (START END LAYER-SPEC IDX OBJECT) for buffer/string range, (let ((layers nil))
or (STRING LAYER-SPEC IDX nil nil) for entire string." (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 (cond
;; First arg is a string - apply to entire string ;; Group name symbol.
;; (tp-put-layer string layer idx) ((and (symbolp layer-spec)
((stringp (car args)) (assoc layer-spec tp-layer-groups))
(list (car args) (cadr args) (caddr args) nil nil)) (if (tp-group-parameterized-p layer-spec)
;; First arg is a number - buffer/string region (error "Parameterized group %S requires an argument, use '(%S ARG)"
;; (tp-put-layer start end layer idx object) layer-spec layer-spec)
((numberp (car args)) (tp-group-props layer-spec t))) ; include tp-name for layer stack
(list (car args) (cadr args) (caddr args) (cadddr args) (nth 4 args))) ;; Any other symbol: a single layer name.
(t (error "Invalid arguments: %S" args)))) ((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) (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. "Set layer(s) at a specific index position.
@ -58,13 +218,15 @@ or (STRING LAYER-SPEC IDX nil nil) for entire string."
Calling conventions: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-put-layer START END LAYER IDX OBJECT) (tp-put-layer START END LAYER IDX OBJECT)
2. Entire string: 2. Entire string:
(tp-put-layer STRING LAYER IDX) (tp-put-layer STRING LAYER IDX)
LAYER can be: LAYER can be:
- A symbol (layer name from tp-layer-alist or tp-layer-groups) - A symbol (layer name from `tp-layer-alist' or `tp-layer-groups')
- A plist (inline layer definition) - 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 (NAME &rest PLIST) for named inline layer
- A list of the above for multiple layers - A list of the above for multiple layers
@ -73,68 +235,26 @@ IDX specifies where to insert:
- -1 means bottom - -1 means bottom
- Other values insert at that position - Other values insert at that position
OBJECT defaults to current buffer for region form." OBJECT defaults to current buffer for region form. Only text inside
(let (start end layer-spec idx obj) \[START, END) is modified."
(cond (pcase-let ((`(,start ,end ,obj ,layer-spec ,idx)
;; Entire string form: (tp-put-layer string layer idx) (tp--parse-layer-args
((stringp start-or-string) start-or-string
(setq obj start-or-string (list end-or-layer layer-or-idx idx-or-object object) 2)))
start 0 (setq idx (or idx 0))
end (length start-or-string) (let ((layers-to-add (tp--put-layer-specs layer-spec)))
layer-spec end-or-layer (tp--stack-map-region
idx (or layer-or-idx 0))) start end obj
;; Region form: (tp-put-layer start end layer idx object) (lambda (abs-start abs-end stack)
((numberp start-or-string) (let* ((actual-idx (if (< idx 0)
(setq start start-or-string (max 0 (+ (length stack) 1 idx))
end end-or-layer (min idx (length stack))))
layer-spec layer-or-idx (new-stack (append (seq-take stack actual-idx)
idx (or idx-or-object 0) layers-to-add
obj object))) (seq-drop stack actual-idx))))
(set-text-properties abs-start abs-end
;; Normalize layer-spec to a list of layer property lists (tp--stack-build-props new-stack)
(let ((layers-to-add obj)))))
(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)))
(or obj (cons start end)))) (or obj (cons start end))))
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object) (defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object)
@ -145,14 +265,14 @@ This is equivalent to (tp-put-layer ... LAYER 0 ...).
Calling conventions: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-push-layer START END LAYER OBJECT) (tp-push-layer START END LAYER OBJECT)
2. Entire string: 2. Entire string:
(tp-push-layer STRING LAYER)" (tp-push-layer STRING LAYER)"
(cond (pcase-let ((`(,start ,end ,obj ,layer)
((stringp start-or-string) (tp--parse-layer-args
(tp-put-layer start-or-string end-or-layer 0)) start-or-string
((numberp start-or-string) (list end-or-layer layer-or-object object) 1)))
(tp-put-layer start-or-string end-or-layer layer-or-object 0 object)))) (tp-put-layer start end layer 0 obj)))
(defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object) (defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object)
"Delete layer by name or index. "Delete layer by name or index.
@ -160,37 +280,27 @@ Calling conventions:
Calling conventions: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-delete-layer START END LAYER-NAME/IDX OBJECT) (tp-delete-layer START END LAYER-NAME/IDX OBJECT)
2. Entire string: 2. Entire string:
(tp-delete-layer STRING LAYER-NAME/IDX) (tp-delete-layer STRING LAYER-NAME/IDX)
LAYER-NAME/IDX can be: LAYER-NAME/IDX can be:
- A symbol (layer name) - A symbol (layer name)
- An integer (layer index, 0=top, -1=bottom)" - An integer (layer index, 0=top, -1=bottom)
(let (start end layer-id obj)
(cond Only text inside [START, END) is modified."
((stringp start-or-string) (pcase-let ((`(,start ,end ,obj ,layer-id)
(setq obj start-or-string (tp--parse-layer-args
start 0 start-or-string
end (length start-or-string) (list end-or-idx idx-or-object object) 1)))
layer-id end-or-idx)) (tp--stack-map-region
((numberp start-or-string) start end obj
(setq start start-or-string (lambda (abs-start abs-end stack)
end end-or-idx (when-let ((found (tp--get-layer-by-idx-or-name stack layer-id)))
layer-id idx-or-object (set-text-properties
obj object))) abs-start abs-end
(tp--stack-build-props (-remove-at (car found) stack))
(tp-intervals-map obj))))
(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)
nil)) nil))
(defun tp-pop-layer (start-or-string &optional end-or-object object) (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: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-pop-layer START END OBJECT) (tp-pop-layer START END OBJECT)
2. Entire string: 2. Entire string:
(tp-pop-layer STRING)" (tp-pop-layer STRING)"
(cond (pcase-let ((`(,start ,end ,obj)
((stringp start-or-string) (tp--parse-layer-args
(tp-delete-layer start-or-string 0)) start-or-string (list end-or-object object) 0)))
((numberp start-or-string) (tp-delete-layer start end 0 obj)))
(tp-delete-layer start-or-string end-or-object 0 object))))
(defun tp--move-layer-in-stack (stack from-id to-idx) (defun tp--move-layer-in-stack (stack from-id to-idx)
"Move layer at FROM-ID to TO-IDX position in STACK. "Move layer at FROM-ID to TO-IDX position in STACK.
FROM-ID can be an integer index or a layer name symbol. FROM-ID can be an integer index or a layer name symbol.
TO-IDX must be an integer index. 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. 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." Returns the new stack, or nil if FROM-ID is invalid."
(let* ((len (length stack)) (let* ((len (length stack))
@ -289,33 +399,17 @@ TO-IDX is the target position (integer index):
Both indices refer to positions before the move. Both indices refer to positions before the move.
The layer at FROM-ID is removed and inserted at TO-IDX position. The layer at FROM-ID is removed and inserted at TO-IDX position.
OBJECT defaults to current buffer for region form." OBJECT defaults to current buffer for region form."
(let (start end from-id to-idx obj) (pcase-let ((`(,start ,end ,obj ,from-id ,to-idx)
(cond (tp--parse-layer-args
;; Entire string form: (tp-move-layer string from-id to-idx) start-or-string
((stringp start-or-string) (list end-or-from from-or-to to-or-object object) 2)))
(setq obj start-or-string (tp--stack-map-region
start 0 start end obj
end (length start-or-string) (lambda (abs-start abs-end stack)
from-id end-or-from (when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx)))
to-idx from-or-to)) (set-text-properties abs-start abs-end
;; Region form: (tp-move-layer start end from-id to-idx object) (tp--stack-build-props new-stack)
((numberp start-or-string) obj))))
(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)
nil)) nil))
(defun tp-raise-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object) (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: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-raise-layer START END IDX/LAYER-NAME N OBJECT) (tp-raise-layer START END IDX/LAYER-NAME N OBJECT)
2. Entire string: 2. Entire string:
(tp-raise-layer STRING IDX/LAYER-NAME N) (tp-raise-layer STRING IDX/LAYER-NAME N)
Positive N moves the layer up (toward top/visible). Positive N moves the layer up (toward top/visible).
Negative N moves the layer down (toward bottom). Negative N moves the layer down (toward bottom).
Uses `tp--raise-layer-in-stack' internally, which is built on `tp--move-layer-in-stack'." Uses `tp--raise-layer-in-stack' internally, which is built on
(let (start end layer-id n obj) `tp--move-layer-in-stack'."
(cond (pcase-let ((`(,start ,end ,obj ,layer-id ,n)
((stringp start-or-string) (tp--parse-layer-args
(setq obj start-or-string start-or-string
start 0 (list end-or-idx idx-or-n n-or-object object) 2)))
end (length start-or-string) (setq n (or n 1))
layer-id end-or-idx (tp--stack-map-region
n (or idx-or-n 1))) start end obj
((numberp start-or-string) (lambda (abs-start abs-end stack)
(setq start start-or-string (when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n)))
end end-or-idx (set-text-properties abs-start abs-end
layer-id idx-or-n (tp--stack-build-props new-stack)
n (or n-or-object 1) obj))))
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)
nil)) nil))
(defun tp-rotate-layer (start-or-string &optional end-or-object object) (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: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-rotate-layer START END OBJECT) (tp-rotate-layer START END OBJECT)
2. Entire string: 2. Entire string:
(tp-rotate-layer STRING) (tp-rotate-layer STRING)
Uses `tp-move-layer' internally to move layer at index 0 to index -1." Uses `tp-move-layer' internally to move layer at index 0 to index -1."
(cond (pcase-let ((`(,start ,end ,obj)
((stringp start-or-string) (tp--parse-layer-args
(tp-move-layer start-or-string 0 -1)) start-or-string (list end-or-object object) 0)))
((numberp start-or-string) (tp-move-layer start end 0 -1 obj)))
(tp-move-layer start-or-string end-or-object 0 -1 object))))
(defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object) (defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object)
"Pin a layer to the top (make it visible). "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: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-pin-layer START END IDX/LAYER-NAME OBJECT) (tp-pin-layer START END IDX/LAYER-NAME OBJECT)
2. Entire string: 2. Entire string:
(tp-pin-layer STRING IDX/LAYER-NAME) (tp-pin-layer STRING IDX/LAYER-NAME)
Uses `tp-move-layer' internally to move the specified layer to index 0 (top)." Uses `tp-move-layer' internally to move the specified layer to index 0 (top)."
(cond (pcase-let ((`(,start ,end ,obj ,layer-id)
((stringp start-or-string) (tp--parse-layer-args
(tp-move-layer start-or-string end-or-idx 0)) start-or-string
((numberp start-or-string) (list end-or-idx idx-or-object object) 1)))
(tp-move-layer start-or-string end-or-idx idx-or-object 0 object)))) (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) (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. "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: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT) (tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT)
2. Entire string: 2. Entire string:
(tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2) (tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)
Uses `tp--switch-layers-in-stack' internally." Uses `tp--switch-layers-in-stack' internally."
(let (start end id1 id2 obj) (pcase-let ((`(,start ,end ,obj ,id1 ,id2)
(cond (tp--parse-layer-args
((stringp start-or-string) start-or-string
(setq obj start-or-string (list end-or-id1 id1-or-id2 id2-or-object object) 2)))
start 0 (tp--stack-map-region
end (length start-or-string) start end obj
id1 end-or-id1 (lambda (abs-start abs-end stack)
id2 id1-or-id2)) (when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2)))
((numberp start-or-string) (set-text-properties abs-start abs-end
(setq start start-or-string (tp--stack-build-props new-stack)
end end-or-id1 obj))))
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)
nil)) 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) (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. "Merge specified layers into a new layer.
Calling conventions: Calling conventions:
1. Buffer/string region: 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: 2. Entire string:
(tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...))" (tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...))
(let (start end new-name layer-ids obj)
(cond Earlier layers in the list take precedence; a property explicitly set
((stringp start-or-string) to nil in a higher-precedence layer stays nil in the merged layer."
(setq obj start-or-string (pcase-let ((`(,start ,end ,obj ,new-name ,layer-ids)
start 0 (tp--parse-layer-args
end (length start-or-string) start-or-string
new-name end-or-name (list end-or-name name-or-ids ids-or-object object) 2)))
layer-ids name-or-ids)) (tp--stack-map-region
((numberp start-or-string) start end obj
(setq start start-or-string (lambda (abs-start abs-end stack)
end end-or-name (let* ((layers-to-merge
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
(cl-loop for id in layer-ids (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)) when found collect found))
;; Sort by index (descending) to remove from end first ;; Sort by index (descending) to remove from end first
(sorted-layers (sort (copy-sequence layers-to-merge) (sorted-layers (sort (copy-sequence layers-to-merge)
(lambda (a b) (> (car a) (car b)))))) (lambda (a b) (> (car a) (car b))))))
(when layers-to-merge (when layers-to-merge
;; Merge properties (earlier in list takes precedence) ;; Merge properties (earlier in list takes precedence)
(let* ((merged-props (let ((merged-props (tp--merge-layer-props
(cl-reduce (lambda (acc layer) layers-to-merge (list 'tp-name new-name)))
(let ((props (cdr layer))) (new-stack stack))
(cl-loop for (key val) on props by #'cddr ;; Remove old layers from stack
do (unless (plist-get acc key) (dolist (idx (mapcar #'car sorted-layers))
(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)
(setq new-stack (-remove-at idx new-stack))) (setq new-stack (-remove-at idx new-stack)))
;; Add merged layer at top ;; Add merged layer at top
(setq new-stack (cons merged-props new-stack)) (setq new-stack (cons merged-props new-stack))
(set-text-properties (set-text-properties abs-start abs-end
(+ start i-start) (+ start i-end) (tp--stack-build-props new-stack)
(tp--build-layer-props new-stack) obj))))))
obj)))))
start end obj)
nil)) nil))
(defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object) (defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object)
@ -497,90 +563,29 @@ Calling conventions:
Calling conventions: Calling conventions:
1. Buffer/string region: 1. Buffer/string region:
(tp-flatten-layers START END NAME OBJECT) (tp-flatten-layers START END NAME OBJECT)
2. Entire string: 2. Entire string:
(tp-flatten-layers STRING NAME) (tp-flatten-layers STRING NAME)
NAME can be nil for an unnamed layer." NAME can be nil for an unnamed layer. Higher layers take precedence;
(let (start end name obj) a property explicitly set to nil in a higher layer stays nil in the
(cond flattened result."
((stringp start-or-string) (pcase-let ((`(,start ,end ,obj ,name)
(setq obj start-or-string (tp--parse-layer-args
start 0 start-or-string
end (length start-or-string) (list end-or-name name-or-object object) 1)))
name end-or-name)) (tp--stack-map-region
((numberp start-or-string) start end obj
(setq start start-or-string (lambda (abs-start abs-end stack)
end end-or-name (when stack
name name-or-object (let ((merged-props (tp--merge-layer-props
obj object))) (cl-loop for layer in stack
for i from 0
(tp-intervals-map collect (cons i layer))
(lambda (i-start i-end top belows) (when name (list 'tp-name name)))))
(let* ((current-stack (tp--layer-stack-to-list top belows)) (set-text-properties abs-start abs-end merged-props obj)))))
(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)
nil)) 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) (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. "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 (setq start start-or-string
end end-or-plist end end-or-plist
plist plist-or-object 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) ;; Handle plist wrapped in a list (from region form)
(when (and (listp plist) (when (and (listp plist)
@ -621,28 +628,27 @@ Returns the modified object (string) or nil for buffer operations."
(setq plist (car plist))) (setq plist (car plist)))
;; Process each interval ;; Process each interval
(tp-intervals-map (tp--stack-map-region
(lambda (i-start i-end top belows) start end obj
(let* ((current-stack (tp--layer-stack-to-list top belows)) (lambda (abs-start abs-end stack)
(modified-stack (let ((modified-stack
(cl-loop for layer in current-stack (cl-loop for layer in stack
for i from 0 for i from 0
collect collect
(if (cl-some (if (cl-some
(lambda (id) (lambda (id)
(let ((found (tp--get-layer-by-idx-or-name (let ((found (tp--get-layer-by-idx-or-name
current-stack id))) stack id)))
(and found (= (car found) i)))) (and found (= (car found) i))))
layer-ids) layer-ids)
;; Merge plist into this layer ;; Merge plist into this layer
(tp--deep-merge-plist layer plist) (tp--deep-merge-plist layer plist)
;; Keep layer unchanged ;; Keep layer unchanged
layer)))) layer))))
(set-text-properties (when stack
(+ start i-start) (+ start i-end) (set-text-properties abs-start abs-end
(tp--build-layer-props modified-stack) (tp--stack-build-props modified-stack)
obj))) obj)))))
start end obj)
(if (stringp obj) obj nil))) (if (stringp obj) obj nil)))
(defun tp-add-to-all-layers (start-or-string &optional end-or-plist plist-or-object &rest rest) (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 (setq start start-or-string
end end-or-plist end end-or-plist
plist plist-or-object 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) ;; Handle plist wrapped in a list (from region form)
(when (and (listp plist) (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") (insert "Hello World")
(tp-set 1 6 '(face bold)) (tp-set 1 6 '(face bold))
(goto-char 12) (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))) (let ((match (tp-backward 'face)))
(should match) (should match)
(should (= (prop-match-beginning match) 1))))) (should (= (prop-match-beginning match) 6)))))
(ert-deftest tp-test-backward-on-string () (ert-deftest tp-test-backward-on-string ()
"Test tp-backward works on string objects." "Test tp-backward works on string objects."