From ceb0dfb0bc547bdf7b8757762eab7e7d7f52f8fe Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Sun, 26 Jul 2026 20:01:20 +0800 Subject: [PATCH] Fix confirmed bugs in layer, stack, search, and reactive-render modules 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 --- CHANGELOG.md | 199 +++++++++++++ tp-layer-tests.el | 342 +++++++++++++++++++++ tp-layer.el | 324 +++++++++++++++----- tp-reactive.el | 49 ++- tp-render-tests.el | 364 +++++++++++++++++++++++ tp-render.el | 514 ++++++++++++++++++++------------ tp-search-tests.el | 332 +++++++++++++++++++++ tp-search.el | 501 ++++++++++++++++--------------- tp-stack-tests.el | 383 ++++++++++++++++++++++++ tp-stack.el | 728 +++++++++++++++++++++++---------------------- tp-tests.el | 9 +- 11 files changed, 2867 insertions(+), 878 deletions(-) create mode 100644 CHANGELOG.md create mode 100644 tp-layer-tests.el create mode 100644 tp-render-tests.el create mode 100644 tp-search-tests.el create mode 100644 tp-stack-tests.el diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..e8fbfa7 --- /dev/null +++ b/CHANGELOG.md @@ -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). diff --git a/tp-layer-tests.el b/tp-layer-tests.el new file mode 100644 index 0000000..56b2278 --- /dev/null +++ b/tp-layer-tests.el @@ -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 diff --git a/tp-layer.el b/tp-layer.el index 004d981..07f7d70 100644 --- a/tp-layer.el +++ b/tp-layer.el @@ -44,6 +44,45 @@ definition. When nil, redefinition only updates the registry.") TRANSFORM-FN receives the value and returns the transformed value. Used for tp-text transformations like formatting numbers or dates.") +(defvar tp--group-generated-layers nil + "Alist tracking layers generated by each group: (GROUP-NAME . LAYER-NAMES). +Only layers created by the group definition itself (anonymous and +named elements) are recorded here; layers merely referenced by name +are not. Used to clean up orphaned layers when a group is redefined +or undefined.") + +(defvar tp--anonymous-layer-registry nil + "Alist interning anonymous reactive layers: (PROPS-SPEC . LAYER-NAME). +PROPS-SPEC is the original (unresolved) props spec passed to +`tp--resolve-props'; LAYER-NAME is the anonymous layer registered for +it. Lookup is `equal'-based, so resolving an identical spec reuses +the existing anonymous layer instead of minting a new registry entry +on every call.") + +(defun tp--anonymous-layer-name-for (props) + "Return the interned anonymous layer name for reactive spec PROPS. +If an `equal' spec was registered before, reuse its layer name; +otherwise generate a fresh name via `tp--generate-anonymous-layer-name' +and record it in `tp--anonymous-layer-registry'." + (or (cdr (assoc props tp--anonymous-layer-registry)) + (let ((name (tp--generate-anonymous-layer-name))) + (push (cons (copy-tree props) name) tp--anonymous-layer-registry) + name))) + +(defvar tp--layer-expansion-stack nil + "Layer names currently being expanded, innermost first. +Dynamically bound during `tp-layer-props' / `tp-layer-props-with-arg' +to detect cyclic layer references.") + +(defun tp--check-layer-cycle (layer-name) + "Signal a clear error if LAYER-NAME is already being expanded. +The error message names the full cycle, e.g. \"a -> b -> a\"." + (when (memq layer-name tp--layer-expansion-stack) + (error "tp: cyclic layer reference: %s" + (mapconcat #'symbol-name + (reverse (cons layer-name tp--layer-expansion-stack)) + " -> ")))) + (defun tp--expand-layer-to-props-list (layer-name str start) "Expand LAYER-NAME to a list of property keys it contributes. If LAYER-NAME is a layer defined in `tp-layer-alist', returns a list @@ -302,6 +341,16 @@ BODY is either: - Keyword arguments starting with :props, :data, :compute, :watch, or :transform (reactive format - only for non-parameterized layers with $-prefixed variables) +In simple format, exactly one body form is accepted; supplying more +than one signals an error at macro-expansion time instead of silently +discarding the extra forms. + +$-prefixed reactive symbols appearing in a PARAMETERIZED body do not +create reactive dependencies (parameterized layers cannot be +reactive); they are resolved to the current value of the corresponding +variable each time the layer is evaluated via +`tp-layer-props-with-arg'. + Note: NAME cannot be a built-in Emacs text property name like `face', `display', `invisible', etc. See `tp--builtin-text-properties' for the complete list of reserved names." @@ -321,17 +370,21 @@ complete list of reserved names." ;; Non-parameterized reactive: use tp--define-layer-internal directly `(tp--define-layer-internal ',name ,@body)) ;; Simple format (original behavior) - (let ((simple-body (car body))) - (cond - ;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM) - ((null arglist) - `(tp--define-layer-unified ',name nil ,simple-body)) - ;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM) - ((and (= (length arglist) 1) - (symbolp (car arglist))) - `(tp--define-layer-unified ',name ',arglist ',simple-body)) - (t - (error "define-tp ARGLIST must be empty or contain exactly one symbol"))))))) + (progn + (when (cdr body) + (error "define-tp %s: simple format takes exactly one body form, got %d (use the :props keyword format to combine multiple components)" + name (length body))) + (let ((simple-body (car body))) + (cond + ;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM) + ((null arglist) + `(tp--define-layer-unified ',name nil ,simple-body)) + ;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM) + ((and (= (length arglist) 1) + (symbolp (car arglist))) + `(tp--define-layer-unified ',name ',arglist ',simple-body)) + (t + (error "define-tp ARGLIST must be empty or contain exactly one symbol")))))))) (defun tp--define-layer-unified (name arglist body) "Define a layer NAME with ARGLIST and BODY using unified structure. @@ -406,19 +459,22 @@ IDX is the index for anonymous elements. Returns a cons cell (LAYER-NAME . PROPERTIES) or a symbol if ELEMENT references an already-defined layer. -For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA :watch WATCH :compute COMPUTE)." +For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA +:watch WATCH :compute COMPUTE :transform TRANSFORM). +Unknown keywords in format-4 elements signal an error." (let ((format (tp--layer-group-element-format element))) (pcase format ('symbol element) ('format-4 - ;; Parse named layer with :props and optional :data/:watch/:compute + ;; Parse named layer with :props and optional :data/:watch/:compute/:transform (let* ((layer-suffix (car element)) (layer-name (intern (format "%s-%s" group-name layer-suffix))) (rest (cdr element)) (props nil) (data nil) (watch nil) - (compute nil)) + (compute nil) + (transform nil)) ;; Parse keyword arguments (while rest (pcase (car rest) @@ -426,8 +482,12 @@ For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA :watch WATCH (:data (setq data (cadr rest) rest (cddr rest))) (:watch (setq watch (cadr rest) rest (cddr rest))) (:compute (setq compute (cadr rest) rest (cddr rest))) - (_ (setq rest (cdr rest))))) - (list layer-name :props props :data data :watch watch :compute compute))) + (:transform (setq transform (cadr rest) rest (cddr rest))) + (unknown + (error "Unknown keyword %S in layer group element: %S" + unknown element)))) + (list layer-name :props props :data data :watch watch + :compute compute :transform transform))) ('format-3 (let* ((layer-suffix (car element)) (layer-name (intern (format "%s-%s" group-name layer-suffix))) @@ -443,13 +503,22 @@ For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA :watch WATCH (cons layer-name element))) (_ (error "Invalid layer group element: %S" element))))) -(defun tp--define-layer-from-parsed (layer-name props data watch compute) +(defun tp--define-layer-from-parsed (layer-name props data watch compute &optional transform) "Internal helper to define a layer from parsed components. LAYER-NAME is the symbol name for the layer. PROPS is the property list. DATA is the list of data variables. WATCH is the list of watcher definitions. -COMPUTE is the list of computed variable definitions." +COMPUTE is the list of computed variable definitions. +TRANSFORM, if non-nil, is registered in `tp-layer-transforms'; +when nil, any previously registered transform for LAYER-NAME is +removed (mirroring `tp--define-layer-internal')." + ;; Register or unregister transform function + (if transform + (if (assoc layer-name tp-layer-transforms) + (setcdr (assoc layer-name tp-layer-transforms) transform) + (push (cons layer-name transform) tp-layer-transforms)) + (setq tp-layer-transforms (assq-delete-all layer-name tp-layer-transforms))) (let* ((reactive-syms (tp--collect-reactive-symbols props)) (computed-vars (when compute (mapcar #'car compute))) (all-reactive-syms (delete-dups reactive-syms)) @@ -508,6 +577,7 @@ Individual layers created by the group are stored in `tp-layer-alist', and the group itself is stored in `tp-layer-groups'." (declare (indent defun)) (let ((layer-names nil) + (generated nil) (idx 0)) (dolist (element elements) (let ((parsed (tp--parse-layer-group-element name element idx))) @@ -515,25 +585,35 @@ and the group itself is stored in `tp-layer-groups'." ;; Reference to existing layer (symbol) ((symbolp parsed) (push parsed layer-names)) - ;; Extended format with :data/:watch/:compute (format-4) + ;; Extended format with :data/:watch/:compute/:transform (format-4) ((and (listp parsed) (plist-get (cdr parsed) :props)) (let* ((layer-name (car parsed)) (props (plist-get (cdr parsed) :props)) (data (plist-get (cdr parsed) :data)) (watch (plist-get (cdr parsed) :watch)) - (compute (plist-get (cdr parsed) :compute))) - (tp--define-layer-from-parsed layer-name props data watch compute) - (push layer-name layer-names))) + (compute (plist-get (cdr parsed) :compute)) + (transform (plist-get (cdr parsed) :transform))) + (tp--define-layer-from-parsed layer-name props data watch compute transform) + (push layer-name layer-names) + (push layer-name generated))) ;; Simple format (cons cell of name . props) ((consp parsed) (let* ((layer-name (car parsed)) (props (cdr parsed))) (tp--define-layer-from-parsed layer-name props nil nil nil) (push layer-name layer-names) + (push layer-name generated) ;; Only increment idx for anonymous (Format 1) elements (when (eq (tp--layer-group-element-format element) 'format-1) (cl-incf idx))))))) (setq layer-names (nreverse layer-names)) + (setq generated (nreverse generated)) + ;; Undefine layers generated by a previous definition of this group + ;; that are no longer part of it, so redefinition does not orphan them. + (let ((old-generated (cdr (assq name tp--group-generated-layers)))) + (dolist (stale (cl-set-difference old-generated generated)) + (tp-undefine-layer stale))) + (setf (alist-get name tp--group-generated-layers) generated) (tp--set-group-layers name layer-names) (assoc name tp-layer-groups))) @@ -554,7 +634,13 @@ ELEMENTS is the list of layer definitions." (defun tp--define-layer-group-unified (name arglist body-form) "Define a parameterized layer group NAME with ARGLIST and BODY-FORM. -Stores the group in `tp-layer-groups' with format: (GROUP-NAME ARGLIST BODY-FORM)." +Stores the group in `tp-layer-groups' with format: (GROUP-NAME ARGLIST BODY-FORM). +Layers generated by a previous non-parameterized definition of NAME +are undefined, since a parameterized group generates none." + (dolist (stale (cdr (assq name tp--group-generated-layers))) + (tp-undefine-layer stale)) + (setq tp--group-generated-layers + (assq-delete-all name tp--group-generated-layers)) (let ((entry (list arglist body-form))) (if (assoc name tp-layer-groups) (setf (cdr (assoc name tp-layer-groups)) entry) @@ -651,41 +737,47 @@ Handles two storage formats: 1. Old format (from tp--set-layer-props): (LAYER-NAME . PLIST) - flat plist 2. Unified format (from define-tp): (LAYER-NAME ARGLIST BODY-FORM) For parameterized layers (ARGLIST non-nil), returns nil - use `tp-layer-props-with-arg'. -Recursively expands any nested layer names in the returned plist." +Recursively expands any nested layer names in the returned plist. +Signals an error naming the cycle if layer references are cyclic. +The returned plist is a fresh copy: mutating it does not affect the +stored layer definition." (when-let ((entry (cdr (assoc layer-name tp-layer-alist)))) + (tp--check-layer-cycle layer-name) ;; Auto-include tp-name for layers with reactive deps - (let ((needs-tp-name (or include-tp-name + (let ((tp--layer-expansion-stack (cons layer-name tp--layer-expansion-stack)) + (needs-tp-name (or include-tp-name (tp--layer-has-reactive-deps-p layer-name)))) - (cond - ;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list - ;; Check: exactly 2 elements and first is nil or a list of symbols - ((and (= (length entry) 2) - (or (null (car entry)) - (and (listp (car entry)) - (cl-every #'symbolp (car entry))))) - (let ((arglist (car entry)) - (body (cadr entry))) - (if arglist - ;; Parameterized - needs argument, return nil - nil - ;; Non-parameterized - evaluate body and return props - (let ((plist (eval body))) - (when plist - ;; Recursively expand nested layer names - (when (tp--plist-has-layer-key-p plist) - (setq plist (tp--expand-layer-in-plist plist))) - (if needs-tp-name - (append plist (list 'tp-name layer-name)) - plist)))))) - ;; Old format: entry is just a flat plist - (t - (let ((plist entry)) - ;; Recursively expand nested layer names - (when (tp--plist-has-layer-key-p plist) - (setq plist (tp--expand-layer-in-plist plist))) - (if needs-tp-name - (append plist (list 'tp-name layer-name)) - plist))))))) + (copy-tree + (cond + ;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list + ;; Check: exactly 2 elements and first is nil or a list of symbols + ((and (= (length entry) 2) + (or (null (car entry)) + (and (listp (car entry)) + (cl-every #'symbolp (car entry))))) + (let ((arglist (car entry)) + (body (cadr entry))) + (if arglist + ;; Parameterized - needs argument, return nil + nil + ;; Non-parameterized - evaluate body and return props + (let ((plist (eval body))) + (when plist + ;; Recursively expand nested layer names + (when (tp--plist-has-layer-key-p plist) + (setq plist (tp--expand-layer-in-plist plist))) + (if needs-tp-name + (append plist (list 'tp-name layer-name)) + plist)))))) + ;; Old format: entry is just a flat plist + (t + (let ((plist entry)) + ;; Recursively expand nested layer names + (when (tp--plist-has-layer-key-p plist) + (setq plist (tp--expand-layer-in-plist plist))) + (if needs-tp-name + (append plist (list 'tp-name layer-name)) + plist)))))))) (defun tp-layer-parameterized-p (layer-name) "Return non-nil if LAYER-NAME is a parameterized layer. @@ -703,22 +795,36 @@ where ARGLIST is a non-nil list of argument symbols." "Return properties for parameterized layer LAYER-NAME with ARG. Evaluates the body form with the argument bound to the parameter. If INCLUDE-TP-NAME is non-nil, appends 'tp-name property to identify the layer. -Recursively expands any nested layer names in the returned plist." +Recursively expands any nested layer names in the returned plist. +$-prefixed reactive symbols in the body are resolved to the current +values of their variables at evaluation time; they do not create +reactive dependencies (parameterized layers cannot be reactive). +Signals an error naming the cycle if layer references are cyclic. +The returned plist is a fresh copy: mutating it does not affect the +stored layer definition." (when-let ((entry (cdr (assoc layer-name tp-layer-alist)))) ;; entry is (ARGLIST BODY-FORM) (let ((arglist (car entry)) (body (cadr entry))) (when arglist ; Only for parameterized layers - (let* ((arg-sym (car arglist)) + (tp--check-layer-cycle layer-name) + (let* ((tp--layer-expansion-stack + (cons layer-name tp--layer-expansion-stack)) + (arg-sym (car arglist)) ;; Evaluate the body with the argument bound (plist (eval `(let ((,arg-sym ',arg)) ,body)))) (when plist ;; Recursively expand nested layer names (when (tp--plist-has-layer-key-p plist) (setq plist (tp--expand-layer-in-plist plist))) - (if include-tp-name - (append plist (list 'tp-name layer-name)) - plist))))))) + ;; Resolve $-prefixed reactive symbols to their current values + ;; so they never leak literally into the returned props. + (when (tp--collect-reactive-symbols plist) + (setq plist (tp--resolve-reactive-symbols plist))) + (copy-tree + (if include-tp-name + (append plist (list 'tp-name layer-name)) + plist)))))))) (defun tp-group-props (group-name &optional include-tp-name) "Return list of properties for all layers in GROUP-NAME. @@ -754,10 +860,64 @@ where ARGLIST is a non-nil list of argument symbols." (not (null (car entry))) (cl-every #'symbolp (car entry))))) +(defun tp--group-anonymous-props (plist) + "Normalize anonymous-layer PLIST from a parameterized group element. +Expands nested layer names, resolves $-prefixed reactive symbols to +their current values, and returns a fresh copy safe for caller +mutation. Returns nil if PLIST is nil." + (when plist + (let ((props plist)) + (when (tp--plist-has-layer-key-p props) + (setq props (tp--expand-layer-in-plist props))) + (when (tp--collect-reactive-symbols props) + (setq props (tp--resolve-reactive-symbols props))) + (copy-tree props)))) + +(defun tp--group-spec-to-props (spec include-tp-name) + "Convert one evaluated parameterized-group element SPEC to a props plist. +SPEC may be: +- a symbol naming a defined layer; +- a list (LAYER-NAME ARG ...) whose head is a defined layer or group; +- a cons (\"NAME\" . PLIST) or a list (\"NAME\" :props PLIST); +- a raw property list (anonymous layer), optionally wrapped in one + extra set of parentheses as in the `define-tps' docstring example. +INCLUDE-TP-NAME is passed through for named layer references; +anonymous plists have no name, so it does not apply to them. +Returns nil if SPEC cannot be interpreted." + (cond + ;; Layer name symbol + ((symbolp spec) + (tp-layer-props spec include-tp-name)) + ((not (consp spec)) nil) + ;; (LAYER-NAME ARG ...) - defined layer at the head + ((and (symbolp (car spec)) (tp--is-layer-name-p (car spec))) + (let ((layer-name (car spec)) + (layer-arg (cadr spec))) + (if (tp-layer-parameterized-p layer-name) + (tp-layer-props-with-arg layer-name layer-arg include-tp-name) + ;; Non-parameterized layer - arg should be t or ignored + (tp-layer-props layer-name include-tp-name)))) + ;; ("NAME" :props PLIST) or ("NAME" . PLIST) - use the props part + ((stringp (car spec)) + (tp--group-anonymous-props + (if (eq (cadr spec) :props) + (caddr spec) + (cdr spec)))) + ;; One extra level of wrapping, e.g. ((face (:foreground "red"))) + ((and (consp (car spec)) (null (cdr spec))) + (tp--group-spec-to-props (car spec) include-tp-name)) + ;; Raw plist - anonymous layer + ((symbolp (car spec)) + (tp--group-anonymous-props spec)) + (t nil))) + (defun tp-group-props-with-arg (group-name arg &optional include-tp-name) "Return list of properties for parameterized group GROUP-NAME with ARG. Evaluates the body form with the argument bound to the parameter. -Each evaluated element is a layer reference like (layer-name arg) or just layer-name. +Each evaluated element may be a layer name symbol, a (LAYER-NAME ARG) +reference, a named element (\"NAME\" . PLIST) / (\"NAME\" :props PLIST), +or a raw property list (anonymous layer) as documented in `define-tps'. +If INCLUDE-TP-NAME is non-nil, named layer references include tp-name. Returns a list of property lists for each layer in the group." (when-let ((entry (cdr (assoc group-name tp-layer-groups)))) ;; entry is (ARGLIST BODY-FORM) @@ -769,19 +929,7 @@ Returns a list of property lists for each layer in the group." (layer-specs (eval `(let ((,arg-sym ',arg)) ,body-form)))) ;; Convert layer specs to property lists (mapcar (lambda (spec) - (cond - ;; spec is a symbol - just a layer name - ((symbolp spec) - (tp-layer-props spec include-tp-name)) - ;; spec is (layer-name arg) - parameterized layer - ((and (listp spec) (symbolp (car spec))) - (let ((layer-name (car spec)) - (layer-arg (cadr spec))) - (if (tp-layer-parameterized-p layer-name) - (tp-layer-props-with-arg layer-name layer-arg include-tp-name) - ;; Non-parameterized layer - arg should be t or ignored - (tp-layer-props layer-name include-tp-name)))) - (t nil))) + (tp--group-spec-to-props spec include-tp-name)) layer-specs)))))) (defun tp--is-layer-name-p (sym) @@ -926,7 +1074,7 @@ For group names, includes `tp-layers' property with the full layer stack." ;; Has reactive symbols - need anonymous tp-name for reactive tracking (let* ((existing-tp-name (plist-get props 'tp-name)) (layer-name (or existing-tp-name - (tp--generate-anonymous-layer-name))) + (tp--anonymous-layer-name-for props))) ;; Resolve reactive symbols in expanded props (resolved-props (tp--resolve-reactive-symbols expanded-props))) ;; Register reactive dependencies @@ -958,7 +1106,7 @@ For group names, includes `tp-layers' property with the full layer stack." ;; Has reactive symbols - need anonymous tp-name for reactive tracking (let* ((existing-tp-name (plist-get props 'tp-name)) (layer-name (or existing-tp-name - (tp--generate-anonymous-layer-name))) + (tp--anonymous-layer-name-for props))) ;; Resolve reactive symbols in expanded props (resolved-props (tp--resolve-reactive-symbols expanded-props))) ;; Register reactive dependencies @@ -975,7 +1123,7 @@ For group names, includes `tp-layers' property with the full layer stack." (if reactive-syms ;; Has reactive symbols - need to handle as anonymous reactive layer (let* ((layer-name (or existing-tp-name - (tp--generate-anonymous-layer-name))) + (tp--anonymous-layer-name-for props))) ;; Resolve reactive symbols to get current values (resolved-props (tp--resolve-reactive-symbols props))) ;; Register this anonymous layer in tp-layer-alist with resolved props @@ -1024,17 +1172,31 @@ Also resets all reactive text property watchers, dependencies, and transforms." (tp-reactive-reset) (setq tp-layer-alist nil) (setq tp-layer-groups nil) - (setq tp-layer-transforms nil)) + (setq tp-layer-transforms nil) + (setq tp--group-generated-layers nil) + (setq tp--anonymous-layer-registry nil)) (defun tp-undefine-layer (name) "Remove layer NAME from `tp-layer-alist'. -Also unregisters any reactive dependencies and transforms for this layer." +Also unregisters any reactive dependencies and transforms for this layer, +and drops any anonymous-layer registry entries interned for it." (tp--unregister-reactive-deps name) (setq tp-layer-alist (assq-delete-all name tp-layer-alist)) - (setq tp-layer-transforms (assq-delete-all name tp-layer-transforms))) + (setq tp-layer-transforms (assq-delete-all name tp-layer-transforms)) + (setq tp--anonymous-layer-registry + (cl-remove-if (lambda (cell) (eq (cdr cell) name)) + tp--anonymous-layer-registry))) (defun tp-undefine-group (name) - "Remove layer group NAME from `tp-layer-groups'." + "Remove layer group NAME from `tp-layer-groups'. +Also undefines the layers that the group definition itself generated +(anonymous and named elements), including their reactive dependencies +and transforms. Layers merely referenced by the group are left +untouched." + (dolist (generated (cdr (assq name tp--group-generated-layers))) + (tp-undefine-layer generated)) + (setq tp--group-generated-layers + (assq-delete-all name tp--group-generated-layers)) (setq tp-layer-groups (assq-delete-all name tp-layer-groups))) (defun tp--normalize-layer-spec (layer-spec) diff --git a/tp-reactive.el b/tp-reactive.el index c24fa4a..6d865e8 100644 --- a/tp-reactive.el +++ b/tp-reactive.el @@ -36,12 +36,48 @@ Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).") "Alist of data variables: (LAYER-NAME . (VAR-SYMBOL ...)).") (defvar tp--batch-update-pending nil - "When non-nil, reactive updates are being batched. -This is a list of (LAYER-NAME . CHANGED-VARS) pairs pending update.") + "Queue of deferred reactive buffer re-renders. +Each entry is a list (LAYER-NAME CHANGED-SYMBOLS WHERE TP-TEXT-AFFECTED). +Entries are created and widened by `tp--queue-batch-update'.") (defvar tp--batch-update-active nil "When non-nil, we are inside a `tp-with-batch-updates' form.") +(defvar tp--reactive-updating nil + "Non-nil while a reactive update is being applied. +Used as a reentrancy guard: when a variable is set from within an +update (a computed variable being written, or the tp-text two-way +sync), the nested change still updates the variable, but its +re-render is queued in `tp--batch-update-pending' and flushed after +the outermost update completes instead of recursing.") + +(defconst tp--compute-error (make-symbol "tp--compute-error") + "Sentinel distinguishing a failed compute from a legitimate nil result. +Compute functions may legitimately return nil (e.g. a boolean feeding +`invisible'), so error paths return this uninterned sentinel instead +of nil.") + +(defun tp--queue-batch-update (layer-name symbol where tp-text-affected) + "Queue a deferred re-render of LAYER-NAME in `tp--batch-update-pending'. +SYMBOL is the changed variable, WHERE the buffer for buffer-local +changes (nil for global ones), TP-TEXT-AFFECTED non-nil when the +change touches the layer's `tp-text'. When the layer already has a +pending entry, the entry is widened to the union of both changes: +SYMBOL is added, TP-TEXT-AFFECTED is sticky (once set it stays set) +and WHERE widens to nil (all buffers) as soon as two changes disagree +on it." + (let ((existing (assoc layer-name tp--batch-update-pending))) + (if existing + (progn + (unless (memq symbol (nth 1 existing)) + (setf (nth 1 existing) (cons symbol (nth 1 existing)))) + (unless (eq (nth 2 existing) where) + (setf (nth 2 existing) nil)) + (when tp-text-affected + (setf (nth 3 existing) t))) + (push (list layer-name (list symbol) where (and tp-text-affected t)) + tp--batch-update-pending)))) + (defun tp--register-reactive-deps (layer-name reactive-symbols props) "Register REACTIVE-SYMBOLS as dependencies for LAYER-NAME. PROPS is the original property specification with reactive symbols. @@ -246,7 +282,10 @@ COMPUTED is a list of (VAR-SYMBOL COMPUTE-FN) pairs." (defun tp--apply-initial-computed (compute) "Apply initial computed values using COMPUTE definitions. COMPUTE is a list of (VAR-SYMBOL COMPUTE-FN) pairs. -Sets the global variables to their computed values." +Sets the global variables to their computed values. +A compute function returning nil is a legitimate result and is +applied; only computes that signal an error are skipped (see +`tp--compute-error')." (dolist (comp compute) (let* ((var-sym (car comp)) (compute-fn (cadr comp)) @@ -254,8 +293,8 @@ Sets the global variables to their computed values." (funcall compute-fn) (error (message "tp: initial compute error for %s: %s" var-sym err) - nil)))) - (when val + tp--compute-error)))) + (unless (eq val tp--compute-error) (set var-sym val))))) (defun tp--data-var-symbol (data-entry) diff --git a/tp-render-tests.el b/tp-render-tests.el new file mode 100644 index 0000000..21add29 --- /dev/null +++ b/tp-render-tests.el @@ -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 diff --git a/tp-render.el b/tp-render.el index 713b9d6..96c7c1f 100644 --- a/tp-render.el +++ b/tp-render.el @@ -26,9 +26,44 @@ (require 'tp-ops) (require 'tp-search) +(defun tp--layer-reactive-props (layer-name) + "Collect LAYER-NAME's unresolved reactive props from `tp-reactive-deps'. +Each dependency entry stores only the portions of the layer's props +that reference one variable; this merges the fragments back into a +single plist with the `$var' markers intact. Returns nil when the +layer has no reactive props (data-only dependencies store nil)." + (let ((all nil)) + (dolist (dep tp-reactive-deps) + (let ((layer-entry (assoc layer-name (cdr dep)))) + (when (and layer-entry (cdr layer-entry)) + (setq all (if all + (tp--deep-merge-plist all (cdr layer-entry)) + (copy-sequence (cdr layer-entry))))))) + all)) + +(defun tp--layer-render-props (layer-name override-alist) + "Return LAYER-NAME's props for re-rendering in the current buffer. +Starts from the stored layer definition and deep-merges the layer's +reactive props re-resolved against the current variable values, so +buffer-local values are honored when the target buffer is current. +OVERRIDE-ALIST maps variables to not-yet-visible new values (the +variable watcher runs before the variable is actually set) and takes +precedence over `symbol-value'. Returns nil when the layer has no +usable definition." + (let ((base (tp-layer-props layer-name t))) ; include tp-name for tracking + (when base + (let ((reactive (tp--layer-reactive-props layer-name))) + (if reactive + (tp--deep-merge-plist + base (tp--resolve-reactive-symbols reactive override-alist)) + base))))) + (defun tp--update-layer-computed (layer-name override-alist) "Update computed reactive variables for LAYER-NAME with OVERRIDE-ALIST. Evaluates compute functions and updates the reactive variable values. +A compute function returning nil is a legitimate result and is +propagated; only computes that signal an error are skipped (see +`tp--compute-error'). Returns an updated override-alist with the new computed values." (when-let ((computed (cdr (assoc layer-name tp-layer-computed)))) (dolist (comp computed) @@ -45,8 +80,8 @@ Returns an updated override-alist with the new computed values." (error (message "tp: compute error for %s.%s: %s" layer-name var-sym err) - nil)))) - (when computed-val + tp--compute-error)))) + (unless (eq computed-val tp--compute-error) ;; Update the global variable (set var-sym computed-val) ;; Add to override-alist for property resolution @@ -54,50 +89,58 @@ Returns an updated override-alist with the new computed values." ;; Also update the layer properties if the computed var is used in props (let ((current-props (cdr (assoc layer-name tp-layer-alist)))) (when current-props - ;; Collect all reactive props for this layer from tp-reactive-deps - (let ((all-reactive-props nil)) - (dolist (dep tp-reactive-deps) - (let ((layer-entry (assoc layer-name (cdr dep)))) - (when (and layer-entry (cdr layer-entry)) - ;; Merge the reactive props - (cl-loop for (key val) on (cdr layer-entry) by #'cddr - do (setq all-reactive-props - (plist-put all-reactive-props key val)))))) - (when all-reactive-props - (let ((resolved-props (tp--resolve-reactive-symbols - all-reactive-props override-alist))) - (when resolved-props - (cl-loop for (key val) on resolved-props by #'cddr - do (setq current-props (plist-put current-props key val))) - (tp--set-layer-props layer-name current-props))))))))))) + (when-let ((all-reactive-props (tp--layer-reactive-props layer-name))) + (let ((resolved-props (tp--resolve-reactive-symbols + all-reactive-props override-alist))) + (when resolved-props + ;; Deep-merge the resolved props into the current layer + ;; props so sibling static attributes nested in plists + ;; (e.g. a :background next to a reactive :foreground) + ;; survive the update. + (tp--set-layer-props + layer-name + (tp--deep-merge-plist current-props resolved-props))))))))))) override-alist) -(defun tp--update-layer-regions (layer-name &optional where) +(defun tp--update-layer-regions (layer-name &optional where override-alist) "Update text regions that have LAYER-NAME applied. -Re-applies the layer properties using tp-search-map and tp-add. +Re-applies the layer's current properties to every region tagged with +the layer's `tp-name'. The layer's OWN property keys are replaced +with their current values (so refresh is idempotent: a face variable +changing from bold to italic yields italic, not (italic bold)), while +properties contributed by other sources are left untouched. WHERE specifies which buffers to update: - If WHERE is a buffer, only update that buffer (setq-local case). - - If WHERE is nil, update all buffers that have the text property (setq case)." - (let ((props (tp-layer-props layer-name t))) ; include tp-name for reactive tracking - (when props - ;; Callback for tp-search-map: applies props to matched region. - ;; _TEXT is unused (the matched text), START and END are buffer positions. - ;; Returns nil to prevent tp-search-map from replacing the text. - (let ((apply-props-fn (lambda (_text start end) - (tp-add start end props) - nil))) - (if (and where (bufferp where) (buffer-live-p where)) - ;; setq-local case: only update the specific buffer - (tp-with-current-buffer where - (save-excursion - (tp-search-map apply-props-fn 'tp-name layer-name))) - ;; setq case: update all buffers that have the text property - (dolist (buf (buffer-list)) - (when (buffer-live-p buf) - (tp-with-current-buffer buf - (save-excursion - (tp-search-map apply-props-fn 'tp-name layer-name)))))))))) + - If WHERE is nil, update all buffers that have the text property. + +OVERRIDE-ALIST maps reactive variables to their new values when the +watcher fires before the variables are set; layer props are +re-resolved against it in each target buffer, so buffer-local +variable values are honored." + (let ((update-buffer + (lambda () + (let ((props (tp--layer-render-props layer-name override-alist))) + (when props + (save-excursion + ;; Callback for tp-search-map: replaces the layer's own + ;; property keys on the matched region. Returns nil to + ;; prevent tp-search-map from replacing the text. + (tp-search-map + (lambda (_text start end) + (cl-loop for (key val) on props by #'cddr + do (put-text-property start end key val)) + nil) + 'tp-name layer-name))))))) + (if (and where (bufferp where) (buffer-live-p where)) + ;; setq-local case: only update the specific buffer + (tp-with-current-buffer where + (funcall update-buffer)) + ;; setq case: update all buffers that have the text property + (dolist (buf (buffer-list)) + (when (buffer-live-p buf) + (tp-with-current-buffer buf + (funcall update-buffer))))))) (defun tp--find-tp-text-reactive-var (layer-name) "Find the reactive variable symbol used for tp-text in LAYER-NAME. @@ -119,7 +162,62 @@ Searches through `tp-reactive-deps' to find the original reactive props." (throw 'found var-sym)))))))) nil)) -(defun tp--update-reactive-text (layer-name &optional where) +(defun tp--tp-text-transform (layer-name text) + "Return TEXT transformed by LAYER-NAME's `:transform', or TEXT. +Transform errors are reported and TEXT is returned unchanged; a +non-string transform result is ignored as well." + (let ((transform-fn (when layer-name + (cdr (assoc layer-name tp-layer-transforms))))) + (if (not transform-fn) + text + (condition-case err + (let ((result (funcall transform-fn text))) + (tp-debug-log " Transform %s: %S -> %S" layer-name text result) + (if (stringp result) result text)) + (error + (message "tp: transform error for %s: %s" layer-name err) + text))))) + +(defun tp--merge-embedded-props (embedded props) + "Merge the EMBEDDED string props plist under PROPS; PROPS win. +Like `tp--merge-string-props-into-plist' but takes the embedded plist +directly instead of sampling position 0 of a string, so callers can +merge per property interval. Face-family values (see +`tp-face-properties') are merged with PROPS taking precedence; other +conflicting keys keep the PROPS value; keys only in EMBEDDED are +added." + (let ((result (copy-sequence props))) + (cl-loop for (key val) on embedded by #'cddr + do (let ((existing (plist-get result key))) + (setq result + (plist-put result key + (if existing + (if (memq key tp-face-properties) + (tp--merge-face-values val existing) + existing) + val))))) + result)) + +(defun tp--apply-reactive-text-props (source props offset &optional target) + "Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET. +SOURCE is the (possibly propertized) replacement string; TARGET is a +string, or nil for the current buffer. For every embedded-property +interval of SOURCE the interval's props are merged under PROPS (see +`tp--merge-embedded-props') and the result is applied to the +corresponding span of TARGET shifted by OFFSET. This keeps +per-interval styling of propertized reactive strings intact instead +of smearing position-0 props across the whole region." + (tp--map-intervals + source nil nil + (lambda (istart iend str-props) + (let ((merged (if str-props + (tp--merge-embedded-props str-props props) + props))) + (cl-loop for (key val) on merged by #'cddr + do (put-text-property (+ offset istart) (+ offset iend) + key val target)))))) + +(defun tp--update-reactive-text (layer-name &optional where override-alist) "Update text regions that have tp-text property with LAYER-NAME applied. This is called when a reactive variable bound to tp-text changes. @@ -127,68 +225,131 @@ WHERE specifies which buffers to update: - If WHERE is a buffer, only update that buffer (setq-local case). - If WHERE is nil, update all buffers that have the text property (setq case). +OVERRIDE-ALIST maps reactive variables to their new values when the +watcher fires before the variables are set; the layer's props are +re-resolved against it in each target buffer. + If a transform function is registered for LAYER-NAME via `:transform', it will be applied to the text before updating." - (let ((props (tp-layer-props layer-name t))) ; include tp-name for reactive tracking - (when props - (let* ((raw-text (plist-get props 'tp-text)) - ;; Apply transformation if registered - (transform-fn (cdr (assoc layer-name tp-layer-transforms))) - (new-text (if (and transform-fn raw-text (stringp raw-text)) - (condition-case err - (let ((result (funcall transform-fn raw-text))) - (tp-debug-log " Transform %s: %S -> %S" - layer-name raw-text result) - result) - (error - (message "tp: transform error for %s: %s" - layer-name err) - raw-text)) - raw-text))) - (when (and new-text (stringp new-text)) - (if (and where (bufferp where) (buffer-live-p where)) - ;; setq-local case: only update the specific buffer - (tp-with-current-buffer where - (save-excursion - (tp--replace-reactive-text-in-buffer layer-name new-text props))) - ;; setq case: update all buffers that have the text property - (dolist (buf (buffer-list)) - (when (buffer-live-p buf) - (tp-with-current-buffer buf - (save-excursion - (tp--replace-reactive-text-in-buffer layer-name new-text props))))))))))) + (let ((update-buffer + (lambda () + (let ((props (tp--layer-render-props layer-name override-alist))) + (when props + (let* ((raw-text (plist-get props 'tp-text)) + ;; Apply transformation if registered + (new-text (if (stringp raw-text) + (tp--tp-text-transform layer-name raw-text) + raw-text))) + (when (and new-text (stringp new-text)) + (save-excursion + (tp--replace-reactive-text-in-buffer + layer-name new-text props))))))))) + (if (and where (bufferp where) (buffer-live-p where)) + ;; setq-local case: only update the specific buffer + (tp-with-current-buffer where + (funcall update-buffer)) + ;; setq case: update all buffers that have the text property + (dolist (buf (buffer-list)) + (when (buffer-live-p buf) + (tp-with-current-buffer buf + (funcall update-buffer))))))) (defun tp--replace-reactive-text-in-buffer (layer-name new-text props) "Replace text in current buffer for reactive text with LAYER-NAME. NEW-TEXT is the new text to replace with. PROPS are the properties to apply to the new text. -Text properties embedded in NEW-TEXT are merged with PROPS. -The new properties completely reset/replace the old properties." +Text properties embedded in NEW-TEXT are merged with PROPS per +embedded interval, so a multi-interval propertized reactive string +keeps its per-character styling. Existing text properties whose keys +are set neither by PROPS nor by NEW-TEXT's embedded props are +preserved, so one layer's text update does not erase other layers' +contributions on the same region." (goto-char (point-min)) (let ((match (text-property-search-forward 'tp-name layer-name t)) - ;; Merge embedded text properties from new-text into props - (merged-props (tp--merge-string-props-into-plist new-text props))) + (plain-text (substring-no-properties new-text))) (while match (let* ((m-start (prop-match-beginning match)) (m-end (prop-match-end match)) (old-text (buffer-substring-no-properties m-start m-end))) - (if (equal old-text (substring-no-properties new-text)) - ;; Text content is the same, but properties may differ - ;; Use set-text-properties to reset with new properties - (set-text-properties m-start m-end merged-props) - ;; Text content is different - delete old text and insert new - (delete-region m-start m-end) - (goto-char m-start) - (insert (substring-no-properties new-text)) - ;; Apply new properties - (let ((new-end (+ m-start (length new-text)))) - (set-text-properties m-start new-end merged-props)))) + (unless (equal old-text plain-text) + ;; Text content differs: replace it, carrying over the existing + ;; properties whose keys this layer does not set. + (let ((existing-props (text-properties-at m-start))) + (delete-region m-start m-end) + (goto-char m-start) + (insert plain-text) + (let ((new-end (+ m-start (length plain-text)))) + (cl-loop for (key val) on existing-props by #'cddr + do (unless (plist-member props key) + (put-text-property m-start new-end key val)))))) + ;; Apply the layer's props, merged per embedded interval of NEW-TEXT. + ;; Keys are replaced (not accumulated); unrelated keys are untouched. + (tp--apply-reactive-text-props new-text props m-start)) ;; Search for next match (setq match (text-property-search-forward 'tp-name layer-name t))))) +(defun tp--tp-text-replace (start end final-text result-props object preserve-props) + "Replace [START, END) of OBJECT with FINAL-TEXT, handling props. +Implements the text replacement of `tp--handle-tp-text-property' and +returns its (PROPS NEW-END NEW-OBJECT) result. + +For a string OBJECT a NEW string is built as prefix + FINAL-TEXT + +suffix, so text outside the region survives. RESULT-PROPS (merged +per embedded interval of FINAL-TEXT) are applied to the replaced span +here, because callers can only apply props from index 0, which would +smear them over the preserved prefix; the returned NEW-END is 0 so +the caller's own application over [0, NEW-END) is a no-op. + +For buffers the region text is replaced in place and the returned +NEW-END is the end of the inserted text; the caller applies +RESULT-PROPS itself. + +When PRESERVE-PROPS is non-nil, properties present at START whose +keys RESULT-PROPS does not set are re-applied over the replacement." + (if (stringp object) + (let* ((plain (substring-no-properties final-text)) + ;; Splice: keep the string outside [start, end) intact. + (new-string (concat (substring object 0 start) + plain + (substring object end))) + (new-end (+ start (length plain))) + (existing-props (when preserve-props + (text-properties-at start object)))) + ;; Preserve non-conflicting existing props of the replaced region + (cl-loop for (key val) on existing-props by #'cddr + do (unless (plist-member result-props key) + (put-text-property start new-end key val new-string))) + ;; Apply the merged props per embedded interval of FINAL-TEXT + (tp--apply-reactive-text-props final-text result-props start new-string) + (list result-props 0 new-string)) + ;; Buffer object + (with-current-buffer (or object (current-buffer)) + (let ((old-text (buffer-substring-no-properties start end))) + (if (equal old-text (substring-no-properties final-text)) + ;; Same text content, no replacement needed + (list result-props end object) + ;; Need to replace text + (let ((existing-props (when preserve-props + (text-properties-at start))) + (inhibit-read-only t)) + (save-excursion + (delete-region start end) + (goto-char start) + ;; Insert without properties - the caller applies RESULT-PROPS + (insert (substring-no-properties final-text))) + (let ((new-end (+ start (length final-text)))) + ;; Re-apply existing properties to new text region if preserving + (cl-loop for (key val) on existing-props by #'cddr + do (unless (plist-member result-props key) + (put-text-property start new-end key val object))) + (list result-props new-end object)))))))) + (defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode) "Handle tp-text property in PROPS for region from START to END in OBJECT. -If tp-text is nil, initialize it to the current text in the region. +If tp-text is nil, initialize it to the current text in the region; +when the layer has a `:transform', the displayed text is the +transformed value (matching later reactive updates) while the model - +the reactive variable and the `tp-text' property - keeps the raw text. If tp-text is a string different from current text, replace the text. When PRESERVE-PROPS is non-nil, existing text properties are preserved on the replaced text (used by tp-set and tp-add). @@ -197,24 +358,26 @@ All modes now preserve embedded text properties from tp-text, with props taking precedence over embedded props when there's a conflict. Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props, NEW-END is the new end position after any text replacement, and -NEW-OBJECT is the new string object (only different for strings with tp-text)." +NEW-OBJECT is the new string object (only different for strings whose +text was replaced; see `tp--tp-text-replace' for the string-object +convention of a 0 NEW-END with pre-applied properties)." + (ignore merge-mode) (if (not (plist-member props 'tp-text)) ;; tp-text not in props - return unchanged (list props end object) - (let ((tp-text-val (plist-get props 'tp-text))) + (let ((tp-text-val (plist-get props 'tp-text)) + (layer-name (plist-get props 'tp-name))) (cond ;; tp-text is nil - initialize it to the current text ((null tp-text-val) (let ((current-text (if (stringp object) - (substring object start end) - (if object - (with-current-buffer object - (buffer-substring-no-properties start end)) + (substring-no-properties object start end) + (with-current-buffer (or object (current-buffer)) (buffer-substring-no-properties start end))))) ;; If tp-text uses a reactive variable, update that variable to match ;; This ensures the reactive variable and buffer text stay in sync - (when-let ((layer-name (plist-get props 'tp-name))) + (when layer-name (when-let ((reactive-var (tp--find-tp-text-reactive-var layer-name))) ;; Update the reactive variable with the current text ;; Note: Using global `set` here because the layer definition is global. @@ -226,68 +389,29 @@ NEW-OBJECT is the new string object (only different for strings with tp-text)." (when layer-props (tp--set-layer-props layer-name (plist-put layer-props 'tp-text current-text)))))) - (list (plist-put props 'tp-text current-text) end object))) + (setq props (plist-put props 'tp-text current-text)) + ;; Apply the layer's :transform to the DISPLAYED text on this first + ;; render too, so the initial rendering matches later reactive + ;; updates. The model value stays the raw text. + (let ((display-text (tp--tp-text-transform layer-name current-text))) + (if (equal display-text current-text) + (list props end object) + (tp--tp-text-replace + start end display-text + (tp--merge-string-props-into-plist display-text props) + object preserve-props))))) ;; tp-text has a string value - replace the text in the region ((stringp tp-text-val) ;; Apply transform if layer has one registered - (let* ((layer-name (plist-get props 'tp-name)) - (transform-fn (when layer-name - (cdr (assoc layer-name tp-layer-transforms)))) - (final-text - (if transform-fn - (condition-case err - (funcall transform-fn tp-text-val) - (error - (message "tp: transform error for %s: %s" layer-name err) - tp-text-val)) - tp-text-val)) - ;; Embedded text properties from tp-text are now preserved in all cases. - ;; The props passed to this function take precedence over embedded props - ;; when there's a conflict (e.g., both have 'face' property). - ;; The merge-mode parameter is retained for backward compatibility but - ;; no longer affects behavior in this function - all modes use the same - ;; merging strategy via tp--merge-string-props-into-plist. + (let* ((final-text (tp--tp-text-transform layer-name tp-text-val)) + ;; Embedded text properties from tp-text are preserved in all + ;; cases. The props passed to this function take precedence + ;; over embedded props when there's a conflict (e.g. both have + ;; a `face' property). (result-props (tp--merge-string-props-into-plist final-text props))) - (if (stringp object) - ;; For strings: create a new string with tp-text content - ;; Strip properties - result-props will be applied by the caller - (let ((new-string (substring-no-properties final-text))) - (list result-props (length new-string) new-string)) - ;; For buffers: replace text and adjust end position - (let ((old-text (if object - (with-current-buffer object - (buffer-substring-no-properties start end)) - (buffer-substring-no-properties start end)))) - (if (equal old-text (substring-no-properties final-text)) - ;; Same text content, no replacement needed - (list result-props end object) - ;; Need to replace text - (let ((existing-props (when preserve-props - (if object - (with-current-buffer object - (text-properties-at start)) - (text-properties-at start))))) - (save-excursion - (if object - (with-current-buffer object - (let ((inhibit-read-only t)) - (delete-region start end) - (goto-char start) - ;; Insert without properties - we'll apply result-props later - (insert (substring-no-properties final-text)))) - (let ((inhibit-read-only t)) - (delete-region start end) - (goto-char start) - (insert (substring-no-properties final-text))))) - (let ((new-end (+ start (length final-text)))) - ;; Re-apply existing properties to new text region if preserving - (when existing-props - (cl-loop for (key val) on existing-props by #'cddr - do (unless (plist-member result-props key) - (put-text-property - start new-end key val object)))) - (list result-props new-end object)))))))) + (tp--tp-text-replace start end final-text result-props + object preserve-props))) ;; Other types - return unchanged (t (list props end object)))))) @@ -299,51 +423,69 @@ variable SYMBOL; NEWVAL is its new value. WHERE is the buffer for `setq-local' changes, nil for global ones. OVERRIDE-ALIST maps SYMBOL to NEWVAL (the watcher runs before the variable is actually set). +Buffer-local changes (WHERE a buffer) re-render only that buffer, +resolving the layer's props against the buffer-local values, and do +NOT touch the global layer definition, so `setq-local' cannot leak a +buffer's value into other buffers. + When `tp--batch-update-active' is non-nil the buffer update is queued -in `tp--batch-update-pending' instead of applied immediately. +in `tp--batch-update-pending' instead of applied immediately. When +this function is re-entered from a nested variable write issued +inside an update (a computed variable being set, or the tp-text +two-way sync), the nested re-render is queued the same way and +flushed once the outermost update completes, instead of recursing. This is the engine behind `tp--reactive-variable-watcher'; it is installed as `tp--reactive-update-function'." - (let ((tp-text-affected (plist-member reactive-props 'tp-text))) - ;; Update computed properties for this layer - (let ((updated-override - (tp--update-layer-computed layer-name override-alist))) - (when reactive-props - ;; Resolve the reactive props with the new value override - (let ((resolved-props (tp--resolve-reactive-symbols - reactive-props updated-override))) - ;; Update only the reactive properties in the layer definition - (let ((current-props (cdr (assoc layer-name tp-layer-alist)))) - (when current-props - ;; Deep merge the resolved reactive props into the current - ;; layer props to preserve nested plist values (like face) - (setq current-props (tp--deep-merge-plist current-props - resolved-props)) - (tp--set-layer-props layer-name current-props)))))) - ;; Update text regions with this layer (or defer if batching) - (if tp--batch-update-active - ;; Batching: defer the buffer update - ;; Pending format: (layer-name symbols-list where tp-text-affected) - (let ((existing (assoc layer-name tp--batch-update-pending))) - (tp-debug-log " Deferring buffer update for %s (batch mode)" - layer-name) - (if existing - ;; Update existing entry: add symbol if not present - (let ((symbols (nth 1 existing))) - (unless (memq symbol symbols) - (setf (nth 1 existing) (cons symbol symbols)))) - ;; Create new entry - (push (list layer-name (list symbol) where tp-text-affected) - tp--batch-update-pending))) - ;; Normal: update immediately - (tp-debug-log " Updating layer %s (tp-text affected: %s)" - layer-name (if tp-text-affected "yes" "no")) - (tp--reactive-flush-entry layer-name where tp-text-affected)))) + (ignore newval) + (let ((tp-text-affected (and (plist-member reactive-props 'tp-text) t))) + (if tp--reactive-updating + ;; Nested change fired from within an update: queue, don't recurse. + (tp--queue-batch-update layer-name symbol where tp-text-affected) + (let ((tp--reactive-updating t)) + ;; Update computed properties for this layer + (let ((updated-override + (tp--update-layer-computed layer-name override-alist))) + ;; Update only the reactive properties in the layer definition. + ;; Buffer-local changes must not leak into the global definition; + ;; the buffer re-render below resolves against the buffer-local + ;; values instead. + (when (and reactive-props (not (bufferp where))) + (let ((resolved-props (tp--resolve-reactive-symbols + reactive-props updated-override)) + (current-props (cdr (assoc layer-name tp-layer-alist)))) + (when current-props + ;; Deep merge the resolved reactive props into the current + ;; layer props to preserve nested plist values (like face) + (tp--set-layer-props + layer-name + (tp--deep-merge-plist current-props resolved-props))))) + ;; Update text regions with this layer (or defer if batching) + (if tp--batch-update-active + ;; Batching: defer the buffer update + (progn + (tp-debug-log " Deferring buffer update for %s (batch mode)" + layer-name) + (tp--queue-batch-update layer-name symbol where + tp-text-affected)) + ;; Normal: update immediately + (tp-debug-log " Updating layer %s (tp-text affected: %s)" + layer-name (if tp-text-affected "yes" "no")) + (if tp-text-affected + (tp--update-reactive-text layer-name where updated-override) + (tp--update-layer-regions layer-name where updated-override))))) + ;; Re-renders queued by nested variable writes during this update are + ;; flushed now that the outermost update has finished. + (unless tp--batch-update-active + (when tp--batch-update-pending + (tp--flush-batch-updates)))))) (defun tp--reactive-flush-entry (layer-name where tp-text-affected) "Re-render LAYER-NAME's regions in WHERE (or all buffers when nil). TP-TEXT-AFFECTED non-nil means the layer's `tp-text' changed and the -text itself must be replaced. Installed as +text itself must be replaced. Runs after the changed variables have +actually been set, so layer props re-resolve against current +\(buffer-local aware) values. Installed as `tp--reactive-flush-function'." (if tp-text-affected (tp--update-reactive-text layer-name where) diff --git a/tp-search-tests.el b/tp-search-tests.el new file mode 100644 index 0000000..ab041ba --- /dev/null +++ b/tp-search-tests.el @@ -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 diff --git a/tp-search.el b/tp-search.el index 47706df..0e02a0b 100644 --- a/tp-search.el +++ b/tp-search.el @@ -23,42 +23,91 @@ (require 'tp-layer) (require 'tp-ops) -(defun tp--match-apply-single (pattern properties apply-fn object) +(defun tp--pattern-apply-single (pattern properties apply-fn object literal) "Apply APPLY-FN to matches of single PATTERN in OBJECT. +When LITERAL is non-nil, PATTERN is matched literally; otherwise it +is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for +each match. +For strings, returns a NEW string with properties applied +\(non-destructive). +For buffers, modifies in-place and returns list of regions. + +Zero-width matches (an empty literal pattern, or a regexp that can +match the empty string) are recorded and the scan advances one +position past them, so the search always terminates." + (let ((regexp (if literal (regexp-quote pattern) pattern))) + (cond + ;; String object + ((stringp object) + ;; First, collect all match positions from the original string + (let ((matches nil) + (pos 0) + (limit (length object))) + (while (and (<= pos limit) (string-match regexp object pos)) + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (push (cons beg end) matches) + (setq pos (if (= beg end) (1+ beg) end)))) + ;; Apply function to each match in order (reverse to get correct order) + ;; Make a copy to ensure original string is not modified + (let ((result (copy-sequence object))) + (dolist (match (nreverse matches)) + (when properties + (setq result (funcall apply-fn + (car match) (cdr match) + properties result)))) + result))) + ;; Buffer or nil (current buffer) + (t + (let ((buf (or object (current-buffer)))) + (tp-with-current-buffer buf + (save-excursion + (goto-char (point-min)) + (let (regions (keep-going t)) + (while (and keep-going (re-search-forward regexp nil t)) + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (when properties + (funcall apply-fn beg end properties buf)) + (push (cons beg end) regions) + ;; Guard against zero-width matches looping forever + (when (= beg end) + (if (eobp) + (setq keep-going nil) + (forward-char 1))))) + (nreverse regions))))))))) + +(defun tp--pattern-apply (pattern properties apply-fn object literal) + "Apply APPLY-FN to matches of PATTERN (one pattern or a list). +When LITERAL is non-nil, patterns are matched literally; otherwise +they are regexps. APPLY-FN is called with (START END PROPS OBJECT) +for each match. +For strings, returns a NEW string with properties applied +\(non-destructive). +For buffers, returns list of regions." + (let ((patterns (if (listp pattern) pattern (list pattern)))) + (cond + ;; String object + ((stringp object) + (let ((result object)) + (dolist (p patterns) + (setq result (tp--pattern-apply-single p properties apply-fn + result literal))) + result)) + ;; Buffer or nil (current buffer) + (t + (let ((all-regions nil)) + (dolist (p patterns) + (let ((regions (tp--pattern-apply-single p properties apply-fn + object literal))) + (setq all-regions (append all-regions regions)))) + all-regions))))) + +(defun tp--match-apply-single (pattern properties apply-fn object) + "Apply APPLY-FN to literal matches of single PATTERN in OBJECT. For strings, returns a new string with properties applied (non-destructive). For buffers, modifies in-place and returns list of regions." - (cond - ;; String object - ((stringp object) - ;; First, collect all match positions from the original string - (let ((matches nil) - (pos 0)) - (while (string-match (regexp-quote pattern) object pos) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (push (cons beg end) matches) - (setq pos (if (= beg end) (1+ beg) end)))) - ;; Apply function to each match in order (reverse to get correct order) - ;; Make a copy to ensure original string is not modified - (let ((result (copy-sequence object))) - (dolist (match (nreverse matches)) - (when properties - (setq result (funcall apply-fn (car match) (cdr match) properties result)))) - result))) - ;; Buffer or nil (current buffer) - (t - (let ((buf (or object (current-buffer)))) - (tp-with-current-buffer buf - (save-excursion - (goto-char (point-min)) - (let (regions) - (while (search-forward pattern nil t) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (when properties - (funcall apply-fn beg end properties buf)) - (push (cons beg end) regions))) - (nreverse regions)))))))) + (tp--pattern-apply-single pattern properties apply-fn object t)) (defun tp--match-apply (pattern properties apply-fn &optional object) "Internal function to apply APPLY-FN to matches of PATTERN. @@ -67,61 +116,14 @@ When PATTERN is a list, each element is a pattern to match. APPLY-FN is called with (START END PROPS OBJECT) for each match. For strings, returns a NEW string with properties applied (non-destructive). For buffers, returns list of regions." - (let ((patterns (if (listp pattern) pattern (list pattern)))) - (cond - ;; String object - ((stringp object) - (let ((result object)) - (dolist (p patterns) - (setq result (tp--match-apply-single p properties apply-fn result))) - result)) - ;; Buffer or nil (current buffer) - (t - (let ((all-regions nil)) - (dolist (p patterns) - (let ((regions (tp--match-apply-single p properties apply-fn object))) - (setq all-regions (append all-regions regions)))) - all-regions))))) + (tp--pattern-apply pattern properties apply-fn object t)) (defun tp--regexp-apply-single (pattern properties apply-fn object) "Apply APPLY-FN to regexp matches of single PATTERN in OBJECT. APPLY-FN is called with (START END PROPS OBJECT) for each match. For strings, returns a NEW string with properties applied (non-destructive). For buffers, modifies in-place and returns list of regions." - (cond - ;; String object - ((stringp object) - ;; First, collect all match positions from the original string - (let ((matches nil) - (pos 0)) - (while (string-match pattern object pos) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (push (cons beg end) matches) - (setq pos (if (= beg end) (1+ beg) end)))) - ;; Apply function to each match in order (reverse to get correct order) - ;; Make a copy to ensure original string is not modified - (let ((result (copy-sequence object))) - (dolist (match (nreverse matches)) - (when properties - (setq result (funcall apply-fn - (car match) (cdr match) - properties result)))) - result))) - ;; Buffer or nil (current buffer) - (t - (let ((buf (or object (current-buffer)))) - (tp-with-current-buffer buf - (save-excursion - (goto-char (point-min)) - (let (regions) - (while (re-search-forward pattern nil t) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (when properties - (funcall apply-fn beg end properties buf)) - (push (cons beg end) regions))) - (nreverse regions)))))))) + (tp--pattern-apply-single pattern properties apply-fn object nil)) (defun tp--regexp-apply (pattern properties apply-fn &optional object) "Internal function to apply APPLY-FN to regexp matches of PATTERN. @@ -130,21 +132,7 @@ When PATTERN is a list, each element is a regexp to match. APPLY-FN is called with (START END PROPS OBJECT) for each match. For strings, returns a NEW string with properties applied (non-destructive). For buffers, returns list of regions." - (let ((patterns (if (listp pattern) pattern (list pattern)))) - (cond - ;; String object - ((stringp object) - (let ((result object)) - (dolist (p patterns) - (setq result (tp--regexp-apply-single p properties apply-fn result))) - result)) - ;; Buffer or nil (current buffer) - (t - (let ((all-regions nil)) - (dolist (p patterns) - (let ((regions (tp--regexp-apply-single p properties apply-fn object))) - (setq all-regions (append all-regions regions)))) - all-regions))))) + (tp--pattern-apply pattern properties apply-fn object nil)) (defun tp--deep-merge-apply (start end props obj) "Apply PROPS to OBJ from START to END with deep merge. @@ -163,6 +151,11 @@ For buffers, modifies in-place." do (let* ((current-val (plist-get current-props key)) (new-val (cond + ;; Face-family properties merge with the + ;; incoming face taking precedence, same as + ;; the string path (:add mode). + ((memq key tp-face-properties) + (tp--prepend-face val current-val)) ((and (listp val) (keywordp (car-safe val)) (listp current-val) (keywordp (car-safe current-val))) @@ -291,6 +284,40 @@ Wraps `text-property-search-forward'." Wraps `text-property-search-backward'." (text-property-search-backward property value predicate not-current)) +(defun tp--property-search-backward (property value) + "Search backward for the previous region where PROPERTY `equal's VALUE. + +This is the backward mirror of (text-property-search-forward PROPERTY +VALUE t): a region matches when its PROPERTY value is `equal' to +VALUE. It deliberately does not call +`text-property-search-backward' with predicate t, because that +primitive's non-default-predicate branch skips every other property +run when non-matching runs intervene (observed through Emacs 30.2), +silently missing valid matches. + +If a matching region is found, move point to its beginning and +return a `prop-match' object whose end is clipped to the starting +point (matching the primitive's behavior when point starts inside a +matching region). Otherwise return nil and leave point alone." + (if (bobp) + nil + (let ((origin (point)) + (found nil)) + ;; Walk PROPERTY runs before point; remember the last matching one. + ;; tp--map-intervals clips the run containing ORIGIN to end there. + (tp--map-intervals + (current-buffer) (point-min) origin + (lambda (ibeg iend val) + (when (equal value val) + (setq found (list ibeg iend val))) + nil) + property) + (when found + (goto-char (car found)) + (make-prop-match :beginning (car found) + :end (cadr found) + :value (caddr found)))))) + (defun tp-forward (property &optional value object n) "Search forward N times for text with PROPERTY. Returns prop-match for buffers or list of (START END VALUE) for strings." @@ -333,11 +360,15 @@ Uses `tp-search-backward' for buffers and `tp-search' for strings." (buf (or object (current-buffer)))) (tp-with-current-buffer buf (dotimes (_ count) - (setq result (tp-search-backward property value)))) + ;; `equal' matching, mirroring the predicate t that + ;; `tp-forward' passes. The previous code used the default + ;; nil predicate, which matches values NOT `equal' to VALUE + ;; and so inverted the match when VALUE was non-nil. + (setq result (tp--property-search-backward property value)))) result))))) (defun tp--forward-do (function property &optional value object times start end) - "Internal: Search forward TIMES for PROPERTY and apply FUNCTION to the last match. + "Internal: search forward TIMES for PROPERTY, call FUNCTION on last match. FUNCTION receives two arguments: the prop-match object (or list for strings) and OBJECT. @@ -379,6 +410,74 @@ Returns the number of successful matches." (cl-incf matches))))))) matches))))) +(defun tp--replace-match-text (function arity match obj &optional idx) + "Replace the text of MATCH in OBJ with the result of calling FUNCTION. + +MATCH is either a (START END VALUE) list (string matches) or a +prop-match struct (buffer matches). ARITY is the precomputed +\(func-arity FUNCTION); depending on it, FUNCTION is called with +\(TEXT), (TEXT START), (TEXT START END) or - when IDX is non-nil and +FUNCTION accepts a 4th argument - (TEXT START END IDX). + +If FUNCTION returns a string, it replaces the matched text: +- For string OBJ the replacement happens in place; since strings have + fixed length, a longer replacement is truncated to the match length + and a shorter one only replaces that portion. The replacement's + text properties (including their absence) are copied onto the + replaced portion. +- For buffer OBJ the match is replaced via `delete-region' + `insert' + \(the buffer may grow or shrink). +Any non-string return value leaves OBJ untouched." + (let* ((m-start (if (listp match) (car match) (prop-match-beginning match))) + (m-end (if (listp match) (cadr match) (prop-match-end match))) + (text (if (stringp obj) + (substring obj m-start m-end) + (buffer-substring m-start m-end))) + (max-arity (cdr arity)) + (can-accept-start (or (eq max-arity 'many) + (and (numberp max-arity) (>= max-arity 2)))) + (can-accept-end (or (eq max-arity 'many) + (and (numberp max-arity) (>= max-arity 3)))) + (can-accept-idx (and idx + (or (eq max-arity 'many) + (and (numberp max-arity) (>= max-arity 4))))) + (new-text (cond + (can-accept-idx (funcall function text m-start m-end idx)) + (can-accept-end (funcall function text m-start m-end)) + (can-accept-start (funcall function text m-start)) + (t (funcall function text))))) + (when (stringp new-text) + (if (stringp obj) + ;; For strings: copy text content and properties separately + (let ((len (min (length new-text) (- m-end m-start)))) + ;; Copy text content, truncated to the available room so a + ;; longer replacement cannot overflow the string (which + ;; would clobber text after the match or signal + ;; args-out-of-range). + (store-substring obj m-start + (if (> (length new-text) len) + (substring new-text 0 len) + new-text)) + ;; Copy properties from new-text to obj. Ranges with nil + ;; properties are copied too, so FUNCTION can REMOVE + ;; properties by returning a stripped string. + (let ((pos 0)) + (while (< pos len) + (let* ((props (text-properties-at pos new-text)) + (next-change (or (next-property-change pos new-text) + len))) + (set-text-properties (+ m-start pos) + (+ m-start (min next-change len)) + props + obj) + (setq pos next-change))))) + ;; For buffers, delete and insert + (unless (equal new-text text) + (save-excursion + (delete-region m-start m-end) + (goto-char m-start) + (insert new-text))))))) + (defun tp-forward-do (function property &optional value object times start end) "Search forward for text with PROPERTY and apply FUNCTION to the last match. @@ -418,47 +517,11 @@ Example: (let ((arity (func-arity function))) (tp--forward-do (lambda (match obj) - (let* ((m-start (if (listp match) (car match) (prop-match-beginning match))) - (m-end (if (listp match) (cadr match) (prop-match-end match))) - (text (if (stringp obj) - (substring obj m-start m-end) - (buffer-substring m-start m-end))) - (max-arity (cdr arity)) - (can-accept-start (or (eq max-arity 'many) - (and (numberp max-arity) (>= max-arity 2)))) - (can-accept-end (or (eq max-arity 'many) - (and (numberp max-arity) (>= max-arity 3)))) - (new-text (cond - (can-accept-end (funcall function text m-start m-end)) - (can-accept-start (funcall function text m-start)) - (t (funcall function text))))) - (when (stringp new-text) - (if (stringp obj) - ;; For strings: copy text content and properties separately - (let ((len (min (length new-text) (- m-end m-start)))) - ;; Copy text content - (store-substring obj m-start new-text) - ;; Copy properties from new-text to obj - (let ((pos 0)) - (while (< pos len) - (let* ((props (text-properties-at pos new-text)) - (next-change (or (next-property-change pos new-text) len))) - (when props - (set-text-properties (+ m-start pos) - (+ m-start (min next-change len)) - props - obj)) - (setq pos next-change))))) - ;; For buffers, delete and insert - (unless (equal new-text text) - (save-excursion - (delete-region m-start m-end) - (goto-char m-start) - (insert new-text))))))) + (tp--replace-match-text function arity match obj)) property value object times start end))) (defun tp--backward-do (function property &optional value object times start end) - "Internal: Search backward TIMES for PROPERTY and apply FUNCTION to the last match. + "Internal: search backward TIMES for PROPERTY, call FUNCTION on last match. FUNCTION receives two arguments: the prop-match object (or list for strings) and OBJECT. @@ -494,7 +557,8 @@ Returns the number of successful matches." (save-excursion (goto-char search-end) (dotimes (i count) - (when-let ((match (tp-search-backward property value))) + ;; `equal' matching, same as tp--forward-do's predicate t. + (when-let ((match (tp--property-search-backward property value))) (when (>= (prop-match-beginning match) search-start) (when (= i (1- count)) (funcall function match buf)) @@ -540,43 +604,7 @@ Example: (let ((arity (func-arity function))) (tp--backward-do (lambda (match obj) - (let* ((m-start (if (listp match) (car match) (prop-match-beginning match))) - (m-end (if (listp match) (cadr match) (prop-match-end match))) - (text (if (stringp obj) - (substring obj m-start m-end) - (buffer-substring m-start m-end))) - (max-arity (cdr arity)) - (can-accept-start (or (eq max-arity 'many) - (and (numberp max-arity) (>= max-arity 2)))) - (can-accept-end (or (eq max-arity 'many) - (and (numberp max-arity) (>= max-arity 3)))) - (new-text (cond - (can-accept-end (funcall function text m-start m-end)) - (can-accept-start (funcall function text m-start)) - (t (funcall function text))))) - (when (stringp new-text) - (if (stringp obj) - ;; For strings: copy text content and properties separately - (let ((len (min (length new-text) (- m-end m-start)))) - ;; Copy text content - (store-substring obj m-start new-text) - ;; Copy properties from new-text to obj - (let ((pos 0)) - (while (< pos len) - (let* ((props (text-properties-at pos new-text)) - (next-change (or (next-property-change pos new-text) len))) - (when props - (set-text-properties (+ m-start pos) - (+ m-start (min next-change len)) - props - obj)) - (setq pos next-change))))) - ;; For buffers, delete and insert - (unless (equal new-text text) - (save-excursion - (delete-region m-start m-end) - (goto-char m-start) - (insert new-text))))))) + (tp--replace-match-text function arity match obj)) property value object times start end))) (defun tp-search (start-or-string @@ -674,36 +702,59 @@ Each element contains the start position, end position, and property value." Signature: (tp--search-do FUNCTION PROPERTY &optional VALUE OBJECT START END) -FUNCTION receives two arguments: the prop-match (list of START END VALUE) and OBJECT. +FUNCTION receives two arguments: the match, as a (START END VALUE) +list, and OBJECT. PROPERTY is the text property to search for. -VALUE is the optional value to match; nil means search for PROPERTY without matching value. +VALUE is the optional value to match; nil means search for PROPERTY +without matching value. OBJECT can be a buffer or string; nil defaults to current buffer. START and END define the search range; defaults are object start and end. -Returns the number of matches processed." - (let* ((obj (or object (current-buffer))) - (all-matches (if (stringp obj) - (tp-search obj property value) - (let ((s (or start (point-min))) - (e (or end (point-max)))) - (tp-search s e property value obj)))) - (filtered-matches - (if (and (not (stringp obj)) start end) - (seq-filter (lambda (m) - (and (>= (car m) start) - (<= (cadr m) end))) - all-matches) - (if (stringp obj) - (let ((s (or start 0)) - (e (or end (length obj)))) - (seq-filter (lambda (m) - (and (>= (car m) s) - (<= (cadr m) e))) - all-matches)) - all-matches)))) - (dolist (match filtered-matches) - (funcall function match obj)) - (length filtered-matches))) +Returns the number of matches processed. + +For buffers, FUNCTION is called with OBJECT as the current buffer, and +the match positions handed to FUNCTION are tracked with markers, so +FUNCTION may safely change the length of earlier matches (e.g. replace +their text): later matches still receive their up-to-date positions." + (let ((obj (or object (current-buffer)))) + (if (stringp obj) + (let* ((all-matches (tp-search obj property value)) + (s (or start 0)) + (e (or end (length obj))) + (filtered-matches + (seq-filter (lambda (m) + (and (>= (car m) s) + (<= (cadr m) e))) + all-matches))) + (dolist (match filtered-matches) + (funcall function match obj)) + (length filtered-matches)) + ;; Buffer: do all the work with OBJ current, and track match + ;; positions with markers so length-changing edits made by + ;; FUNCTION on earlier matches don't invalidate later positions. + (tp-with-current-buffer obj + (let* ((s (or start (point-min))) + (e (or end (point-max))) + (matches (tp-search s e property value obj)) + (marked (mapcar (lambda (m) + ;; Begin markers advance on insertion at + ;; their position so adjacent runs stay + ;; correct after a replacement. + (list (copy-marker (car m) t) + (copy-marker (cadr m)) + (caddr m))) + matches))) + (unwind-protect + (dolist (m marked) + (funcall function + (list (marker-position (car m)) + (marker-position (cadr m)) + (caddr m)) + obj)) + (dolist (m marked) + (set-marker (car m) nil) + (set-marker (cadr m) nil))) + (length marked)))))) (defun tp-search-map (function property &optional value object start end) "Apply FUNCTION to all matches of PROPERTY in OBJECT. @@ -747,52 +798,12 @@ Example: ;; Search within a range (tp-search-map #\\='upcase \\='marker nil my-string 0 10)" - (let* ((obj (or object (current-buffer))) - (idx 0) - (arity (func-arity function))) + (let ((idx 0) + (arity (func-arity function))) (tp--search-do (lambda (match obj) - (let* ((m-start (car match)) - (m-end (cadr match)) - (text (if (stringp obj) - (substring obj m-start m-end) - (buffer-substring m-start m-end))) - (max-arity (cdr arity)) - (can-accept-start (or (eq max-arity 'many) - (and (numberp max-arity) (>= max-arity 2)))) - (can-accept-end (or (eq max-arity 'many) - (and (numberp max-arity) (>= max-arity 3)))) - (can-accept-idx (or (eq max-arity 'many) - (and (numberp max-arity) (>= max-arity 4)))) - (new-text (cond - (can-accept-idx (funcall function text m-start m-end idx)) - (can-accept-end (funcall function text m-start m-end)) - (can-accept-start (funcall function text m-start)) - (t (funcall function text))))) - (setq idx (1+ idx)) - (when (stringp new-text) - (if (stringp obj) - ;; For strings: copy text content and properties separately - (let ((len (min (length new-text) (- m-end m-start)))) - ;; Copy text content - (store-substring obj m-start new-text) - ;; Copy properties from new-text to obj - (let ((pos 0)) - (while (< pos len) - (let* ((props (text-properties-at pos new-text)) - (next-change (or (next-property-change pos new-text) len))) - (when props - (set-text-properties (+ m-start pos) - (+ m-start (min next-change len)) - props - obj)) - (setq pos next-change))))) - ;; For buffers, delete and insert - (unless (equal new-text text) - (save-excursion - (delete-region m-start m-end) - (goto-char m-start) - (insert new-text))))))) + (tp--replace-match-text function arity match obj idx) + (setq idx (1+ idx))) property value object start end))) (provide 'tp-search) diff --git a/tp-stack-tests.el b/tp-stack-tests.el new file mode 100644 index 0000000..33da75f --- /dev/null +++ b/tp-stack-tests.el @@ -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 diff --git a/tp-stack.el b/tp-stack.el index 52d7b91..6e32bf6 100644 --- a/tp-stack.el +++ b/tp-stack.el @@ -23,34 +23,194 @@ (require 'tp-layer) (require 'tp-ops) +;;; Shared argument parsing and region iteration + +(defun tp--parse-layer-args (start-or-string rest n) + "Normalize a layer operation's positional arguments. + +START-OR-STRING is the caller's first positional argument and REST the +list of its remaining positional arguments, in order. N is the number +of operation-specific arguments the caller takes (for example 2 for +`tp-put-layer's LAYER and IDX). + +Two calling conventions are supported: +- (STRING ARG1 ... ARGN): operate on the whole STRING. +- (START END ARG1 ... ARGN OBJECT): operate on a region of OBJECT, + where nil means the current buffer. + +Returns the list (START END OBJECT ARG1 ... ARGN) with START/END in +OBJECT's native coordinates (0-based for strings, 1-based for +buffers)." + (cond + ((stringp start-or-string) + (append (list 0 (length start-or-string) start-or-string) + (seq-take rest n))) + ((numberp start-or-string) + (append (list start-or-string (car rest) (nth (1+ n) rest)) + (seq-take (cdr rest) n))) + (t (error "Invalid layer arguments: %S" (cons start-or-string rest))))) + +(defun tp--stack-map-region (start end object function) + "Call FUNCTION over each property run of [START, END) in OBJECT. + +OBJECT is a string, a buffer, or nil for the current buffer. +FUNCTION receives (ABS-START ABS-END STACK): the run's bounds, clipped +to [START, END) and expressed in OBJECT's native coordinates (0-based +for strings, 1-based for buffers), and the run's layer stack as a list +of layer plists, top layer first (empty for bare text). + +Returns the list of FUNCTION's non-nil results, in order. + +Unlike `tp-intervals-map', runs never extend beyond the requested +region, positions are absolute for strings as well as buffers, and +bare text is visited (with an empty STACK) so layers can be applied to +previously property-less text." + (delq nil + (tp--map-intervals + object start end + (lambda (i-start i-end props) + (let* ((idx (-elem-index 'tp-layers props)) + (top (if idx + (-remove-at-indices (list idx (1+ idx)) props) + props)) + (belows (plist-get props 'tp-layers))) + (funcall function i-start i-end + (tp--layer-stack-to-list top belows))))))) + +(defun tp--stack-build-props (layer-list) + "Build text properties from LAYER-LIST (top layer first). +Like `tp--build-layer-props', but the `tp-layers' entry is only added +when there are below-layers, so single-layer stacks do not carry a +garbage (tp-layers nil) property. Consumers must therefore tolerate +an absent `tp-layers' property (both `plist-get' and +`tp--stack-map-region' do)." + (cond + ((null layer-list) nil) + ((null (cdr layer-list)) (copy-sequence (car layer-list))) + (t (append (car layer-list) + (list 'tp-layers (cdr layer-list)))))) + +;;; Queries + (defun tp-region-layer-props (start end layer-name &optional object) "Return layer properties for LAYER-NAME in region from START to END. OBJECT defaults to current buffer. -Returns a list of (START END PROPERTIES) for matching intervals." - (tp-intervals-map - (lambda (i-start i-end top belows) +Returns a list of (START END PROPERTIES) for matching intervals, with +positions in OBJECT's native coordinates (0-based for strings, 1-based +for buffers) and clipped to the requested region." + (tp--stack-map-region + start end object + (lambda (abs-start abs-end stack) (when-let ((props (seq-find (lambda (props) (equal layer-name (plist-get props 'tp-name))) - (append (list top) belows)))) - (list (+ start i-start) (+ start i-end) props))) - start end object)) + stack))) + (list abs-start abs-end props))))) -(defun tp--parse-layer-args (args) - "Parse flexible layer function arguments. -Returns (START END LAYER-SPEC IDX OBJECT) for buffer/string range, -or (STRING LAYER-SPEC IDX nil nil) for entire string." +(defun tp-layer-list (start end &optional object) + "Return list of all layer names in region from START to END." + (let ((layers nil)) + (tp--stack-map-region + start end object + (lambda (_abs-start _abs-end stack) + (dolist (layer stack) + (when-let ((name (plist-get layer 'tp-name))) + (cl-pushnew name layers :test #'equal))))) + (nreverse layers))) + +(defun tp-layer-count (start end &optional object) + "Return number of layers in region from START to END. +OBJECT defaults to current buffer." + (let ((max-count 0)) + (tp--stack-map-region + start end object + (lambda (_abs-start _abs-end stack) + (setq max-count (max max-count (length stack))))) + max-count)) + +(defun tp-layer-exists-p (start end name &optional object) + "Return t if layer NAME exists in region from START to END. +OBJECT defaults to current buffer." + (not (null (tp-region-layer-props start end name object)))) + +(defun tp-layer-top (start end &optional object) + "Return the name of the topmost named layer in START..END of OBJECT. +Scans the region's property runs in order and returns the `tp-name' +of the first top layer that has one, so bare or unnamed runs (for +example before a layer that starts mid-region) do not hide layers +later in the region. Returns nil when no run in the region has a +named top layer. OBJECT defaults to current buffer." + (car (tp--stack-map-region + start end object + (lambda (_abs-start _abs-end stack) + (plist-get (car stack) 'tp-name))))) + +;;; Layer spec normalization for tp-put-layer + +(defun tp--put-layer-specs (layer-spec) + "Normalize LAYER-SPEC into a list of layer plists for `tp-put-layer'. + +LAYER-SPEC can be: +- a layer name or group name (symbol); +- (LAYER-NAME ARG) or (GROUP-NAME ARG) for parameterized layers/groups; +- an inline plist, e.g. (face bold) or (:foreground \"red\"); +- (NAME PROP VAL ...) for a named inline layer; +- a list of any of the above. + +An inline plist is recognized by its even length together with a head +that is a keyword or an ordinary property symbol (one that is not a +defined layer or group name); a named inline layer has odd length +\(NAME plus prop/value pairs)." (cond - ;; First arg is a string - apply to entire string - ;; (tp-put-layer string layer idx) - ((stringp (car args)) - (list (car args) (cadr args) (caddr args) nil nil)) - ;; First arg is a number - buffer/string region - ;; (tp-put-layer start end layer idx object) - ((numberp (car args)) - (list (car args) (cadr args) (caddr args) (cadddr args) (nth 4 args))) - (t (error "Invalid arguments: %S" args)))) + ;; Group name symbol. + ((and (symbolp layer-spec) + (assoc layer-spec tp-layer-groups)) + (if (tp-group-parameterized-p layer-spec) + (error "Parameterized group %S requires an argument, use '(%S ARG)" + layer-spec layer-spec) + (tp-group-props layer-spec t))) ; include tp-name for layer stack + ;; Any other symbol: a single layer name. + ((symbolp layer-spec) + (list (tp--normalize-layer-spec layer-spec))) + ;; (GROUP-NAME ARG): parameterized group. + ((and (consp layer-spec) + (symbolp (car layer-spec)) + (= (safe-length layer-spec) 2) + (tp-group-parameterized-p (car layer-spec))) + (tp-group-props-with-arg (car layer-spec) (cadr layer-spec) t)) + ;; (LAYER-NAME ARG): parameterized layer. + ((and (consp layer-spec) + (symbolp (car layer-spec)) + (= (safe-length layer-spec) 2) + (tp-layer-parameterized-p (car layer-spec))) + (list (tp--normalize-layer-spec layer-spec))) + ;; Keyword-headed plist: a single inline layer. + ((and (consp layer-spec) (keywordp (car layer-spec))) + (list (tp--normalize-layer-spec layer-spec))) + ;; Even-length plist headed by an ordinary (non-layer) property + ;; symbol, e.g. (face bold): a single inline layer. + ((and (consp layer-spec) + (car layer-spec) + (symbolp (car layer-spec)) + (not (tp--is-layer-name-p (car layer-spec))) + (proper-list-p layer-spec) + (cl-evenp (length layer-spec))) + (list layer-spec)) + ;; List whose every element is itself a spec (a layer/group name or + ;; a list): multiple layers. + ((and (consp layer-spec) + (proper-list-p layer-spec) + (cl-every (lambda (el) + (or (consp el) (tp--is-layer-name-p el))) + layer-spec)) + (apply #'append (mapcar #'tp--put-layer-specs layer-spec))) + ;; Anything else, including (NAME PROP VAL ...) named inline + ;; layers; tp--normalize-layer-spec signals on invalid specs. + (t + (list (tp--normalize-layer-spec layer-spec))))) + +;;; Mutators (defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object) "Set layer(s) at a specific index position. @@ -58,13 +218,15 @@ or (STRING LAYER-SPEC IDX nil nil) for entire string." Calling conventions: 1. Buffer/string region: (tp-put-layer START END LAYER IDX OBJECT) - + 2. Entire string: (tp-put-layer STRING LAYER IDX) LAYER can be: -- A symbol (layer name from tp-layer-alist or tp-layer-groups) -- A plist (inline layer definition) +- A symbol (layer name from `tp-layer-alist' or `tp-layer-groups') +- A list (LAYER-NAME ARG) or (GROUP-NAME ARG) for parameterized + layers or groups +- A plist (inline layer definition), e.g. (face bold) - A list (NAME &rest PLIST) for named inline layer - A list of the above for multiple layers @@ -73,68 +235,26 @@ IDX specifies where to insert: - -1 means bottom - Other values insert at that position -OBJECT defaults to current buffer for region form." - (let (start end layer-spec idx obj) - (cond - ;; Entire string form: (tp-put-layer string layer idx) - ((stringp start-or-string) - (setq obj start-or-string - start 0 - end (length start-or-string) - layer-spec end-or-layer - idx (or layer-or-idx 0))) - ;; Region form: (tp-put-layer start end layer idx object) - ((numberp start-or-string) - (setq start start-or-string - end end-or-layer - layer-spec layer-or-idx - idx (or idx-or-object 0) - obj object))) - - ;; Normalize layer-spec to a list of layer property lists - (let ((layers-to-add - (cond - ;; Check if it's a group name - ((and (symbolp layer-spec) - (assoc layer-spec tp-layer-groups)) - (tp-group-props layer-spec t)) ; include tp-name for layer stack - ;; Single layer spec - ((or (symbolp layer-spec) - (and (listp layer-spec) - (or (keywordp (car layer-spec)) - (and (symbolp (car layer-spec)) - (cdr layer-spec) - (not (listp (cadr layer-spec))))))) - (list (tp--normalize-layer-spec layer-spec))) - ;; List of layer specs (multiple layers) - ((and (listp layer-spec) - (listp (car layer-spec))) - (mapcar #'tp--normalize-layer-spec layer-spec)) - (t (list (tp--normalize-layer-spec layer-spec)))))) - - ;; Apply layers at specified index - (if (tp-empty-p (or obj (current-buffer))) - ;; No existing properties - (set-text-properties start end - (tp--build-layer-props layers-to-add) - obj) - ;; Has existing properties - (tp-intervals-map - (lambda (i-start i-end top belows) - (let* ((current-stack (tp--layer-stack-to-list top belows)) - (actual-idx (cond - ((= idx 0) 0) - ((< idx 0) (max 0 (+ (length current-stack) 1 idx))) - (t (min idx (length current-stack))))) - ;; Insert new layers at the specified position - (new-stack (append (seq-take current-stack actual-idx) - layers-to-add - (seq-drop current-stack actual-idx)))) - (set-text-properties - (+ start i-start) (+ start i-end) - (tp--build-layer-props new-stack) - obj))) - start end obj))) +OBJECT defaults to current buffer for region form. Only text inside +\[START, END) is modified." + (pcase-let ((`(,start ,end ,obj ,layer-spec ,idx) + (tp--parse-layer-args + start-or-string + (list end-or-layer layer-or-idx idx-or-object object) 2))) + (setq idx (or idx 0)) + (let ((layers-to-add (tp--put-layer-specs layer-spec))) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (let* ((actual-idx (if (< idx 0) + (max 0 (+ (length stack) 1 idx)) + (min idx (length stack)))) + (new-stack (append (seq-take stack actual-idx) + layers-to-add + (seq-drop stack actual-idx)))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj))))) (or obj (cons start end)))) (defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object) @@ -145,14 +265,14 @@ This is equivalent to (tp-put-layer ... LAYER 0 ...). Calling conventions: 1. Buffer/string region: (tp-push-layer START END LAYER OBJECT) - + 2. Entire string: (tp-push-layer STRING LAYER)" - (cond - ((stringp start-or-string) - (tp-put-layer start-or-string end-or-layer 0)) - ((numberp start-or-string) - (tp-put-layer start-or-string end-or-layer layer-or-object 0 object)))) + (pcase-let ((`(,start ,end ,obj ,layer) + (tp--parse-layer-args + start-or-string + (list end-or-layer layer-or-object object) 1))) + (tp-put-layer start end layer 0 obj))) (defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object) "Delete layer by name or index. @@ -160,37 +280,27 @@ Calling conventions: Calling conventions: 1. Buffer/string region: (tp-delete-layer START END LAYER-NAME/IDX OBJECT) - + 2. Entire string: (tp-delete-layer STRING LAYER-NAME/IDX) LAYER-NAME/IDX can be: - A symbol (layer name) -- An integer (layer index, 0=top, -1=bottom)" - (let (start end layer-id obj) - (cond - ((stringp start-or-string) - (setq obj start-or-string - start 0 - end (length start-or-string) - layer-id end-or-idx)) - ((numberp start-or-string) - (setq start start-or-string - end end-or-idx - layer-id idx-or-object - obj object))) - - (tp-intervals-map - (lambda (i-start i-end top belows) - (let* ((current-stack (tp--layer-stack-to-list top belows)) - (found (tp--get-layer-by-idx-or-name current-stack layer-id))) - (when found - (let ((new-stack (-remove-at (car found) current-stack))) - (set-text-properties - (+ start i-start) (+ start i-end) - (tp--build-layer-props new-stack) - obj))))) - start end obj) +- An integer (layer index, 0=top, -1=bottom) + +Only text inside [START, END) is modified." + (pcase-let ((`(,start ,end ,obj ,layer-id) + (tp--parse-layer-args + start-or-string + (list end-or-idx idx-or-object object) 1))) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((found (tp--get-layer-by-idx-or-name stack layer-id))) + (set-text-properties + abs-start abs-end + (tp--stack-build-props (-remove-at (car found) stack)) + obj)))) nil)) (defun tp-pop-layer (start-or-string &optional end-or-object object) @@ -201,20 +311,20 @@ This is equivalent to (tp-delete-layer ... 0 ...). Calling conventions: 1. Buffer/string region: (tp-pop-layer START END OBJECT) - + 2. Entire string: (tp-pop-layer STRING)" - (cond - ((stringp start-or-string) - (tp-delete-layer start-or-string 0)) - ((numberp start-or-string) - (tp-delete-layer start-or-string end-or-object 0 object)))) + (pcase-let ((`(,start ,end ,obj) + (tp--parse-layer-args + start-or-string (list end-or-object object) 0))) + (tp-delete-layer start end 0 obj))) (defun tp--move-layer-in-stack (stack from-id to-idx) "Move layer at FROM-ID to TO-IDX position in STACK. FROM-ID can be an integer index or a layer name symbol. TO-IDX must be an integer index. -Both indices refer to positions before the move and can be negative (counting from end). +Both indices refer to positions before the move and can be negative +\(counting from end). TO-IDX is clamped to valid range (0 to stack length - 1) if out of bounds. Returns the new stack, or nil if FROM-ID is invalid." (let* ((len (length stack)) @@ -289,33 +399,17 @@ TO-IDX is the target position (integer index): Both indices refer to positions before the move. The layer at FROM-ID is removed and inserted at TO-IDX position. OBJECT defaults to current buffer for region form." - (let (start end from-id to-idx obj) - (cond - ;; Entire string form: (tp-move-layer string from-id to-idx) - ((stringp start-or-string) - (setq obj start-or-string - start 0 - end (length start-or-string) - from-id end-or-from - to-idx from-or-to)) - ;; Region form: (tp-move-layer start end from-id to-idx object) - ((numberp start-or-string) - (setq start start-or-string - end end-or-from - from-id from-or-to - to-idx to-or-object - obj object))) - - (tp-intervals-map - (lambda (i-start i-end top belows) - (let* ((current-stack (tp--layer-stack-to-list top belows)) - (new-stack (tp--move-layer-in-stack current-stack from-id to-idx))) - (when new-stack - (set-text-properties - (+ start i-start) (+ start i-end) - (tp--build-layer-props new-stack) - obj)))) - start end obj) + (pcase-let ((`(,start ,end ,obj ,from-id ,to-idx) + (tp--parse-layer-args + start-or-string + (list end-or-from from-or-to to-or-object object) 2))) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj)))) nil)) (defun tp-raise-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object) @@ -324,39 +418,27 @@ OBJECT defaults to current buffer for region form." Calling conventions: 1. Buffer/string region: (tp-raise-layer START END IDX/LAYER-NAME N OBJECT) - + 2. Entire string: (tp-raise-layer STRING IDX/LAYER-NAME N) Positive N moves the layer up (toward top/visible). Negative N moves the layer down (toward bottom). -Uses `tp--raise-layer-in-stack' internally, which is built on `tp--move-layer-in-stack'." - (let (start end layer-id n obj) - (cond - ((stringp start-or-string) - (setq obj start-or-string - start 0 - end (length start-or-string) - layer-id end-or-idx - n (or idx-or-n 1))) - ((numberp start-or-string) - (setq start start-or-string - end end-or-idx - layer-id idx-or-n - n (or n-or-object 1) - obj object))) - - (tp-intervals-map - (lambda (i-start i-end top belows) - (let* ((current-stack (tp--layer-stack-to-list top belows)) - (new-stack (tp--raise-layer-in-stack current-stack layer-id n))) - (when new-stack - (set-text-properties - (+ start i-start) (+ start i-end) - (tp--build-layer-props new-stack) - obj)))) - start end obj) +Uses `tp--raise-layer-in-stack' internally, which is built on +`tp--move-layer-in-stack'." + (pcase-let ((`(,start ,end ,obj ,layer-id ,n) + (tp--parse-layer-args + start-or-string + (list end-or-idx idx-or-n n-or-object object) 2))) + (setq n (or n 1)) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj)))) nil)) (defun tp-rotate-layer (start-or-string &optional end-or-object object) @@ -365,16 +447,15 @@ Uses `tp--raise-layer-in-stack' internally, which is built on `tp--move-layer-in Calling conventions: 1. Buffer/string region: (tp-rotate-layer START END OBJECT) - + 2. Entire string: (tp-rotate-layer STRING) Uses `tp-move-layer' internally to move layer at index 0 to index -1." - (cond - ((stringp start-or-string) - (tp-move-layer start-or-string 0 -1)) - ((numberp start-or-string) - (tp-move-layer start-or-string end-or-object 0 -1 object)))) + (pcase-let ((`(,start ,end ,obj) + (tp--parse-layer-args + start-or-string (list end-or-object object) 0))) + (tp-move-layer start end 0 -1 obj))) (defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object) "Pin a layer to the top (make it visible). @@ -382,16 +463,16 @@ Uses `tp-move-layer' internally to move layer at index 0 to index -1." Calling conventions: 1. Buffer/string region: (tp-pin-layer START END IDX/LAYER-NAME OBJECT) - + 2. Entire string: (tp-pin-layer STRING IDX/LAYER-NAME) Uses `tp-move-layer' internally to move the specified layer to index 0 (top)." - (cond - ((stringp start-or-string) - (tp-move-layer start-or-string end-or-idx 0)) - ((numberp start-or-string) - (tp-move-layer start-or-string end-or-idx idx-or-object 0 object)))) + (pcase-let ((`(,start ,end ,obj ,layer-id) + (tp--parse-layer-args + start-or-string + (list end-or-idx idx-or-object object) 1))) + (tp-move-layer start end layer-id 0 obj))) (defun tp-switch-layer (start-or-string &optional end-or-id1 id1-or-id2 id2-or-object object) "Switch between two layers by name or index. @@ -399,96 +480,81 @@ Uses `tp-move-layer' internally to move the specified layer to index 0 (top)." Calling conventions: 1. Buffer/string region: (tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT) - + 2. Entire string: (tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2) Uses `tp--switch-layers-in-stack' internally." - (let (start end id1 id2 obj) - (cond - ((stringp start-or-string) - (setq obj start-or-string - start 0 - end (length start-or-string) - id1 end-or-id1 - id2 id1-or-id2)) - ((numberp start-or-string) - (setq start start-or-string - end end-or-id1 - id1 id1-or-id2 - id2 id2-or-object - obj object))) - - (tp-intervals-map - (lambda (i-start i-end top belows) - (let* ((current-stack (tp--layer-stack-to-list top belows)) - (new-stack (tp--switch-layers-in-stack current-stack id1 id2))) - (when new-stack - (set-text-properties - (+ start i-start) (+ start i-end) - (tp--build-layer-props new-stack) - obj)))) - start end obj) + (pcase-let ((`(,start ,end ,obj ,id1 ,id2) + (tp--parse-layer-args + start-or-string + (list end-or-id1 id1-or-id2 id2-or-object object) 2))) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj)))) nil)) +(defun tp--merge-layer-props (layers initial) + "Merge the plists of LAYERS into the INITIAL plist and return it. +LAYERS is a list of (INDEX . PROPS) conses as returned by +`tp--get-layer-by-idx-or-name'. Earlier layers take precedence: a key +already present in the accumulator is never overwritten, and presence +is tested with `plist-member' so an explicit nil value in a higher +layer shadows lower layers' values. `tp-name' keys of the merged +layers are dropped (INITIAL may seed its own)." + (cl-reduce (lambda (acc layer) + (cl-loop for (key val) on (cdr layer) by #'cddr + unless (eq key 'tp-name) + do (unless (plist-member acc key) + (setq acc (plist-put acc key val)))) + acc) + layers + :initial-value initial)) + (defun tp-merge-layers (start-or-string &optional end-or-name name-or-ids ids-or-object object) "Merge specified layers into a new layer. Calling conventions: 1. Buffer/string region: - (tp-merge-layers START END NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...) OBJECT) - + (tp-merge-layers START END NEW-LAYER-NAME + \\='(IDX1 LAYER-NAME1 IDX2 ...) OBJECT) + 2. Entire string: - (tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...))" - (let (start end new-name layer-ids obj) - (cond - ((stringp start-or-string) - (setq obj start-or-string - start 0 - end (length start-or-string) - new-name end-or-name - layer-ids name-or-ids)) - ((numberp start-or-string) - (setq start start-or-string - end end-or-name - new-name name-or-ids - layer-ids ids-or-object - obj object))) - - (tp-intervals-map - (lambda (i-start i-end top belows) - (let* ((current-stack (tp--layer-stack-to-list top belows)) - ;; Find all layers to merge - (layers-to-merge + (tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...)) + +Earlier layers in the list take precedence; a property explicitly set +to nil in a higher-precedence layer stays nil in the merged layer." + (pcase-let ((`(,start ,end ,obj ,new-name ,layer-ids) + (tp--parse-layer-args + start-or-string + (list end-or-name name-or-ids ids-or-object object) 2))) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (let* ((layers-to-merge (cl-loop for id in layer-ids - for found = (tp--get-layer-by-idx-or-name current-stack id) + for found = (tp--get-layer-by-idx-or-name stack id) when found collect found)) ;; Sort by index (descending) to remove from end first (sorted-layers (sort (copy-sequence layers-to-merge) (lambda (a b) (> (car a) (car b)))))) (when layers-to-merge ;; Merge properties (earlier in list takes precedence) - (let* ((merged-props - (cl-reduce (lambda (acc layer) - (let ((props (cdr layer))) - (cl-loop for (key val) on props by #'cddr - do (unless (plist-get acc key) - (setq acc (plist-put acc key val)))) - acc)) - layers-to-merge - :initial-value (list 'tp-name new-name))) - ;; Remove old layers from stack - (indices-to-remove (mapcar #'car sorted-layers)) - (new-stack current-stack)) - (dolist (idx indices-to-remove) + (let ((merged-props (tp--merge-layer-props + layers-to-merge (list 'tp-name new-name))) + (new-stack stack)) + ;; Remove old layers from stack + (dolist (idx (mapcar #'car sorted-layers)) (setq new-stack (-remove-at idx new-stack))) ;; Add merged layer at top (setq new-stack (cons merged-props new-stack)) - (set-text-properties - (+ start i-start) (+ start i-end) - (tp--build-layer-props new-stack) - obj))))) - start end obj) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj)))))) nil)) (defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object) @@ -497,90 +563,29 @@ Calling conventions: Calling conventions: 1. Buffer/string region: (tp-flatten-layers START END NAME OBJECT) - + 2. Entire string: (tp-flatten-layers STRING NAME) -NAME can be nil for an unnamed layer." - (let (start end name obj) - (cond - ((stringp start-or-string) - (setq obj start-or-string - start 0 - end (length start-or-string) - name end-or-name)) - ((numberp start-or-string) - (setq start start-or-string - end end-or-name - name name-or-object - obj object))) - - (tp-intervals-map - (lambda (i-start i-end top belows) - (let* ((current-stack (tp--layer-stack-to-list top belows)) - (layer-count (length current-stack))) - (when (> layer-count 0) - ;; Create list of all indices - (let ((all-ids (cl-loop for i from 0 below layer-count collect i))) - ;; Use merge with all layers - (let* ((layers-to-merge - (cl-loop for id in all-ids - for found = (tp--get-layer-by-idx-or-name - current-stack id) - when found collect found)) - (merged-props - (cl-reduce (lambda (acc layer) - (let ((props (cdr layer))) - (cl-loop for (key val) on props by #'cddr - unless (eq key 'tp-name) - do (unless (plist-get acc key) - (setq acc (plist-put acc key val)))) - acc)) - layers-to-merge - :initial-value (if name (list 'tp-name name) nil)))) - (set-text-properties - (+ start i-start) (+ start i-end) - merged-props - obj)))))) - start end obj) +NAME can be nil for an unnamed layer. Higher layers take precedence; +a property explicitly set to nil in a higher layer stays nil in the +flattened result." + (pcase-let ((`(,start ,end ,obj ,name) + (tp--parse-layer-args + start-or-string + (list end-or-name name-or-object object) 1))) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (when stack + (let ((merged-props (tp--merge-layer-props + (cl-loop for layer in stack + for i from 0 + collect (cons i layer)) + (when name (list 'tp-name name))))) + (set-text-properties abs-start abs-end merged-props obj))))) nil)) -(defun tp-layer-list (start end &optional object) - "Return list of all layer names in region from START to END." - (let ((layers nil)) - (tp-intervals-map - (lambda (_i-start _i-end top belows) - (when-let ((name (plist-get top 'tp-name))) - (cl-pushnew name layers :test #'equal)) - (dolist (below belows) - (when-let ((name (plist-get below 'tp-name))) - (cl-pushnew name layers :test #'equal)))) - start end object) - (nreverse layers))) - -(defun tp-layer-count (start end &optional object) - "Return number of layers in region from START to END. -OBJECT defaults to current buffer." - (let ((max-count 0)) - (tp-intervals-map - (lambda (_i-start _i-end top belows) - (let ((count (+ (if top 1 0) (length belows)))) - (when (> count max-count) - (setq max-count count)))) - start end object) - max-count)) - -(defun tp-layer-exists-p (start end name &optional object) - "Return t if layer NAME exists in region from START to END. -OBJECT defaults to current buffer." - (not (null (tp-region-layer-props start end name object)))) - -(defun tp-layer-top (start end &optional object) - "Return the name of the top layer at START in OBJECT. -OBJECT defaults to current buffer." - (when-let ((intervals (tp-intervals start end object))) - (plist-get (nth 2 (car intervals)) 'tp-name))) - (defun tp-add-to-layers (idx-or-layer-name-list start-or-string &optional end-or-plist plist-or-object &rest rest) "Add/merge properties to specified layers. @@ -612,7 +617,9 @@ Returns the modified object (string) or nil for buffer operations." (setq start start-or-string end end-or-plist plist plist-or-object - obj (car rest)))) + obj (car rest))) + (t (error "Invalid layer arguments: %S" + (cons start-or-string (list end-or-plist plist-or-object))))) ;; Handle plist wrapped in a list (from region form) (when (and (listp plist) @@ -621,28 +628,27 @@ Returns the modified object (string) or nil for buffer operations." (setq plist (car plist))) ;; Process each interval - (tp-intervals-map - (lambda (i-start i-end top belows) - (let* ((current-stack (tp--layer-stack-to-list top belows)) - (modified-stack - (cl-loop for layer in current-stack - for i from 0 - collect - (if (cl-some - (lambda (id) - (let ((found (tp--get-layer-by-idx-or-name - current-stack id))) - (and found (= (car found) i)))) - layer-ids) - ;; Merge plist into this layer - (tp--deep-merge-plist layer plist) - ;; Keep layer unchanged - layer)))) - (set-text-properties - (+ start i-start) (+ start i-end) - (tp--build-layer-props modified-stack) - obj))) - start end obj) + (tp--stack-map-region + start end obj + (lambda (abs-start abs-end stack) + (let ((modified-stack + (cl-loop for layer in stack + for i from 0 + collect + (if (cl-some + (lambda (id) + (let ((found (tp--get-layer-by-idx-or-name + stack id))) + (and found (= (car found) i)))) + layer-ids) + ;; Merge plist into this layer + (tp--deep-merge-plist layer plist) + ;; Keep layer unchanged + layer)))) + (when stack + (set-text-properties abs-start abs-end + (tp--stack-build-props modified-stack) + obj))))) (if (stringp obj) obj nil))) (defun tp-add-to-all-layers (start-or-string &optional end-or-plist plist-or-object &rest rest) @@ -682,7 +688,9 @@ Returns the modified object (string) or nil for buffer operations." (setq start start-or-string end end-or-plist plist plist-or-object - obj (car rest)))) + obj (car rest))) + (t (error "Invalid layer arguments: %S" + (cons start-or-string (list end-or-plist plist-or-object))))) ;; Handle plist wrapped in a list (from region form) (when (and (listp plist) diff --git a/tp-tests.el b/tp-tests.el index 980b8d4..da2e23c 100644 --- a/tp-tests.el +++ b/tp-tests.el @@ -680,9 +680,16 @@ leak between tests regardless of how BODY exits." (insert "Hello World") (tp-set 1 6 '(face bold)) (goto-char 12) + ;; Explicit VALUE finds the previous region carrying that value. + (let ((match (tp-backward 'face 'bold))) + (should match) + (should (= (prop-match-beginning match) 1))) + ;; VALUE nil equal-matches the property-absent region, mirroring + ;; tp-forward (see tp-test-forward). + (goto-char 12) (let ((match (tp-backward 'face))) (should match) - (should (= (prop-match-beginning match) 1))))) + (should (= (prop-match-beginning match) 6))))) (ert-deftest tp-test-backward-on-string () "Test tp-backward works on string objects."