From 972b6d4e4c31f65607f671f49cf4c8d4b5ee29fb Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Tue, 28 Jul 2026 22:42:55 +0800 Subject: [PATCH] Complete text-property facade and managed lifecycle Add canonical query semantics, managed metadata and transactions, overlay-aware lookup, reproducible benchmarks, and synchronized API documentation. --- CHANGELOG.md | 77 + Makefile | 10 +- README.md | 273 ++- README_CN.md | 268 ++- docs/API-SEMANTICS.md | 171 ++ docs/ARCHITECTURE.md | 104 +- docs/BENCHMARKS.md | 42 + docs/CODE-ANALYSIS.md | 3 + docs/REPOSITORY-AUDIT.md | 1897 +++++++++++++++++ docs/reactive-text-properties-en.md | 3 +- docs/reactive-text-properties.md | 2 +- .../2026-07-28-api-semantics-phase-1.md | 66 + ...026-07-28-complete-text-property-facade.md | 69 + tp-benchmark.el | 217 ++ tp-builtins.el | 43 + tp-char-tests.el | 136 ++ tp-core-tests.el | 65 + tp-core.el | 112 +- tp-doctest.el | 66 +- tp-layer-tests.el | 27 +- tp-layer.el | 286 ++- tp-managed-tests.el | 303 +++ tp-native-tests.el | 210 ++ tp-ops-tests.el | 49 + tp-ops.el | 452 ++-- tp-palette.el | 40 + tp-query.el | 179 ++ tp-reactive.el | 45 +- tp-render-tests.el | 171 +- tp-render.el | 306 ++- tp-search-tests.el | 113 +- tp-search.el | 509 +++-- tp-stack-tests.el | 70 +- tp-stack.el | 425 +++- tp-tests.el | 60 +- tp.el | 2 + 36 files changed, 6041 insertions(+), 830 deletions(-) create mode 100644 docs/API-SEMANTICS.md create mode 100644 docs/BENCHMARKS.md create mode 100644 docs/REPOSITORY-AUDIT.md create mode 100644 postmortem/2026-07-28-api-semantics-phase-1.md create mode 100644 postmortem/2026-07-28-complete-text-property-facade.md create mode 100644 tp-benchmark.el create mode 100644 tp-char-tests.el create mode 100644 tp-managed-tests.el create mode 100644 tp-native-tests.el create mode 100644 tp-query.el diff --git a/CHANGELOG.md b/CHANGELOG.md index c9ce2ac..8aa92e4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,83 @@ All notable changes to the tp library are documented here. +## Unreleased + +### Added + +- Internal Stage 2 canonical façade records and dataflow: + `tp--native-range`, `tp--presence`, `tp--request`, `tp--match`, + and `tp--result`. Public entry points and historical return shapes + remain compatible. +- Stage 3 text-only native façade in `tp-query.el`: + `tp-lookup-result`, `tp-lookup`, `tp-property-change`, + `tp-property-any`, `tp-property-not-all`, and + `tp-with-mutation-policy`. +- Stage 4 managed lifecycle APIs: `tp-attach-managed-layers`, + `tp-detach-managed-layers`, `tp-managed-layer-diagnostics`, + `tp-managed-buffer-diagnostics`, `tp-managed-diagnostics`, and + `tp-layer-transaction`. +- Stage 5 overlay-aware lookup modes for `tp-lookup`: `:char` and + `:char-source` report Emacs character-property values and the + winning overlay identity when an overlay wins. +- `docs/API-SEMANTICS.md` centralizes the current object/coordinate, + mutation, presence/nil, search-result, layer-ownership, `tp-text`, + error, and hidden-stack conflict contracts. +- `tp-any-value`, a unique public sentinel for property-search wildcard + matching when later positional arguments also need to be supplied. +- `tp-unresolved-layer` and `tp-layer-conflict` error types. +- `tp-reactive-observer-errors`, a newest-first structured record of + isolated watcher callback failures. + +### Fixed + +- Initial `tp-text` rendering now preserves every embedded property + interval for strings and buffers instead of spreading position-zero + properties across the replacement. +- `tp-text` application preserves the caller's `tp-set`, `tp-reset`, + or `tp-add` write semantics even when replacement text is unchanged. +- Explicit nil properties override embedded `tp-text` values. +- Non-parameterized layer redefinition refreshes managed regions with + old/new ownership reconciliation: removed keys disappear, new keys + replace them, and unrelated or externally changed values survive. +- Search APIs distinguish omitted VALUE (any directly present value) + from explicit nil (a present nil value), with one presence-aware run + scanner shared by strings and buffers. +- Removing the last nested sub-property removes the empty parent key + consistently for strings and buffers. +- Stack NOERROR catches only unresolved layer specifications; errors + from layer bodies and internal operations propagate. +- When hidden-layer full-stack storage detects an external direct + property edit, stack decoding now signals `tp-layer-conflict` before + any managed write instead of silently discarding the external value. +- Buffer transaction rollback tracks its live range with markers, so + insertions and deletions inside the range are removed or restored + together with the original text-property snapshot. + +### Changed + +- Transform and compute failures now propagate as business-output + errors. A transform returning a non-string also signals. Watcher + failures remain isolated observers, but are recorded structurally + while the managed update continues. +- Managed layer entries now store `tp-meta` in authoritative + `tp-layers` storage, including parameterized args and definition + versions. Direct rendered properties and public stack queries strip + `tp-meta`; historical returns remain unchanged. +- Parameterized mounted layer entries refresh from stored args after + redefinition. +- Insert/copy/yank/stickiness/narrowing/indirect-buffer behavior is + now documented as direct Emacs delegation with no tp wrapper. +- Overlay creation, movement, deletion, priority management, and + lifecycle remain native Emacs responsibilities; tp only reports + overlay-aware lookup results. +- `tp-with-mutation-policy` accepts only ordinary+respect, + ordinary+inhibit, and silent+inhibit; silent+respect is rejected. +- Theme enable/disable events now increment theme generation and expose + conservative refresh diagnostics. Reproducible benchmark evidence is + recorded in `docs/BENCHMARKS.md`; timings are advisory baseline data, + not release thresholds. + ## 0.3.0 (2026-07-27) ### Added diff --git a/Makefile b/Makefile index 8e9c9cf..df51551 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,7 @@ # make test # run all ERT test suites # make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces) # make doctest # execute README examples against the code +# make benchmark # run reproducible correctness-first benchmarks # make compile # byte-compile the library modules # make compile-all # byte-compile modules + tests + dev scripts # make clean # remove compiled files @@ -18,11 +19,11 @@ WERROR ?= nil LOADPATH = -L . $(LOAD_EXTRA) SRC = tp-core.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \ - tp-render.el tp-stack.el tp-palette.el tp-builtins.el tp.el + tp-render.el tp-stack.el tp-query.el tp-palette.el tp-builtins.el tp.el TESTS = $(wildcard *-tests.el) -DEV = tp-doctest.el tp-run-shuffled.el +DEV = tp-doctest.el tp-run-shuffled.el tp-benchmark.el -.PHONY: test test-shuffled doctest compile compile-all clean +.PHONY: test test-shuffled doctest benchmark compile compile-all clean test: $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ @@ -35,6 +36,9 @@ test-shuffled: doctest: $(EMACS) -Q --batch $(LOADPATH) -l tp-doctest.el +benchmark: + $(EMACS) -Q --batch $(LOADPATH) -l tp-benchmark.el -f tp-benchmark-run + compile: clean $(EMACS) -Q --batch $(LOADPATH) \ --eval "(setq byte-compile-error-on-warn $(WERROR))" \ diff --git a/README.md b/README.md index 694d6e7..51d92b8 100644 --- a/README.md +++ b/README.md @@ -55,6 +55,11 @@ - [tp-forward-do / tp-backward-do](#tp-forward-do--tp-backward-do) - [tp-search](#tp-search---search-all-matches) - [tp-search-map](#tp-search-map---apply-function-to-matched-text) + - [Native Text Property Compatibility](#native-text-property-compatibility) + - [tp-lookup-result / tp-lookup](#tp-lookup-result--tp-lookup) + - [tp-property-change](#tp-property-change) + - [tp-property-any / tp-property-not-all](#tp-property-any--tp-property-not-all) + - [tp-with-mutation-policy](#tp-with-mutation-policy) - [The Property Layer System](#the-property-layer-system) - [Custom Text Properties](#custom-text-properties) - [Text Property Layers](#text-property-layers) @@ -82,6 +87,10 @@ - [tp-switch-layer](#tp-switch-layer---switch-two-layers) - [Property Layer Visibility](#property-layer-visibility) - [tp-hide-layer / tp-show-layer](#tp-hide-layer--tp-show-layer---hide-and-show-layers) + - [Managed Layer Lifecycle](#managed-layer-lifecycle) + - [tp-attach-managed-layers / tp-detach-managed-layers](#tp-attach-managed-layers--tp-detach-managed-layers) + - [tp-managed-layer-diagnostics / tp-managed-buffer-diagnostics / tp-managed-diagnostics](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) + - [tp-layer-transaction](#tp-layer-transaction) - [Property Layer Merging](#property-layer-merging) - [tp-merge-layers](#tp-merge-layers---merge-multiple-layers) - [tp-flatten-layers](#tp-flatten-layers---flatten-all-layers) @@ -215,6 +224,12 @@ case, so OBJECT sits before the range instead of after it. | `tp-put-layer` / `tp-push-layer` | OBJECT when given (the string itself in string forms), else `(START . END)` | | `tp-add-to-layers` / `tp-add-to-all-layers` | the string itself (mutated **in place**) for string forms; nil for buffers | +The precise object, mutation, nil/presence, search, and managed-layer +contracts are centralized in +[docs/API-SEMANTICS.md](docs/API-SEMANTICS.md). “Unified” means one +high-level vocabulary; a few documented string/buffer return differences +remain for compatibility. + **Namespace map**: `tp-layer-NAME` functions taking a *layer name* argument (`tp-layer-props`, `tp-layer-arglist`, ...) query the layer **registry** (definitions); the ones taking *position* arguments — START END @@ -382,7 +397,7 @@ Native APIs require manual searching and looping. tp.el provides convenient patt (tp-search my-string 'marker) ; => ((0 5 t) (12 17 t)) ;; Upcase all marker text -(tp-search-map #'upcase 'marker nil my-string) +(tp-search-map #'upcase 'marker tp-any-value my-string) ``` ## Requirements @@ -420,6 +435,7 @@ The modules and their roles: | `tp-search.el` | `tp-match-*`, `tp-regexp-*`, `tp-search`, navigation | | `tp-render.el` | Reactive re-rendering engine | | `tp-stack.el` | Layer stack operations (push/pop/move/merge/flatten/...) | +| `tp-query.el` | Native text lookup/change wrappers and mutation policy | | `tp-palette.el` | Light/dark color palette data | | `tp-builtins.el` | Built-in layers, palette gallery, display-buffer helpers | @@ -470,6 +486,16 @@ A complete overview of all tp.el functions organized by category: | [`tp-search`](#tp-search---search-all-matches) | Search all matching properties in range or string | | [`tp-search-map`](#tp-search-map---apply-function-to-matched-text) | Apply function to all matches (with optional start/end range) | +#### Native Text Property Compatibility +| Function | Description | +|----------|-------------| +| [`tp-lookup`](#tp-lookup-result--tp-lookup) | Text-only direct/effective/source-aware property lookup | +| [`tp-lookup-result`](#tp-lookup-result--tp-lookup) | Result record returned by `tp-lookup` | +| [`tp-property-change`](#tp-property-change) | Wrapper for next/previous single-property or all-property change positions | +| [`tp-property-any`](#tp-property-any--tp-property-not-all) | Wrapper for `text-property-any` | +| [`tp-property-not-all`](#tp-property-any--tp-property-not-all) | Wrapper for `text-property-not-all` | +| [`tp-with-mutation-policy`](#tp-with-mutation-policy) | Explicit modified/read-only mutation policy wrapper | + #### Property Layer Definition Functions | Function | Description | |----------|-------------| @@ -515,6 +541,16 @@ A complete overview of all tp.el functions organized by category: | [`tp-hide-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers) | Hide a layer without removing it from the stack | | [`tp-show-layer`](#tp-hide-layer--tp-show-layer---hide-and-show-layers) | Make a hidden layer render again | +#### Managed Layer Lifecycle +| Function | Description | +|----------|-------------| +| [`tp-attach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | Attach inserted/copied managed layer storage to the current buffer registry | +| [`tp-detach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | Remove managed storage, optionally keeping rendered visible properties | +| [`tp-managed-layer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only diagnostics for one layer | +| [`tp-managed-buffer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only diagnostics for one buffer | +| [`tp-managed-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | Read-only global managed lifecycle diagnostics | +| [`tp-layer-transaction`](#tp-layer-transaction) | Run a managed stack change with rollback on error | + #### Property Layer Merging Functions | Function | Description | |----------|-------------| @@ -1434,9 +1470,11 @@ START/END bounds and the SUBEXP capture group work exactly as in Search forward/backward N times for text with PROPERTY. - **N** is the number of searches, defaulting to 1. -- **VALUE** is `equal`-matched against the property's value in buffers. - Passing nil therefore matches the next run where PROPERTY is *absent* - (its value is nil); pass the value explicitly to find a propertied region. +- **VALUE** is `equal`-matched against directly present property values. + Omitting VALUE matches any present value; explicit nil matches a present + nil value. Missing-property spans never match. +- Pass the unique public sentinel **`tp-any-value`** when wildcard matching + is wanted and later positional arguments such as OBJECT or N are supplied. - **`tp-backward` mirrors `tp-forward`**: the same equal-matching semantics, in the opposite direction. - **OBJECT** can be a buffer or string; nil defaults to current buffer. @@ -1449,7 +1487,7 @@ Search forward/backward N times for text with PROPERTY. - For buffers, returns the prop-match object from the last successful search. - For strings, returns a list of (START END VALUE) for the **first N** runs where PROPERTY matches, counted from position 0 (point is not involved); - VALUE nil means any value. `tp-backward` returns them from end to start. + `tp-backward` returns them from end to start. **Examples:** @@ -1464,14 +1502,20 @@ Search forward/backward N times for text with PROPERTY. (prop-match-beginning match)))) ;; => 7 -;; VALUE nil equal-matches nil - i.e. the run WITHOUT the property +;; Omitting VALUE matches the next directly present marker value (with-temp-buffer (insert "Hello World Test") (tp-set 7 12 '(marker t)) (goto-char 1) (let ((match (tp-forward 'marker))) (list (prop-match-beginning match) (prop-match-end match)))) -;; => (1 7) ; the run where marker is absent +;; => (7 12) + +;; Explicit nil matches only a present nil value +(let ((str (copy-sequence "abc"))) + (tp-set 1 2 '(marker nil) str) + (tp-forward 'marker nil str)) +;; => ((1 2 nil)) ;; Backward mirrors forward: same value matching, opposite direction (with-temp-buffer @@ -1496,7 +1540,7 @@ Search forward/backward N times for text with PROPERTY. (let ((my-string (copy-sequence "Hello World Hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-forward 'marker nil my-string 2)) + (tp-forward 'marker tp-any-value my-string 2)) ;; => ((0 5 t) (12 17 t)) ;; PREDICATE - match with a custom function instead of `equal' @@ -1550,7 +1594,9 @@ a function to *every* match. - **FUNCTION** receives `(TEXT &optional START END IDX)` where TEXT is the matched text, START and END are the positions of the match, and IDX is the 0-based match index. FUNCTION is called with as many of these arguments as it accepts. When FUNCTION returns a string, it replaces the matched text in the string or buffer. - **Replacements may change length in buffers** (the match is deleted and the replacement inserted). **Strings cannot change length in place**: a replacement of a different length signals an error; same-length replacements are applied in place. - **PROPERTY** is the text property to search for. -- **VALUE** is the optional value to match; nil means search for PROPERTY without matching value. +- **VALUE** follows the presence-aware search contract: omitted means any + present value; explicit nil means a present nil value. Use + `tp-any-value` when later positional arguments are supplied. - **OBJECT** can be a buffer or string; nil defaults to current buffer. - **TIMES** is the number of searches, defaulting to 1. The function searches TIMES times but only applies FUNCTION to the TIMES-th match. All-or-nothing: if fewer than TIMES matches exist, FUNCTION is not applied at all and the number of available matches is returned. - **START** and **END** define the search range; defaults are object start and end. @@ -1566,7 +1612,7 @@ a function to *every* match. (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-forward-do #'upcase 'marker nil my-string 2) + (tp-forward-do #'upcase 'marker tp-any-value my-string 2) my-string) ;; => "hello world HELLO" ; Only the 2nd match is upcased @@ -1574,7 +1620,7 @@ a function to *every* match. (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-forward-do #'upcase 'marker nil my-string 2 6 17) + (tp-forward-do #'upcase 'marker tp-any-value my-string 2 6 17) my-string) ;; => "hello world hello" ; only 1 match in range 6-17, so the ;; requested 2nd match does not exist: nothing is applied @@ -1590,7 +1636,7 @@ a function to *every* match. (lambda (text start end) (setq match-info (list start end)) (upcase text)) - 'marker nil my-string 2) + 'marker tp-any-value my-string 2) (list my-string match-info)) ;; => ("hello world HELLO" (12 17)) ; Only the last match is transformed @@ -1598,7 +1644,7 @@ a function to *every* match. (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-backward-do #'upcase 'marker nil my-string 2) + (tp-backward-do #'upcase 'marker tp-any-value my-string 2) my-string) ;; => "HELLO world hello" ; The first match (last when searching backward) is upcased ``` @@ -1668,7 +1714,9 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT. replacement of a different length signals an error; same-length replacements are applied in place. - **PROPERTY** is the text property to search for. -- **VALUE** is the optional value to match; nil means search for PROPERTY without matching value. +- **VALUE** follows the presence-aware search contract: omitted means any + present value; explicit nil means a present nil value. Use + `tp-any-value` when later positional arguments are supplied. - **OBJECT** can be a buffer or string; nil defaults to current buffer. - **START** and **END** define the search range; defaults are object start and end. - Returns the number of matches processed. @@ -1680,7 +1728,7 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT. (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-search-map #'upcase 'marker nil my-string) + (tp-search-map #'upcase 'marker tp-any-value my-string) my-string) ;; => "HELLO world HELLO" @@ -1688,7 +1736,7 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT. (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-search-map #'upcase 'marker nil my-string 0 10) + (tp-search-map #'upcase 'marker tp-any-value my-string 0 10) my-string) ;; => "HELLO world hello" ; Only first match in range 0-10 @@ -1703,20 +1751,129 @@ Apply FUNCTION to all matches of PROPERTY in OBJECT. (lambda (text start end idx) (push (list idx start end) positions) (upcase text)) - 'marker nil my-string) + 'marker tp-any-value my-string) (list my-string (nreverse positions))) ;; => ("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11))) ;; Custom transformation without optional parameters (let ((my-string (copy-sequence "hello world"))) (tp-set 0 5 '(marker t) my-string) - (tp-search-map #'upcase 'marker nil my-string) + (tp-search-map #'upcase 'marker tp-any-value my-string) my-string) ;; => "HELLO world" ``` --- +## Native Text Property Compatibility + +Stage 3 makes the text-property boundary explicit, and Stage 5 adds overlay-aware character-property lookup. These APIs map to GNU Emacs primitives; tp does not manage overlay lifecycle. + +#### `tp-lookup-result` / `tp-lookup` + +`tp-lookup` returns a `tp-lookup-result` record. Use the generated accessors: + +| Accessor | Meaning | +|----------|---------| +| `tp-lookup-result-property` | requested property | +| `tp-lookup-result-value` | resolved value | +| `tp-lookup-result-present-p` | non-nil when the chosen source provides the property; a direct nil counts, while a nil alias follows Emacs' alias fallback | +| `tp-lookup-result-source` | `:text-direct`, `:category`, `:alias`, `:default`, or `:absent` | +| `tp-lookup-result-mode` | lookup mode | +| `tp-lookup-result-object` | queried object | +| `tp-lookup-result-position` | queried position | +| `tp-lookup-result-overlay` | winning overlay for `:char` / `:char-source`, otherwise nil | + +Modes: + +| Mode | Behavior | +|------|----------| +| `:text-direct` | inspect only direct text properties with `text-properties-at`; explicit nil is present | +| `:text-effective` | return `get-text-property`'s effective text value and report its text source | +| `:text-source` | report the winning text source without overlays | +| `:char` | overlay-aware `get-char-property-and-overlay` value; text fallback follows Emacs | +| `:char-source` | like `:char`, plus `:overlay` source and overlay identity when an overlay wins | + +```elisp +;; Direct lookup distinguishes explicit nil from absence +(let ((str (copy-sequence "ab"))) + (put-text-property 0 1 'state nil str) + (let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct)) + (absent-result (tp-lookup 1 'state :object str :mode :text-direct))) + (list (list (tp-lookup-result-present-p nil-result) + (tp-lookup-result-value nil-result) + (tp-lookup-result-source nil-result)) + (list (tp-lookup-result-present-p absent-result) + (tp-lookup-result-value absent-result) + (tp-lookup-result-source absent-result))))) +;; => ((t nil :text-direct) (nil nil :absent)) + +;; Source-aware lookup explains category/default/alias/direct text sources +(let* ((str (copy-sequence "a")) + (category (make-symbol "tp-doc-category"))) + (put category 'state 'category-value) + (put-text-property 0 1 'category category str) + (let ((result (tp-lookup 0 'state :object str :mode :text-source))) + (list (tp-lookup-result-value result) + (tp-lookup-result-source result)))) +;; => (category-value :category) + +;; Character-source lookup reports the winning overlay identity +(with-temp-buffer + (insert "x") + (let ((low (make-overlay 1 2)) + (high (make-overlay 1 2))) + (overlay-put low 'priority 1) + (overlay-put low 'state 'low) + (overlay-put high 'priority 10) + (overlay-put high 'state 'high) + (let ((result (tp-lookup 1 'state :mode :char-source))) + (list (tp-lookup-result-value result) + (tp-lookup-result-source result) + (eq (tp-lookup-result-overlay result) high))))) +;; => (high :overlay t) +``` + +`tp-lookup` reports overlay winners, but overlay creation, deletion, movement, priority management, and lifecycle remain native Emacs responsibilities. + +#### `tp-property-change` + +`tp-property-change` wraps `next-property-change`, `previous-property-change`, `next-single-property-change`, and `previous-single-property-change`. + +```elisp +(tp-property-change POSITION :object OBJECT :limit LIMIT :direction :next) +(tp-property-change POSITION :property PROPERTY :object OBJECT :limit LIMIT :direction :previous) +``` + +Omit `:property` for any property change. Pass `:property` for a single-property change. `:direction` is `:next` or `:previous`. + +#### `tp-property-any` / `tp-property-not-all` + +These are thin wrappers over Emacs primitives: + +```elisp +(tp-property-any START END PROPERTY VALUE &optional OBJECT) +(tp-property-not-all START END PROPERTY VALUE &optional OBJECT) +``` + +They preserve Emacs behavior exactly, including explicit nil matching. + +#### `tp-with-mutation-policy` + +`tp-with-mutation-policy` makes modified/read-only behavior explicit for buffer mutations: + +| Policy | Behavior | +|--------|----------| +| `(:modified :ordinary :read-only :respect)` | normal Emacs mutation; read-only text can signal | +| `(:modified :ordinary :read-only :inhibit)` | bind `inhibit-read-only` and record ordinary modified/undo state | +| `(:modified :silent :read-only :inhibit)` | bind `inhibit-read-only` and use `with-silent-modifications` | + +`(:modified :silent :read-only :respect)` is rejected because silent modification cannot be combined with respecting read-only text. + +Insert/copy/yank/stickiness/narrowing/indirect-buffer behavior is delegated directly to Emacs. tp does not provide wrappers for those operations; use the native primitives (`insert`, `insert-and-inherit`, `copy-sequence`, `substring`, `insert-for-yank`, narrowing commands, and indirect buffers). + +--- + ## The Property Layer System The **property layer system** is tp.el's innovative feature that allows stacking multiple sets of properties on the same text region. Only the **top layer** is visible, but lower layers are preserved and can be revealed through rotation or pinning. @@ -2443,7 +2600,7 @@ returns nil instead of signaling. :top (tp-layer-top 1 10) :layers (tp-layer-list 1 10) :hidden (length (tp-at 1 'tp-layers))))) -;; => (:face (:background "yellow") :top highlight :layers (highlight base) :hidden 1) +;; => (:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2) ``` --- @@ -2879,6 +3036,12 @@ full stack, hidden layers included (0 = top, -1 = bottom). - Hiddenness is stored as a `tp-hidden` flag inside the layer's plist in `tp-layers` stack storage, so `tp-hidden` is a reserved property name inside layers, like `tp-name`. +- While any layer is hidden, direct properties are a render cache for the + first visible managed layer. Definition/reactive refresh has enough + ownership context to preserve native edits on that visible layer. A normal + stack decode/write remains strict and signals `tp-layer-conflict` before + changing state when the cache differs; properties appearing while every + layer is hidden are always a conflict. Both functions return the number of property runs modified. A NAME matching no layer never signals, and hiding an already-hidden layer (or showing a @@ -2946,6 +3109,64 @@ visible one) is a silent no-op — 0 means nothing changed. --- +### Managed Layer Lifecycle + +Stage 4 adds explicit lifecycle metadata for managed layer stacks. A single managed layer now uses `tp-layers` storage when metadata is present, because `tp-meta` is authoritative lifecycle state. The rendered direct text properties and public stack queries strip `tp-meta`: `text-properties-at` should show only rendered properties plus stack storage, and `tp-layer-stack-at` returns public layer plists without metadata. + +Legacy return values remain unchanged. Stack mutators still return their documented object/range/run-count values; diagnostics are separate read-only APIs. + +Parameterized mounted layers store their args and definition version in `tp-meta`. Redefining a parameterized layer refreshes mounted entries from stored args. Entries created before metadata existed are treated conservatively as legacy entries. + +#### `tp-attach-managed-layers` / `tp-detach-managed-layers` + +```elisp +(tp-attach-managed-layers START END &optional OBJECT) +(tp-detach-managed-layers START END &optional OBJECT KEEP-RENDERED) +``` + +`tp-attach-managed-layers` scans a range that already contains managed layer storage, normalizes missing metadata, registers found layers in the reactive buffer registry, and returns discovered layer names in range order. Use it after inserting a propertized managed string through native insertion paths. + +`tp-detach-managed-layers` removes managed storage and returns detached layer names. When KEEP-RENDERED is non-nil, the currently visible rendered properties remain as ordinary text properties; lifecycle storage (`tp-name`, `tp-layers`, `tp-meta`) is removed. + +#### `tp-managed-layer-diagnostics` / `tp-managed-buffer-diagnostics` / `tp-managed-diagnostics` + +```elisp +(tp-managed-layer-diagnostics LAYER-NAME) +(tp-managed-buffer-diagnostics &optional BUFFER) +(tp-managed-diagnostics) +``` + +These functions are read-only diagnostics. They report layers, buffers, entries, stored args, registry state, errors, and theme diagnostics. `tp-managed-diagnostics` includes a `:theme` plist with generation, last hook source, refresh mode, refreshed ranges, and errors. Theme enable/disable hooks increment the generation and use conservative refresh diagnostics; this is lifecycle evidence, not a benchmark. + +#### `tp-layer-transaction` + +```elisp +(tp-layer-transaction START END OBJECT FUNCTION &optional NOERROR) +``` + +Runs FUNCTION over a managed range. On success it returns a structured plist with `:status ok`, `:ok t`, FUNCTION's value in `:result`, an operation id, the range, and changed ranges. On error it restores the exact pre-transaction text/property snapshot; by default it signals `tp-layer-transaction-error`, while NOERROR returns the structured failure plist with rollback status. + +```elisp +(progn + (tp-layer-reset) + (define-tp tx-base () '(face bold)) + (define-tp tx-temp () '(face italic)) + (with-temp-buffer + (insert "abcd") + (let ((result + (tp-layer-transaction + 1 4 (current-buffer) + (lambda () (tp-put-layer 1 3 'tx-base 0))))) + (list (plist-get result :status) + (plist-get result :range) + (tp-at 1 'face))))) +;; => (ok (1 . 4) bold) +``` + +Theme generation and managed diagnostics are verified as lifecycle behavior. Reproducible benchmark evidence is recorded in `docs/BENCHMARKS.md`; those timings are advisory baseline data, not release thresholds. + +--- + ### Property Layer Merging #### `tp-merge-layers` - Merge Multiple Layers @@ -3836,7 +4057,12 @@ The transform function: - Receives the raw `tp-text` string value - Returns the transformed string for display - Is applied both on initial display and reactive updates -- Errors in transform functions are caught and logged +- Must return a string; failures and non-string results propagate instead of + rendering stale input + +Compute functions follow the same business-error rule. Watch callbacks are +observers: their failures are isolated so rendering continues, and structured +records are appended newest-first to `tp-reactive-observer-errors`. ### Anonymous Reactive Layers @@ -3868,6 +4094,13 @@ All text property APIs (`tp-set`, `tp-match-set`, `tp-regexp-set`, etc.) now acc (tp-regexp-set "[0-9]+" 'warning-style) ``` +This direct use is **template expansion** for non-reactive layers: the +definition becomes ordinary text properties and does not retain `tp-name`. +Use `tp-push-layer` or `tp-put-layer` for a **managed mount** that can later +be queried, moved, hidden, deleted by name, or refreshed after a layer +redefinition. Parameterized mounted entries retain their arguments and use +them to refresh existing instances after redefinition. + ### Reactive Layer Groups Layer groups can also use reactive features: diff --git a/README_CN.md b/README_CN.md index 0e0699e..5d47c38 100644 --- a/README_CN.md +++ b/README_CN.md @@ -54,6 +54,11 @@ - [tp-forward-do / tp-backward-do](#tp-forward-do--tp-backward-do) - [tp-search](#tp-search---搜索所有匹配) - [tp-search-map](#tp-search-map---对匹配文本应用函数) + - [原生文本属性兼容](#原生文本属性兼容) + - [tp-lookup-result / tp-lookup](#tp-lookup-result--tp-lookup) + - [tp-property-change](#tp-property-change) + - [tp-property-any / tp-property-not-all](#tp-property-any--tp-property-not-all) + - [tp-with-mutation-policy](#tp-with-mutation-policy) - [属性层系统](#属性层系统) - [自定义文本属性](#自定义文本属性) - [文本属性层](#文本属性层) @@ -81,6 +86,10 @@ - [tp-switch-layer](#tp-switch-layer---交换两个属性层) - [属性层可见性](#属性层可见性) - [tp-hide-layer / tp-show-layer](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) + - [Managed Layer 生命周期](#managed-layer-生命周期) + - [tp-attach-managed-layers / tp-detach-managed-layers](#tp-attach-managed-layers--tp-detach-managed-layers) + - [tp-managed-layer-diagnostics / tp-managed-buffer-diagnostics / tp-managed-diagnostics](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) + - [tp-layer-transaction](#tp-layer-transaction) - [属性层合并](#属性层合并) - [tp-merge-layers](#tp-merge-layers---合并多个属性层) - [tp-flatten-layers](#tp-flatten-layers---扁平化所有属性层) @@ -214,6 +223,10 @@ OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和 | `tp-put-layer` / `tp-push-layer` | 给定 OBJECT 时返回 OBJECT（字符串形式返回该字符串本身），否则返回 `(START . END)` | | `tp-add-to-layers` / `tp-add-to-all-layers` | 字符串形式返回该字符串本身（**就地**修改）；缓冲区返回 nil | +对象、修改性、nil/presence、搜索和 managed layer 的精确契约统一记录在 +[docs/API-SEMANTICS.md](docs/API-SEMANTICS.md)。“统一”指共享同一套高层 +词汇；为保持兼容，当前仍存在少数已记录的字符串/缓冲区返回值差异。 + **命名空间地图**：接受*层名*参数的 `tp-layer-NAME` 函数 （`tp-layer-props`、`tp-layer-arglist` 等）查询的是层**注册表**（层定 义）；接受*位置*参数的函数 —— START END（`tp-layer-list`、 @@ -381,7 +394,7 @@ OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和 (tp-search my-string 'marker) ; => ((0 5 t) (12 17 t)) ;; 将所有标记文本转为大写 -(tp-search-map #'upcase 'marker nil my-string) +(tp-search-map #'upcase 'marker tp-any-value my-string) ``` ## 系统要求 @@ -418,6 +431,7 @@ OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和 | `tp-search.el` | `tp-match-*`、`tp-regexp-*`、`tp-search`、导航 | | `tp-render.el` | 响应式重渲染引擎 | | `tp-stack.el` | 属性层栈操作（push/pop/移动/合并/扁平化/...） | +| `tp-query.el` | 原生文本查询/change 封装与修改策略 | | `tp-palette.el` | 亮色/暗色调色板数据 | | `tp-builtins.el` | 内置属性层、调色板画廊、display-buffer 辅助工具 | @@ -467,6 +481,16 @@ tp.el 所有函数按类别组织的完整概览： | [`tp-search`](#tp-search---搜索所有匹配) | 在范围或字符串中搜索所有匹配的属性 | | [`tp-search-map`](#tp-search-map---对匹配文本应用函数) | 对所有匹配的文本应用函数（支持起始和结束范围） | +#### 原生文本属性兼容 +| 函数 | 描述 | +|------|------| +| [`tp-lookup`](#tp-lookup-result--tp-lookup) | text-only 的 direct/effective/source-aware 属性查询 | +| [`tp-lookup-result`](#tp-lookup-result--tp-lookup) | `tp-lookup` 返回的结果记录 | +| [`tp-property-change`](#tp-property-change) | next/previous single-property 或 all-property change 位置封装 | +| [`tp-property-any`](#tp-property-any--tp-property-not-all) | `text-property-any` 封装 | +| [`tp-property-not-all`](#tp-property-any--tp-property-not-all) | `text-property-not-all` 封装 | +| [`tp-with-mutation-policy`](#tp-with-mutation-policy) | 显式 modified/read-only 修改策略封装 | + #### 属性层定义函数 | 函数 | 描述 | |------|------| @@ -512,6 +536,16 @@ tp.el 所有函数按类别组织的完整概览： | [`tp-hide-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) | 隐藏属性层而不将其从栈中移除 | | [`tp-show-layer`](#tp-hide-layer--tp-show-layer---隐藏与显示属性层) | 让隐藏的属性层重新渲染 | +#### Managed Layer 生命周期 +| 函数 | 描述 | +|------|------| +| [`tp-attach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | 将插入/复制进来的 managed layer storage 登记到当前缓冲区注册表 | +| [`tp-detach-managed-layers`](#tp-attach-managed-layers--tp-detach-managed-layers) | 移除 managed storage，可选保留当前可见渲染属性 | +| [`tp-managed-layer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 某一层的只读诊断 | +| [`tp-managed-buffer-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 某一缓冲区的只读诊断 | +| [`tp-managed-diagnostics`](#tp-managed-layer-diagnostics--tp-managed-buffer-diagnostics--tp-managed-diagnostics) | 全局 managed lifecycle 只读诊断 | +| [`tp-layer-transaction`](#tp-layer-transaction) | 以失败回滚方式执行 managed stack 修改 | + #### 属性层合并函数 | 函数 | 描述 | |------|------| @@ -1415,9 +1449,10 @@ START/END 边界和 SUBEXP 捕获组的用法与 向前/向后搜索 N 次具有 PROPERTY 的文本。 - **N** 是搜索次数，默认为 1。 -- **VALUE** 在缓冲区中与属性值做 `equal` 匹配。 - 因此传入 nil 会匹配下一段 PROPERTY *不存在*（值为 nil）的区段； - 要查找带属性的区域，请显式传入属性值。 +- **VALUE** 与直接存在的属性值做 `equal` 匹配。省略 VALUE 匹配任意已 + 存在值；显式 nil 只匹配“键存在且值为 nil”。缺少该属性的区段不匹配。 +- 需要继续传入 OBJECT、N 等后续位置参数并保持通配时，传入公共唯一哨兵 + **`tp-any-value`**。 - **`tp-backward` 与 `tp-forward` 对称**：相同的 equal 匹配语义， 方向相反。 - **OBJECT** 可以是缓冲区或字符串；nil 默认为当前缓冲区。 @@ -1429,8 +1464,8 @@ START/END 边界和 SUBEXP 捕获组的用法与 有 point，因此在字符串上会被忽略。 - 对于缓冲区，返回最后一次成功搜索的 prop-match 对象。 - 对于字符串，返回**前 N 个** PROPERTY 匹配区段的 (START END VALUE) - 列表，从位置 0 开始计数（与 point 无关）；VALUE 为 nil 表示匹配任意 - 值。`tp-backward` 按从末尾到开头的顺序返回。 + 列表，从位置 0 开始计数（与 point 无关）。`tp-backward` 按从末尾到 + 开头的顺序返回。 **示例：** @@ -1445,14 +1480,20 @@ START/END 边界和 SUBEXP 捕获组的用法与 (prop-match-beginning match)))) ;; => 7 -;; VALUE 为 nil 时 equal 匹配 nil - 即匹配没有该属性的区段 +;; 省略 VALUE 时匹配下一个直接存在的 marker 值 (with-temp-buffer (insert "Hello World Test") (tp-set 7 12 '(marker t)) (goto-char 1) (let ((match (tp-forward 'marker))) (list (prop-match-beginning match) (prop-match-end match)))) -;; => (1 7) ; marker 不存在的区段 +;; => (7 12) + +;; 显式 nil 只匹配“属性存在且值为 nil” +(let ((str (copy-sequence "abc"))) + (tp-set 1 2 '(marker nil) str) + (tp-forward 'marker nil str)) +;; => ((1 2 nil)) ;; backward 与 forward 对称：相同的值匹配，方向相反 (with-temp-buffer @@ -1477,7 +1518,7 @@ START/END 边界和 SUBEXP 捕获组的用法与 (let ((my-string (copy-sequence "Hello World Hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-forward 'marker nil my-string 2)) + (tp-forward 'marker tp-any-value my-string 2)) ;; => ((0 5 t) (12 17 t)) ;; PREDICATE - 用自定义函数代替 `equal' 进行匹配 @@ -1530,7 +1571,9 @@ START/END 边界和 SUBEXP 捕获组的用法与 - **FUNCTION** 的参数是 `(TEXT &optional START END IDX)`，其中 TEXT 是此次匹配到的文本，START 和 END 为开始结束的位置，IDX 是从 0 开始的匹配索引。FUNCTION 会按其实际接受的参数个数被调用。当 FUNCTION 返回字符串时，它将替换字符串或缓冲区中的匹配文本。 - **在缓冲区中替换文本可以改变长度**（先删除匹配文本，再插入替换文本）。**字符串无法就地改变长度**：长度不同的替换会发出错误信号；长度相同的替换会就地应用。 - **PROPERTY** 是要搜索的文本属性。 -- **VALUE** 为 nil 时，表示搜索 PROPERTY 属性，不用匹配值。 +- **VALUE** 遵循 presence-aware 搜索契约：省略表示任意已存在值；显式 + nil 表示“键存在且值为 nil”。需要继续传入后续位置参数时使用 + `tp-any-value`。 - **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。 - **TIMES** 表示向前/向后搜索几次，默认搜索一次。该函数会搜索 TIMES 次，但仅对第 TIMES 个匹配应用 FUNCTION。要么全有要么全无：当匹配数量不足 TIMES 时，完全不应用 FUNCTION，仅返回实际找到的匹配数量。 - **START** 和 **END** 默认为 OBJECT 的起始和结束位置。 @@ -1546,7 +1589,7 @@ START/END 边界和 SUBEXP 捕获组的用法与 (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-forward-do #'upcase 'marker nil my-string 2) + (tp-forward-do #'upcase 'marker tp-any-value my-string 2) my-string) ;; => "hello world HELLO" ; 仅第 2 次匹配被转为大写 @@ -1554,7 +1597,7 @@ START/END 边界和 SUBEXP 捕获组的用法与 (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-forward-do #'upcase 'marker nil my-string 2 6 17) + (tp-forward-do #'upcase 'marker tp-any-value my-string 2 6 17) my-string) ;; => "hello world hello" ; 范围 6-17 内仅有 1 个匹配，请求的 ;; 第 2 个匹配不存在：不做任何应用（要么全有要么全无； @@ -1570,7 +1613,7 @@ START/END 边界和 SUBEXP 捕获组的用法与 (lambda (text start end) (setq match-info (list start end)) (upcase text)) - 'marker nil my-string 2) + 'marker tp-any-value my-string 2) (list my-string match-info)) ;; => ("hello world HELLO" (12 17)) ; 仅最后一次匹配被转换 @@ -1578,7 +1621,7 @@ START/END 边界和 SUBEXP 捕获组的用法与 (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-backward-do #'upcase 'marker nil my-string 2) + (tp-backward-do #'upcase 'marker tp-any-value my-string 2) my-string) ;; => "HELLO world hello" ; 向后搜索时第一个匹配（即最后找到的）被转为大写 ``` @@ -1646,7 +1689,9 @@ START/END 边界和 SUBEXP 捕获组的用法与 **字符串无法就地改变长度**：长度不同的替换会发出错误信号； 长度相同的替换会就地应用。 - **PROPERTY** 是要搜索的文本属性。 -- **VALUE** 为 nil 时，表示搜索 PROPERTY 属性，不用匹配值。 +- **VALUE** 遵循 presence-aware 搜索契约：省略表示任意已存在值；显式 + nil 表示“键存在且值为 nil”。需要继续传入后续位置参数时使用 + `tp-any-value`。 - **OBJECT** 默认是当前 buffer 或指定的字符串或指定的 buffer。 - **START** 和 **END** 默认为 OBJECT 的起始和结束位置。 - 返回处理的匹配数量。 @@ -1658,7 +1703,7 @@ START/END 边界和 SUBEXP 捕获组的用法与 (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-search-map #'upcase 'marker nil my-string) + (tp-search-map #'upcase 'marker tp-any-value my-string) my-string) ;; => "HELLO world HELLO" @@ -1666,7 +1711,7 @@ START/END 边界和 SUBEXP 捕获组的用法与 (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-search-map #'upcase 'marker nil my-string 0 10) + (tp-search-map #'upcase 'marker tp-any-value my-string 0 10) my-string) ;; => "HELLO world hello" ; 仅范围 0-10 内的第一个匹配被处理 @@ -1681,20 +1726,129 @@ START/END 边界和 SUBEXP 捕获组的用法与 (lambda (text start end idx) (push (list idx start end) positions) (upcase text)) - 'marker nil my-string) + 'marker tp-any-value my-string) (list my-string (nreverse positions))) ;; => ("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11))) ;; 不使用可选参数的自定义转换 (let ((my-string (copy-sequence "hello world"))) (tp-set 0 5 '(marker t) my-string) - (tp-search-map #'upcase 'marker nil my-string) + (tp-search-map #'upcase 'marker tp-any-value my-string) my-string) ;; => "HELLO world" ``` --- +## 原生文本属性兼容 + +Stage 3 明确了文本属性边界，Stage 5 增加 overlay-aware 字符属性查询。这组 API 映射 GNU Emacs 原语；tp 不管理 overlay 生命周期。 + +#### `tp-lookup-result` / `tp-lookup` + +`tp-lookup` 返回 `tp-lookup-result` 记录。使用自动生成的访问器读取字段： + +| 访问器 | 含义 | +|--------|------| +| `tp-lookup-result-property` | 请求的属性 | +| `tp-lookup-result-value` | 解析出的值 | +| `tp-lookup-result-present-p` | 选定来源提供该属性时为非 nil；direct 显式 nil 计为存在，alias nil 则遵循 Emacs 的 alias fallback | +| `tp-lookup-result-source` | `:text-direct`、`:category`、`:alias`、`:default` 或 `:absent` | +| `tp-lookup-result-mode` | 查询模式 | +| `tp-lookup-result-object` | 被查询对象 | +| `tp-lookup-result-position` | 被查询位置 | +| `tp-lookup-result-overlay` | `:char` / `:char-source` 中的获胜 overlay；其他模式为 nil | + +模式： + +| 模式 | 行为 | +|------|------| +| `:text-direct` | 只检查 `text-properties-at` 的直接文本属性；显式 nil 算存在 | +| `:text-effective` | 返回 `get-text-property` 的有效文本值，并报告其文本来源 | +| `:text-source` | 报告不含 overlay 的获胜文本来源 | +| `:char` | overlay-aware 的 `get-char-property-and-overlay` 值；文本 fallback 遵循 Emacs | +| `:char-source` | 类似 `:char`，当 overlay 获胜时额外记录 `:overlay` 来源和 overlay 对象 | + +```elisp +;; direct 查询区分显式 nil 与缺失 +(let ((str (copy-sequence "ab"))) + (put-text-property 0 1 'state nil str) + (let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct)) + (absent-result (tp-lookup 1 'state :object str :mode :text-direct))) + (list (list (tp-lookup-result-present-p nil-result) + (tp-lookup-result-value nil-result) + (tp-lookup-result-source nil-result)) + (list (tp-lookup-result-present-p absent-result) + (tp-lookup-result-value absent-result) + (tp-lookup-result-source absent-result))))) +;; => ((t nil :text-direct) (nil nil :absent)) + +;; source-aware 查询解释 category/default/alias/direct 文本来源 +(let* ((str (copy-sequence "a")) + (category (make-symbol "tp-doc-category"))) + (put category 'state 'category-value) + (put-text-property 0 1 'category category str) + (let ((result (tp-lookup 0 'state :object str :mode :text-source))) + (list (tp-lookup-result-value result) + (tp-lookup-result-source result)))) +;; => (category-value :category) + +;; char-source 查询报告获胜 overlay 身份 +(with-temp-buffer + (insert "x") + (let ((low (make-overlay 1 2)) + (high (make-overlay 1 2))) + (overlay-put low 'priority 1) + (overlay-put low 'state 'low) + (overlay-put high 'priority 10) + (overlay-put high 'state 'high) + (let ((result (tp-lookup 1 'state :mode :char-source))) + (list (tp-lookup-result-value result) + (tp-lookup-result-source result) + (eq (tp-lookup-result-overlay result) high))))) +;; => (high :overlay t) +``` + +`tp-lookup` 会报告 overlay 获胜者，但 overlay 创建、删除、移动、priority 管理和生命周期仍由 Emacs 原生机制负责。 + +#### `tp-property-change` + +`tp-property-change` 封装 `next-property-change`、`previous-property-change`、`next-single-property-change` 和 `previous-single-property-change`。 + +```elisp +(tp-property-change POSITION :object OBJECT :limit LIMIT :direction :next) +(tp-property-change POSITION :property PROPERTY :object OBJECT :limit LIMIT :direction :previous) +``` + +省略 `:property` 表示任意属性变化；传入 `:property` 表示单属性变化。`:direction` 为 `:next` 或 `:previous`。 + +#### `tp-property-any` / `tp-property-not-all` + +这两个函数是 Emacs 原语的薄封装： + +```elisp +(tp-property-any START END PROPERTY VALUE &optional OBJECT) +(tp-property-not-all START END PROPERTY VALUE &optional OBJECT) +``` + +它们完整保留 Emacs 行为，包括显式 nil 匹配。 + +#### `tp-with-mutation-policy` + +`tp-with-mutation-policy` 显式声明 buffer 修改的 modified/read-only 行为： + +| 策略 | 行为 | +|------|------| +| `(:modified :ordinary :read-only :respect)` | 普通 Emacs 修改；read-only 文本可报错 | +| `(:modified :ordinary :read-only :inhibit)` | 绑定 `inhibit-read-only`，并记录普通 modified/undo 状态 | +| `(:modified :silent :read-only :inhibit)` | 绑定 `inhibit-read-only`，并使用 `with-silent-modifications` | + +`(:modified :silent :read-only :respect)` 会被拒绝，因为 silent modification 不能与尊重 read-only 文本同时成立。 + +insert/copy/yank/stickiness/narrowing/indirect-buffer 行为直接委托 Emacs。tp 不提供这些操作的 wrapper；请使用原生原语（`insert`、`insert-and-inherit`、`copy-sequence`、`substring`、`insert-for-yank`、narrowing 命令和 indirect buffer）。 + +--- + ## 属性层系统 属性层系统是 tp.el 的创新功能，允许在同一文本区域堆叠多组属性。只有顶层属性可见，但下层属性会被保留，并可通过轮转或固定操作使其显现。 @@ -2417,7 +2571,7 @@ LAYER 返回 nil 而不发出错误信号。 :top (tp-layer-top 1 10) :layers (tp-layer-list 1 10) :hidden (length (tp-at 1 'tp-layers))))) -;; => (:face (:background "yellow") :top highlight :layers (highlight base) :hidden 1) +;; => (:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2) ``` --- @@ -2843,6 +2997,10 @@ OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的 的属性 —— 隐藏的内容绝不会泄漏（参见[属性层合并](#属性层合并)）。 - 隐藏状态以 `tp-hidden` 标志的形式存储在 `tp-layers` 栈存储内该层的 plist 中，因此 `tp-hidden` 与 `tp-name` 一样是层内部的保留属性名。 +- 任一层隐藏期间，直接属性是第一个可见 managed layer 的渲染缓存。 + definition/reactive refresh 具备明确所有权上下文，会把原生编辑保留到该 + 可见层；普通栈解码/写入仍采用严格策略，缓存不一致时会在改变状态之前发出 + `tp-layer-conflict`。所有层都隐藏时出现直接属性始终属于冲突。 两个函数都返回被修改的属性区段数量。NAME 不匹配任何层时从不发出错误信 号，隐藏一个已隐藏的层（或显示一个可见的层）是静默的空操作 —— 返回 0 @@ -2910,6 +3068,64 @@ OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的 --- +### Managed Layer 生命周期 + +Stage 4 为 managed layer stack 增加显式生命周期 metadata。只要存在 metadata，单个 managed layer 现在也使用 `tp-layers` 存储，因为 `tp-meta` 是权威生命周期状态。直接渲染到文本上的属性和公开 stack 查询都会剥离 `tp-meta`：`text-properties-at` 应只显示渲染属性和 stack storage，`tp-layer-stack-at` 返回的公开层 plist 不含 metadata。 + +历史返回值保持不变。stack mutator 仍返回各自已记录的 object/range/run-count；诊断信息通过独立的只读 API 查询。 + +参数化 mounted layer 会把 args 和 definition version 存入 `tp-meta`。重新定义参数化层后，已挂载 entry 会用保存的 args 刷新。metadata 出现前创建的 entry 作为 legacy entry 保守处理。 + +#### `tp-attach-managed-layers` / `tp-detach-managed-layers` + +```elisp +(tp-attach-managed-layers START END &optional OBJECT) +(tp-detach-managed-layers START END &optional OBJECT KEEP-RENDERED) +``` + +`tp-attach-managed-layers` 扫描已含 managed layer storage 的区域，补齐缺失 metadata，把发现的层登记到响应式缓冲区注册表，并按范围顺序返回层名。通过原生插入路径插入带 managed 属性的字符串后使用它。 + +`tp-detach-managed-layers` 移除 managed storage 并返回被 detach 的层名。KEEP-RENDERED 非 nil 时，当前可见渲染属性会保留为普通文本属性；生命周期存储（`tp-name`、`tp-layers`、`tp-meta`）会被移除。 + +#### `tp-managed-layer-diagnostics` / `tp-managed-buffer-diagnostics` / `tp-managed-diagnostics` + +```elisp +(tp-managed-layer-diagnostics LAYER-NAME) +(tp-managed-buffer-diagnostics &optional BUFFER) +(tp-managed-diagnostics) +``` + +这些函数是只读诊断。它们报告 layers、buffers、entries、保存的 args、registry state、errors 和 theme diagnostics。`tp-managed-diagnostics` 包含 `:theme` plist，其中有 generation、last hook source、refresh mode、refreshed ranges 和 errors。theme enable/disable hook 会递增 generation，并使用 conservative refresh diagnostics；这是生命周期证据，不是 benchmark。 + +#### `tp-layer-transaction` + +```elisp +(tp-layer-transaction START END OBJECT FUNCTION &optional NOERROR) +``` + +在 managed range 上执行 FUNCTION。成功时返回结构化 plist，包含 `:status ok`、`:ok t`、FUNCTION 返回值对应的 `:result`、operation id、range 和 changed ranges。失败时恢复事务前的完整文本/属性快照；默认发出 `tp-layer-transaction-error`，NOERROR 非 nil 时返回带 rollback 状态的结构化失败 plist。 + +```elisp +(progn + (tp-layer-reset) + (define-tp tx-base () '(face bold)) + (define-tp tx-temp () '(face italic)) + (with-temp-buffer + (insert "abcd") + (let ((result + (tp-layer-transaction + 1 4 (current-buffer) + (lambda () (tp-put-layer 1 3 'tx-base 0))))) + (list (plist-get result :status) + (plist-get result :range) + (tp-at 1 'face))))) +;; => (ok (1 . 4) bold) +``` + +theme generation 与 managed diagnostics 已作为生命周期行为验证。可复现 benchmark 证据记录在 `docs/BENCHMARKS.md`；这些耗时是建议性基线，不是发布阈值。 + +--- + ### 属性层合并 #### `tp-merge-layers` - 合并多个属性层 @@ -3783,7 +3999,11 @@ OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的 - 接收原始的 `tp-text` 字符串值 - 返回用于显示的转换后字符串 - 在初始显示和响应式更新时都会应用 -- 转换函数中的错误会被捕获并记录 +- 必须返回字符串；失败或返回非字符串会向上传播，不会渲染陈旧输入 + +compute 函数遵循相同的业务错误规则。watch 回调属于 observer：其失败会被 +隔离，渲染仍继续；结构化错误按 newest-first 记录在 +`tp-reactive-observer-errors`。 ### 匿名响应式层 @@ -3815,6 +4035,12 @@ OBJECT，因此 `(tp-rotate-layer 1 5 'up)` 会无歧义地选中规范的 (tp-regexp-set "[0-9]+" 'warning-style) ``` +对非响应式层而言，这种直接使用属于**模板展开**：定义被展开为普通文本 +属性，不保留 `tp-name`。如果需要后续按名查询、移动、隐藏、删除，或在非 +参数化层重定义后刷新，请使用 `tp-push-layer` / `tp-put-layer` 建立 +**managed mount**。参数化 mounted entry 目前没有保存实参，因此参数化层 +重定义不会自动刷新既有实例。 + ### 响应式层组 层组也可以使用响应式特性： diff --git a/docs/API-SEMANTICS.md b/docs/API-SEMANTICS.md new file mode 100644 index 0000000..91ceca7 --- /dev/null +++ b/docs/API-SEMANTICS.md @@ -0,0 +1,171 @@ +# tp API 语义规范 + +本文档是 tp 核心 API 的当前行为契约。代码、测试、README 与 docstring 若与本文冲突，应以经过测试的代码为准并同步修正文档。 + +tp 当前定位是 **Emacs 文本属性的高层操作工具箱，以及一套受管理的命名层、层栈和响应式渲染模型**。它尚不是全部原生文本/字符属性语义的等价替代品；完整范围与路线见 [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。 + +Stage 2 canonical façade 已完成为内部模型：`tp--native-range`、`tp--presence`、`tp--request`、`tp--match`、`tp--result` 是模块间传递的规范记录。公开入口和历史返回值保持兼容，不因内部模型收敛而改变。 + +Stage 3 text-only 原生语义 façade 已完成：direct/effective/source-aware lookup、property change/any/not-all 与三种 mutation policy 组合均有明确公开边界。 + +Stage 4 managed lifecycle 已完成：managed metadata、attach/detach、diagnostics、transaction、参数化 mounted layer args/version refresh 与 theme generation diagnostics 均有公开边界。 + +Stage 5 overlay-aware 字符属性查询已完成：`tp-lookup :char` / `:char-source` 报告 Emacs 选出的字符属性值、overlay 来源和获胜 overlay 身份。overlay 创建、移动、删除、priority 管理和生命周期不属于 tp 契约。 + +## 1. 对象、范围与坐标 + +- 所有范围均采用半开区间 `[START, END)`。 +- 字符串使用 Emacs 原生的 0-based 坐标，合法边界为 `0` 到 `(length STRING)`。 +- 缓冲区使用 Emacs 原生位置，通常从 `point-min` 开始；显式 BUFFER 和 nil（当前缓冲区）具有相同语义。 +- 范围结果原则上使用目标对象的原生坐标。当前公开兼容例外是 `tp-intervals` / `tp-intervals-map`：缓冲区默认返回相对 START 的 offset，传入 `ABSOLUTE` 才返回可直接回传给写 API 的原生坐标。内部 canonical range 使用原生坐标，但该 relative 默认作为历史兼容例外保留。 + +## 2. 修改策略 + +| 调用族 | 字符串 | 缓冲区 | +| --- | --- | --- | +| `tp-set` / `tp-reset` / `tp-add` / `tp-remove` 整串形式 | 复制后返回新字符串 | 不适用 | +| 上述函数的 START/END 形式 | 原地修改显式字符串 OBJECT | 原地修改 | +| `tp-match-*` / `tp-regexp-*` | 返回新字符串 | 原地修改，返回匹配范围 | +| 层栈修改函数 | 原地修改字符串 | 原地修改 | +| `tp-forward-do` / `tp-backward-do` / `tp-search-map` | 原地修改；替换文本必须等长 | 原地修改；替换文本可增减长度 | + +普通缓冲区写入使用 Emacs 的属性修改原语，因此遵循 Emacs 的 modified、undo 和 read-only 行为；tp 不把所有修改默认包装为 silent modification。响应式重渲染和 `tp-text` 文本替换为了恢复受管理输出会在内部允许修改 read-only 文本，这是当前实现边界，不代表公开 API 已提供统一的 read-only 策略。相同值刷新会尽量避免无意义地翻转 buffer-modified 状态。 + +## 3. presence、nil 与 wildcard + +以下三种状态必须区分： + +1. 属性键不存在； +2. 属性键存在，值为 nil； +3. 属性键存在，值为非 nil。 + +`tp-member` 用于判断直接属性键是否存在；`tp-at` / `plist-get` 单独使用时不能区分前两种状态。删除最后一个子属性会移除空的父属性键，不会偶然留下 `(PROPERTY nil)`。 + +搜索 API 的规则是： + +- 省略 VALUE：匹配该直接属性的任意已存在值； +- 显式传入 nil：只匹配“键存在且值为 nil”； +- 需要继续提供 OBJECT、次数或范围等后续位置参数时，传入公共唯一哨兵 `tp-any-value` 表示任意值； +- 自定义 PREDICATE 总是优先执行，并接收请求 VALUE（可能是 `tp-any-value`）和实际属性值。 + +属性缺失的范围不属于搜索结果，即使搜索值是 nil。 + +## 4. 搜索结果 + +- `tp-search` 对字符串和缓冲区范围都返回 `(START END VALUE)` 列表。 +- `tp-forward` / `tp-backward` 的字符串路径返回前/后 N 个 `(START END VALUE)`；缓冲区路径移动 point，并返回第 N 次搜索的 `prop-match`。 +- `tp-forward-do` / `tp-backward-do` 只在第 N 个匹配上调用函数；匹配不足 N 个时不调用函数，返回实际找到的数量。 +- `tp-search-map` 处理全部匹配并返回处理数量。 + +`tp-forward` / `tp-backward` 的对象相关结果差异是现存公开兼容契约。内部搜索路径已收敛到 canonical match/result 记录；公开返回结构暂不改变。 + +## 5. 原生文本查询与修改策略 + +Stage 3/5 查询 façade 已完成：text modes 保持 text-only，char modes 委托 Emacs 的 overlay-aware 字符属性查询。 + +`tp-lookup` 返回 `tp-lookup-result` 记录，字段为 property、value、present-p、source、mode、object、position、overlay。text modes 中 overlay 始终为 nil；`:char` / `:char-source` 中 overlay 为 Emacs 选出的获胜 overlay，若文本 fallback 获胜则为 nil。 + +| MODE | 语义 | +| --- | --- | +| `:text-direct` | 只读取直接文本属性；显式 nil 与缺失通过 present-p/source 区分 | +| `:text-effective` | 值使用 `get-text-property`；source 使用 text-only 来源解释 | +| `:text-source` | 返回 direct/category/alias/default/absent 来源和值，不查看 overlay | +| `:char` | 使用 `get-char-property-and-overlay` 的值，按 Emacs overlay/text 优先级解析 | +| `:char-source` | 同 `:char`，并在 overlay 获胜时把 source 设为 `:overlay`、overlay 设为获胜 overlay | + +source 取值为 `:text-direct`、`:category`、`:alias`、`:default`、`:overlay` 或 `:absent`。direct 显式 nil 的结果是 present-p 为 t、value 为 nil、source 为 `:text-direct`；alias nil 与 Emacs 原生语义一致，会继续寻找后续 alias/default；缺失属性的结果是 present-p 为 nil、value 为 nil、source 为 `:absent`。 + +`tp-property-change` 是 Emacs property change 原语的显式封装：`:direction :next` / `:previous` 选择 next/previous，传入 `:property` 时使用 single-property change，省略时使用 all-property change。 + +`tp-property-any` / `tp-property-not-all` 是 `text-property-any` / `text-property-not-all` 的薄封装，保留 Emacs 对显式 nil、边界和对象的行为。 + +`tp-with-mutation-policy` 只接受三种有效组合： + +| POLICY | 语义 | +| --- | --- | +| `(:modified :ordinary :read-only :respect)` | 普通修改，尊重 read-only | +| `(:modified :ordinary :read-only :inhibit)` | 绑定 `inhibit-read-only`，普通 modified/undo 行为 | +| `(:modified :silent :read-only :inhibit)` | 绑定 `inhibit-read-only` 并使用 `with-silent-modifications` | + +`(:modified :silent :read-only :respect)` 明确拒绝，因为 silent modification 与尊重 read-only 不能同时满足。 + +insert、copy、yank、stickiness、narrowing 和 indirect buffer 行为直接委托 Emacs；tp 不为这些原生操作提供 wrapper。 + +## 6. 直接模板展开与 managed mount + +层名有两种不同用途： + +### 6.1 直接模板展开 + +把非响应式层名传给 `tp-set`、`tp-reset`、`tp-add`、`tp-match-*` 或 `tp-regexp-*` 时，层定义展开为普通属性，通常不保留 `tp-name`。结果不能依赖层名进行后续移动、隐藏、按名删除或静态重定义刷新。 + +匿名响应式属性和响应式层需要保留 `tp-name` 才能登记与刷新，这是直接路径中的受管理例外。 + +### 6.2 managed mount + +`tp-push-layer` / `tp-put-layer` 明确保留 `tp-name` 和必要的 `tp-layers` 状态。mounted layer 可以被查询、移动、隐藏、显示、删除和响应式刷新。 + +非参数化层重新定义后，已挂载区域按 old/new 所有权协调： + +- 新定义写入其拥有的键； +- 旧定义拥有、但新定义不再拥有的键，仅在当前值仍等于旧值时移除； +- 外部已经改写的值不会被当作旧层残留删除。 + +所有 managed mount 都携带 lifecycle metadata。即使只有单个 managed layer，只要存在 `tp-meta`，权威存储也使用 `tp-layers`；直接渲染属性和 `tp-layer-stack-at` 等 public stack query 不暴露 `tp-meta`。 + +参数化层的已挂载 entry 保存调用实参、形参表和 definition version；重新定义参数化层后，既有 managed entry 会按保存的 args 刷新。历史无 metadata 的 entry 按 legacy entry 保守处理。 + +`tp-attach-managed-layers` 扫描已经进入缓冲区的 managed storage，补齐/规范化 metadata，登记发现的层，并返回层名列表。`tp-detach-managed-layers` 移除 managed storage；KEEP-RENDERED 非 nil 时保留当前可见渲染属性为普通文本属性。 + +`tp-managed-layer-diagnostics`、`tp-managed-buffer-diagnostics` 和 `tp-managed-diagnostics` 是只读诊断入口，报告 entries、args、registry、errors 与 theme diagnostics。`tp-managed-diagnostics` 的 theme 部分报告 generation、last hook source、refresh mode、refreshed ranges 和 errors；这是 lifecycle 诊断，不是性能基准。 + +`tp-layer-transaction` 在给定范围内执行 managed stack 修改。成功返回结构化 plist，其中 `:status` 为 `ok`、`:ok` 为 t，`:result` 保留 FUNCTION 的返回值；失败时恢复事务前文本/属性快照并默认发出 `tp-layer-transaction-error`，NOERROR 非 nil 时返回结构化失败 plist。 + +## 7. `tp-text` 替换 + +- 初次应用和响应式更新都按内嵌字符串的真实属性 interval 处理，不从位置 0 采样后扩散到整段。 +- 调用者显式属性覆盖内嵌属性；显式 nil 也是有效覆盖值。 +- 未被调用者覆盖的内嵌属性按各自 interval 保留。 +- 每个 interval 算出待写属性后，`tp-set` 只覆盖这些键并保留其他目标属性，`tp-reset` 替换目标的完整属性集合，`tp-add` 则对目标已有的 face-family 与嵌套 plist 继续合并；文本内容相同和发生替换时遵守同一规则。 +- 字符串和缓冲区路径遵守相同的 per-interval 属性计算；对象的复制/原地策略仍按第 2 节执行。 + +## 8. 错误边界 + +- 未定义或无法解析的层使用 `tp-unresolved-layer` 表达。 +- 栈 API 的 NOERROR 只抑制 `tp-unresolved-layer`；参数化层 body、计算、属性结构和其他内部错误必须传播。 +- 隐藏层存储发生所有权冲突时使用 `tp-layer-conflict`。 +- transform 失败或返回非字符串、compute 失败都属于业务输出失败，必须传播。 +- watcher 属于 observer：单个 watcher 失败不会阻断 managed update；失败会记录到 `tp-reactive-observer-errors`（newest first）并输出消息。 +- 公开边界不应把内部失败转换为默认值后继续写入。 + +## 9. 隐藏层与外部直接修改 + +存在隐藏层时，`tp-layers` 保存完整 managed stack，其他直接属性是第一个可见层的渲染缓存。两类调用采用不同但明确的策略： + +- definition/reactive refresh 知道正在刷新哪个定义，也知道直接属性对应哪个可见 entry；它先把原生直接编辑协调进该可见 entry，再执行 old/new 所有权刷新，因此外部改写值不会被当作旧定义残留删除； +- 普通 stack decode/write 缺少这次 definition refresh 的所有权上下文，缓存不一致时会在写入前发出 `tp-layer-conflict`，且不修改层栈； +- 所有层都隐藏时没有可接收直接属性的可见 entry，此时出现直接属性始终发出 `tp-layer-conflict`。 + +tp 不会把外部属性收编成新的匿名层，也不会静默覆盖它。 + +## 10. 返回值现状 + +核心写 API 的返回值仍保留历史差异： + +- buffer/region `tp-set` / `tp-reset` / `tp-add`：`(START . END)`； +- 整串复制式写入：新字符串； +- buffer `tp-remove` / `tp-clear`：nil； +- stack mutator：修改的 property-run 数量； +- `tp-put-layer` / `tp-push-layer`：显式 OBJECT 或 `(START . END)`。 + +这些返回值是当前兼容契约。property-run 数量会受无关 interval 边界影响，不应被当成稳定业务标识。内部 request/result 模型已建立，但不会改变这些历史 public returns。 + +## 11. 明确不在当前完整契约内 + +以下能力仍需设计或补齐，不能据现有 API 推断： + +- overlay lifecycle（创建、移动、删除、priority 管理）； +- insert/copy/yank/stickiness 的 tp wrapper 或 managed workflow； +- mutation policy 三种组合之外的统一 read-only、silent modification、undo 策略； +- 字符串/缓冲区完全一致的搜索结果结构； +- observer 错误的清理、重试与汇总策略。 diff --git a/docs/ARCHITECTURE.md b/docs/ARCHITECTURE.md index a988dab..e2c8437 100644 --- a/docs/ARCHITECTURE.md +++ b/docs/ARCHITECTURE.md @@ -2,12 +2,17 @@ 本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。 -自 0.2.0 起，原来的单文件 tp.el 已拆分为九个分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。0.3.0 进一步收紧了模块边界：`tp-text` 处理链下沉至 tp-ops、批量更新上收至 tp-render、层栈存储编解码与匿名层机制归位 tp-layer，钩子变量从四个减少到两个。各变更的缘由见 [CHANGELOG.md](../CHANGELOG.md)。 +当前 API 的规范契约见 [API-SEMANTICS.md](API-SEMANTICS.md)；Emacs 原生 +文本属性覆盖范围、已确认问题与演进路线见 +[REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)。 + +自 0.2.0 起，原来的单文件 tp.el 已拆分为分层模块，`tp.el` 只作为总入口（`(require 'tp)` 依次加载全部模块，用户接口不变）。0.3.0 进一步收紧了模块边界：`tp-text` 处理链下沉至 tp-ops、批量更新上收至 tp-render、层栈存储编解码与匿名层机制归位 tp-layer，钩子变量从四个减少到两个。Stage 3 新增 tp-query，承载原生文本查询/change 封装与修改策略。各变更的缘由见 [CHANGELOG.md](../CHANGELOG.md)。 ## 目录 - [架构概述](#架构概述) - [模块分层](#模块分层) + - [Canonical records 与 dataflow](#canonical-records-与-dataflow) - [tp-core.el：基础工具](#tp-coreel基础工具) - [tp-reactive.el：响应式基础设施](#tp-reactiveel响应式基础设施) - [tp-layer.el：层定义、解析与层栈存储](#tp-layerel层定义解析与层栈存储) @@ -15,6 +20,7 @@ - [tp-search.el：模式匹配与搜索](#tp-searchel模式匹配与搜索) - [tp-render.el：响应式渲染引擎](#tp-renderel响应式渲染引擎) - [tp-stack.el：属性层栈操作](#tp-stackel属性层栈操作) + - [tp-query.el：原生文本查询与修改策略](#tp-queryel原生文本查询与修改策略) - [tp-palette.el：调色板数据](#tp-paletteel调色板数据) - [tp-builtins.el：内置层与辅助工具](#tp-builtinsel内置层与辅助工具) - [钩子变量：唯一许可的反向调用](#钩子变量唯一许可的反向调用) @@ -30,7 +36,7 @@ tp 采用严格的线性分层：**每个模块只允许 `require` 并调用排 ``` tp-core → tp-reactive → tp-layer → tp-ops → tp-search - → tp-render → tp-stack → tp-palette → tp-builtins + → tp-render → tp-stack → tp-query → tp-palette → tp-builtins ``` 注意加载顺序是依赖顺序的**上界**：并非每个模块都依赖它前面的全部模块。各模块实际 `require` 的 tp- 模块如下（逐一核对自源码头部）： @@ -44,6 +50,7 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search | tp-search | tp-core、tp-reactive、tp-layer、tp-ops | | tp-render | tp-core、tp-reactive、tp-layer、tp-ops、tp-search | | tp-stack | tp-core、tp-reactive、tp-layer（**不依赖 tp-ops / tp-search / tp-render**） | +| tp-query | tp-core | | tp-palette | —（不依赖任何 tp- 模块，仅 subr-x） | | tp-builtins | tp-core、tp-layer、tp-ops、tp-palette | @@ -58,6 +65,8 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search │ tp-palette.el 明/暗主题调色板数据、tp-parse-color │ │ （独立叶模块，不依赖任何 tp- 模块） │ ├────────────────────────────────────────────────────────────────┤ +│ tp-query.el 原生文本 lookup/change 封装、mutation policy │ +├────────────────────────────────────────────────────────────────┤ │ tp-stack.el 层栈操作（push/pop/move/hide/show/merge …） │ ├────────────────────────────────────────────────────────────────┤ │ tp-render.el 响应式重渲染引擎、最小差异 tp-text 编辑、 │ @@ -91,6 +100,20 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search ## 模块分层 +### Canonical records 与 dataflow + +Stage 2 canonical façade 是内部模型，不改变公开入口和历史返回值。五个记录承担模块间的规范数据边界： + +| 记录 | 所有者 | 用途 | +|------|--------|------| +| `tp--native-range` | tp-core | 目标对象的原生 `[START, END)` 范围；字符串使用 0-based，缓冲区使用原生 buffer position | +| `tp--presence` | tp-core | 区分属性缺失、present nil、present non-nil | +| `tp--request` | tp-ops | 公开重载参数解析后的规范请求：对象、范围、操作、属性/值/谓词、修改策略 | +| `tp--match` | tp-search | 搜索内部匹配结果，统一字符串与缓冲区路径 | +| `tp--result` | tp-search | 搜索内部结果载体；最终按公开 API 的历史契约适配返回 | + +数据流为：公开入口解析成 `tp--request`，tp-core 提供对象、native range、presence 与 adapter，tp-ops/tp-search/tp-stack 只在 I/O 边界按对象类型分支。内部搜索先产生 canonical `tp--match` / `tp--result`，再由公开入口保留旧返回结构；`tp-intervals` / `tp-intervals-map` 的缓冲区 relative 默认是显式保留的兼容例外。 + ### tp-core.el：基础工具 最底层模块，不依赖任何其他 tp 模块，提供区间遍历、合并引擎与调试能力。0.3.0 起 tp-core **不再持有任何可变状态**（匿名层计数器已迁至 tp-layer；仅剩 `tp-debug-mode` / `tp-debug-echo` 两个 defcustom 用户选项）。 @@ -112,7 +135,6 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search | `tp--merge-face-values` | 合并两个 face 值 | 合并引擎内部 | | `tp--merge-duplicate-keys` | 合并 plist 中的重复键 | tp--parse-args | | `tp--parse-face-list` | 解析 face 列表 | 合并引擎内部 | -| `tp--merge-string-props-into-plist` | 将字符串内嵌属性并入 plist | tp-ops 的 tp-text 处理链 | | `tp--get-nested` | 按路径获取嵌套属性值 | tp-get, tp-at | `tp-face-properties`（常量，`'(face font-lock-face mouse-face)`）定义参与 face 感知合并的属性家族。 @@ -238,11 +260,14 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search | `tp--normalize-layer-spec` | 规范化层规格（含多参数 `(LAYER ARG1 ... ARGN)`） | | `tp--build-layer-props` / `tp--layer-stack-to-list` | 旧式编解码原语（无隐藏层语义） | | `tp--stack-hidden-p` | 层 plist 是否带 `tp-hidden` 标志 | -| `tp--stack-props-to-list` | 原始属性 → 有序层列表（顶层在前，含隐藏层）。有隐藏层时 `tp-layers` 持有完整栈，直接属性只是最顶可见层的渲染缓存 | +| `tp--plist-equivalent-p` / `tp--assert-hidden-render-cache` | 普通栈解码时验证完整存储的直接渲染缓存；无刷新上下文的不一致在改写前发出 `tp-layer-conflict` | +| `tp--stack-props-to-list` | 原始属性 → 有序层列表（顶层在前，含隐藏层）。完整存储模式下 `tp-layers` 持有完整栈，直接属性只是最顶可见层的渲染缓存，并在普通解码时执行冲突检查；definition/reactive refresh 由 tp-render 在明确可见 entry 上协调外部编辑 | | `tp--stack-build-props` | 有序层列表 → 原始属性。单层栈不携带 `tp-layers`；含隐藏层时切换为"完整栈 + 渲染缓存"存储模式（全部隐藏时不渲染任何层属性） | | `tp--get-layer-by-idx-or-name` | 通过索引或名称查找层 | -钩子变量：`tp--layer-refresh-function`（定义于此，由 tp-render.el 安装为 `tp--update-layer-regions`）；`tp--layer-refresh` 是它的调用入口，层重定义后经它触发已应用区域的重渲染。 +钩子变量：`tp--layer-refresh-function`（定义于此，由 tp-render.el 安装为 +`tp--update-layer-regions`）；`tp--layer-refresh` 是它的调用入口，非参数化 +层重定义后把 old props 一并传给渲染层，触发已挂载区域的 old/new 所有权协调。 --- @@ -307,12 +332,12 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search #### 搜索和导航 | 函数 | 描述 | 依赖 | |------|------|------| -| `tp-forward` | 向前搜索 N 次并移动点；0.3.0 起接受 PREDICATE 与 NOT-CURRENT（默认保持 0.2.0 的对称 `equal` 匹配契约） | text-property-search-forward | +| `tp-forward` | 向前搜索 N 次并移动点；省略 VALUE 匹配任意直接存在值，显式 nil 精确匹配 present-nil | tp--property-search-forward | | `tp-backward` | 向后搜索 N 次并移动点（与向前语义对称，同样新增 PREDICATE/NOT-CURRENT） | tp--property-search-backward | -| `tp--property-search-backward` | 带谓词的向后搜索引擎 | text-property-search-backward | -| `tp--property-match-p` | 谓词归一化（nil/t → `equal`；函数 → `(funcall PRED VALUE PROP-VALUE)`） | - | -| `tp--string-property-matches` | 字符串路径的按段匹配收集器 | - | -| `tp-search` | 收集所有匹配区间 | tp-intervals 等 | +| `tp--property-search-forward` / `tp--property-search-backward` | 基于统一直接属性 run 的单步搜索引擎 | tp--property-matches | +| `tp--property-match-p` | 谓词归一化（函数优先；否则 `tp-any-value` 通配，其他值用 `equal`） | - | +| `tp--property-matches` | 字符串/缓冲区共用、presence-aware 的直接属性 run 收集器 | text-properties-at, next-property-change | +| `tp-search` | 收集所有 `(START END VALUE)` 匹配区间 | tp--property-matches | | `tp-search-forward` / `tp-search-backward` | **已废弃（0.3.0，make-obsolete）**：裸封装原语，nil-PREDICATE 默认语义与库内 `equal` 匹配相悖；请改用 `tp-forward` / `tp-backward`，或直接用 Emacs 原语 | text-property-search-* | #### 遍历与替换 @@ -339,10 +364,10 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search #### 重渲染 | 函数 | 描述 | 依赖 | |------|------|------| -| `tp--update-layer-regions` | 重渲染携带某层的所有文本区域（替换该层自己的属性键，保留其他来源属性），并**写穿**到 `tp-layers` 栈存储 | tp--layer-render-props, tp-search-map, tp--write-layer-through-stack-storage | -| `tp--write-layer-through-stack-storage` | 把新属性写进栈存储里该层的条目（被覆盖或被隐藏的副本也保持最新，`tp-show-layer` 后渲染当前值而非陈旧快照；值未变的段不触碰缓冲区） | tp--stack-props-to-list, tp--stack-build-props [tp-layer] | -| `tp--merge-props-into-stack-entry` | 更新栈条目的键，保留其 `tp-hidden` 标志与栈位置 | - | -| `tp--update-layer-computed` | 更新 `:compute` 计算属性（nil 值可正常传播） | tp--resolve-reactive-symbols, tp--set-layer-props | +| `tp--update-layer-regions` | 用 old/new 所有权协调重渲染已挂载区域，并**写穿**到 `tp-layers` 栈存储 | tp--layer-render-props, tp-search-map, tp--write-layer-through-stack-storage | +| `tp--write-layer-through-stack-storage` | 先按旧定义移除仍由该层拥有的键，再写入新定义；被覆盖或隐藏的副本也保持最新 | tp--stack-props-to-list, tp--stack-build-props [tp-layer] | +| `tp--reconcile-layer-props` / `tp--reconcile-layer-region` | 计算和写入 old/new 属性协调；保留不属于旧层或已被外部改写的值 | - | +| `tp--update-layer-computed` | 更新 `:compute` 计算属性（nil 可传播；错误向上抛出） | tp--store-computed-value | | `tp--layer-render-props` / `tp--layer-reactive-props` | 求取层的渲染属性 | tp-layer-props | #### 响应式文本（tp-text） @@ -424,6 +449,52 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search | `tp-add-to-layers` | 向特定层添加属性 | tp--deep-merge-plist, tp--stack-map-region | | `tp-add-to-all-layers` | 向所有层添加属性 | tp-add-to-layers | +#### Managed lifecycle（Stage 4） +| 函数/状态 | 描述 | 依赖 | +|------|------|------| +| `tp-meta` | lifecycle metadata，保存在 `tp-layers` 权威存储中；直接渲染属性和 public stack query 会剥离它 | tp--managed-render-props, tp--managed-public-layer-props | +| `tp--managed-operation-counter` | transaction/entry id 的单调计数器 | tp--managed-next-operation-id | +| `tp-attach-managed-layers` | 扫描已有 managed storage、规范化 metadata、登记发现的层并返回层名 | tp--managed-normalize-stack, tp-reactive--register-layer-buffer | +| `tp-detach-managed-layers` | 移除 managed storage；KEEP-RENDERED 时保留当前可见渲染属性 | tp--managed-detached-props | +| `tp-managed-layer-diagnostics` | 只读层诊断：entries、args、registry、buffers、errors | tp--managed-buffer-diagnostic-data | +| `tp-managed-buffer-diagnostics` | 只读缓冲区诊断 | tp--managed-buffer-diagnostic-data | +| `tp-managed-diagnostics` | 全局只读诊断，含 theme diagnostics | tp--managed-theme-diagnostics | +| `tp-layer-transaction` | managed transaction；失败恢复原文本/属性快照，默认发出 `tp-layer-transaction-error` | tp--transaction-* | + +只要 layer stack entry 携带 `tp-meta`，即使只有一个 managed layer，也使用 `tp-layers` 保存权威 stack storage。参数化 mounted entry 保存 args、arglist 与 definition-version；层重定义后通过保存的 args 刷新既有 entry。历史无 metadata entry 作为 legacy entry 保守处理。 + +--- + +### tp-query.el：原生文本查询与修改策略 + +只依赖 tp-core。提供 Stage 3/5 原生 façade：直接/effective/source-aware text lookup、overlay-aware char lookup、property change/any/not-all 封装，以及显式 modified/read-only 修改策略。overlay lifecycle（创建、移动、删除、priority 管理）不属于 tp-query。 + +#### 查询记录与 lookup +| 函数/记录 | 描述 | 依赖 | +|------|------|------| +| `tp-lookup-result` | `cl-defstruct` 结果记录：property、value、present-p、source、mode、object、position、overlay | - | +| `tp-lookup` | 按 MODE 查询属性；支持 `:text-direct`、`:text-effective`、`:text-source`、`:char`、`:char-source` | tp--lookup-direct, tp--lookup-effective, tp--lookup-char, tp--lookup-source-cell | +| `tp--lookup-direct` | 只检查 `text-properties-at` 的直接 plist，区分 explicit nil 与 absent | plist-member | +| `tp--lookup-effective` | 值使用 `get-text-property`，source 使用 text-only 解释 | tp--lookup-source-cell | +| `tp--lookup-char` | 使用 `get-char-property-and-overlay`，overlay 获胜时 source 为 `:overlay` 且记录 overlay 对象 | get-char-property-and-overlay | +| `tp--lookup-source-cell` | 按 direct → category → alias → default → absent 解释来源 | text-properties-at, symbol-plist, char-property-alias-alist, default-text-properties | +| `tp--lookup-alias-cell` | 查找 `char-property-alias-alist` 中第一个直接存在的 alias 属性 | plist-member | + +#### property change 与区域谓词 +| 函数 | 描述 | 依赖 | +|------|------|------| +| `tp-property-change` | `:direction :next` / `:previous`；传入 PROPERTY 时走 single-property change，省略时走 all-property change | next/previous-property-change, next/previous-single-property-change | +| `tp-property-any` | `text-property-any` 薄封装 | text-property-any | +| `tp-property-not-all` | `text-property-not-all` 薄封装 | text-property-not-all | + +#### 修改策略 +| 函数/宏 | 描述 | +|------|------| +| `tp--mutation-policy-modes` | 校验并归一化 `:modified` 与 `:read-only`；拒绝 `(:modified :silent :read-only :respect)` | +| `tp-with-mutation-policy` | 三种有效组合：ordinary+respect、ordinary+inhibit、silent+inhibit | + +insert/copy/yank/stickiness/narrowing/indirect buffer 均不在 tp-query 中封装，行为直接委托 Emacs 原生操作。 + --- ### tp-palette.el：调色板数据 @@ -434,6 +505,9 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search |------|------| | `define-tp-palette` | 定义调色板（重定义立即生效）；别名 `tp-define-palette` | | `tp-palette-alist` | 调色板注册表（唯一数据源） | +| `tp-theme-generation` / `tp-theme-last-*` | theme lifecycle diagnostics：generation、last hook source、refresh mode、refreshed ranges、errors | +| `tp-theme-change-hook` | `enable-theme` / `disable-theme` 后运行的 hook；palette 只负责事件检测，managed renderer 可订阅 | +| `tp--palette-after-enable-theme` / `tp--palette-after-disable-theme` | theme lifecycle advice，递增 generation 并记录来源 | | `tp-parse-color` | 解析颜色规格（支持 `("light" . "dark")` 及单边 cons） | | `tp-theme-dark-p` / `tp-theme-light-p` | 当前主题判断 | | `tp-palette-color` | 通用的主题解析取色器（0.3.0 新增的首选查询入口） | @@ -483,7 +557,7 @@ tp-core → tp-reactive → tp-layer → tp-ops → tp-search |------|------|------|------| | tp-core | —— | **无可变状态**（仅 `tp-debug-mode`/`tp-debug-echo` 两个用户选项；调试日志写入 *tp-debug* 缓冲区，由 `tp-debug-clear` 清除） | - | | tp-reactive | `tp-reactive-deps` | 变量 → 依赖层 注册表 | `tp-reactive-reset` | -| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` | `:watch` / `:compute` / `:data` 注册表 | `tp-reactive-reset` | +| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` / `tp-reactive-observer-errors` | `:watch` / `:compute` / `:data` 注册表与结构化 observer 错误 | `tp-reactive-reset` | | tp-reactive | `tp--batch-update-pending` | 批量更新队列（0.3.0 起也被 reset 清空，防止残留条目对新定义的层重放） | `tp-reactive-reset` | | tp-reactive | `tp--layer-buffers` | 层→缓冲区注册表（哈希表，0.3.0 新增） | `tp-reactive-reset`（clrhash）；单层条目随 `tp-undefine-layer`/层重定义移除；死缓冲区经 kill-buffer-hook 与惰性访问剔除 | | tp-reactive | `tp--batch-update-active` / `tp--reactive-updating` | 动态标志（let 绑定，非持久状态） | 随作用域退出 | diff --git a/docs/BENCHMARKS.md b/docs/BENCHMARKS.md new file mode 100644 index 0000000..2e48ff7 --- /dev/null +++ b/docs/BENCHMARKS.md @@ -0,0 +1,42 @@ +# Reproducible benchmark evidence + +## Command and environment + +```sh +make benchmark \ + EMACS=/Applications/Emacs.app/Contents/MacOS/Emacs \ + LOAD_EXTRA='-L /tmp/tp-elpa.Ur243x/dash-2.20.0' +``` + +- Emacs: 30.2 +- Fixed seeds: `1`, `7`, `42`, `747555` +- Reproducible generated seed: `8675309` +- Every scenario performs a correctness assertion before accepting timing. +- The full command completed successfully on 2026-07-28. + +The runner is `tp-benchmark.el`; `make benchmark` is the stable entry point. Output rows include scenario, status, fixture, seed, requested/actual size, operations, scanned/changed/refreshed counts, elapsed wall time, and GC count. + +## Representative result: seed 42 + +| Scenario | Requested / actual | Operations | Scanned | Changed | Refreshed | Elapsed (s) | GC | +| --- | ---: | ---: | ---: | ---: | ---: | ---: | ---: | +| large text | 100,000 | 2 | 100,000 | 100,000 | 0 | 0.000304 | 0 | +| large text | 1,000,000 | 2 | 1,000,000 | 1,000,000 | 0 | 0.000323 | 0 | +| fragmented intervals | 1,000 | 1 | 1,000 | 500 | 0 | 0.044254 | 0 | +| fragmented intervals | 10,000 | 1 | 10,000 | 5,000 | 0 | 0.404836 | 1 | +| fragmented intervals | 50,000 | 1 | 50,000 | 25,000 | 0 | 1.965066 | 3 | +| stack depth | 1 | 2 | 2,000 | 2,000 | 0 | 0.000909 | 0 | +| stack depth | 5 | 6 | 2,000 | 2,000 | 0 | 0.003204 | 0 | +| stack depth | 20 | 21 | 2,000 | 2,000 | 0 | 0.012905 | 0 | +| stack depth | 50 | 51 | 2,000 | 2,000 | 0 | 0.037830 | 0 | +| reactive fan-out | 1 / 1 | 1 | 1 | 1 | 1 | 0.000763 | 0 | +| reactive fan-out | 10 / 10 | 1 | 10 | 10 | 10 | 0.005469 | 0 | +| reactive fan-out | 100 / 100 | 1 | 100 | 100 | 100 | 0.051376 | 0 | +| reactive fan-out | 500 / 200 | 1 | 200 | 200 | 200 | 0.102989 | 0 | +| theme refresh | 1 / 1 | 1 | 1,000 | 0 | 1 | 0.001317 | 0 | + +The 500-buffer fan-out fixture is intentionally capped at 200 live buffers on local hardware; output reports both requested and actual counts. Theme refresh uses the v1 conservative managed-range strategy. + +## Interpretation + +These figures are advisory, not release thresholds. Fragmented interval count is the clearest scaling risk and should remain the first optimization target. Large-text lookup over one property run and deep-stack top lookup are cheap in this fixture, but those results must not be generalized to fragmented text or repeated stack mutation. diff --git a/docs/CODE-ANALYSIS.md b/docs/CODE-ANALYSIS.md index 27ee0bd..543d9c6 100644 --- a/docs/CODE-ANALYSIS.md +++ b/docs/CODE-ANALYSIS.md @@ -6,6 +6,9 @@ > tp.el 仅作总入口），并修复了大量已确认的 bug。当前架构请以 > [ARCHITECTURE.md](ARCHITECTURE.md) 为准，本次变更明细见 [CHANGELOG.md](../CHANGELOG.md)。 > 下文的调用堆栈与问题分析保留为历史分析；"文件结构"与"关键代码位置"表已更新为当前模块位置。 +> 当前 0.3.0 的 API 语义、原生兼容能力、已确认缺陷与扩展路线，请参阅 +> [REPOSITORY-AUDIT.md](REPOSITORY-AUDIT.md)；修复后的规范契约见 +> [API-SEMANTICS.md](API-SEMANTICS.md)。 本报告旨在帮助想要参与 tp.el 开发的开发者快速了解项目结构、核心功能实现、以及潜在的优化方向。 diff --git a/docs/REPOSITORY-AUDIT.md b/docs/REPOSITORY-AUDIT.md new file mode 100644 index 0000000..aec42f2 --- /dev/null +++ b/docs/REPOSITORY-AUDIT.md @@ -0,0 +1,1897 @@ +# tp 仓库系统审计与“文本属性操作替代层”能力评估 + +> 审计日期：2026-07-28 +> 审计快照：`a65d799`（tp 0.3.0） +> 结论置信度：高 +> 范围：公开 API 语义、核心实现、层栈与响应式设计、Emacs 原生语义覆盖、 +> 测试与 CI、性能风险、文档一致性，以及后续扩展路线。 + +> 实施状态（2026-07-28）：阶段 0 语义已冻结在 +> [API-SEMANTICS.md](API-SEMANTICS.md)；阶段 1 的 TP-A01～A06、TP-A10 与 +> TP-A11 已按本文路线实现回归测试和修复；阶段 2 canonical façade 已完成为 +> 内部记录/数据流模型，公开返回保持兼容；阶段 3 text-only 原生语义 façade +> 已完成；阶段 4 managed lifecycle 已完成；阶段 5 overlay-aware 查询已完成， +> overlay lifecycle 明确排除。下文的问题描述保留为审计快照证据，不代表 +> 修复后工作树的现状。 + +> 当前验收结论：按路线编号共有阶段 0～5（6 个阶段；若只统计开发阶段则为 +> 1～5 共 5 个），现已全部完成。tp 已能作为日常文本属性操作的统一高层 +> façade，并对 direct/effective/source、显式 nil、change/predicate、 +> mutation policy、managed lifecycle 和 overlay-aware lookup 给出公开契约。 +> “替代”不表示重写 Emacs 引擎：overlay lifecycle、yank/stickiness/undo +> 等底层机制继续显式委托原生 API。 + +## 0. 结论先行 + +### 0.1 直接回答 + +如果“替代所有文本属性操作”是指： + +1. 用更统一、易记的接口完成日常的属性设置、查询、删除、批量匹配； +2. 同时提供原生 API 没有的命名层、层栈、响应式属性、调色板等高层能力； + +那么 tp **已经基本具备成为首选高层工具箱的条件**。 + +如果“替代”是指： + +1. tp 的每个 API 在字符串与缓冲区上都具有稳定、可预测、统一的语义； +2. 可以覆盖或等价映射 GNU Emacs 的全部文本属性读取、写入、边界搜索、 + 插入继承、分类默认值、撤销、复制/yank、特殊属性行为； +3. 进一步覆盖 `get-char-property` 所代表的文本属性与 overlay 联合视图； +4. 现有用户可以不再理解 Emacs 原生语义而只依赖 tp； + +那么答案是 **目前不能**。 + +当前最准确的定位应当是： + +> **tp 是建立在 Emacs 原生文本属性之上的高层操作工具箱，并额外提供一套 +> 受管理的命名层、层栈与响应式渲染模型。** + +不宜在当前版本中把它描述为： + +> Emacs 全部文本属性/字符属性操作的语义等价替代品。 + +### 0.2 为什么还不能称为“完整替代” + +主要原因不是函数数量不足，而是以下四个语义问题： + +1. **公共 API 契约尚未完全收敛。** 同一函数在字符串和缓冲区上可能采用不同 + 的修改方式、坐标、返回类型与搜索结果结构。 +2. **“属性不存在”和“属性存在但值为 nil”没有被全程区分。** 这会直接破坏 + 精确查询、搜索、覆盖和删除语义。 +3. **原生文本属性模型与 tp 的受管理层模型有两个不同的所有权系统。** + `tp-set` 展开命名层后通常不保留身份，而 `tp-push-layer`/`tp-put-layer` + 会写入 `tp-name`/`tp-layers`；二者不能互换。 +4. **Emacs 的完整语义远大于“给区间写 plist”。** 分类默认值、属性别名、 + stickiness、插入继承、撤销、yank 过滤、special properties、overlay-aware + 查询等仍没有成为 tp 的明确 API 契约。 + +此外，本次审计确认了数个当前测试未覆盖的实现问题，其中至少两个会造成用户 +可见的属性错误，见[第 6 节](#6-已确认的问题与风险排序)。 + +### 0.3 三个替代层级 + +建议把“替代”拆成三个可验证层级，而不是使用一个无法验收的口号： + +| 层级 | 定义 | 当前状态 | +| --- | --- | --- | +| A. 日常操作替代 | 常见设置、读取、删除、匹配、遍历可优先使用 tp | **较强，接近可用** | +| B. 原生文本属性 API 语义替代 | 对原生读取、写入、搜索、复制、nil 值、坐标和返回值有明确等价契约 | **text-only 已达到，公开返回仍兼容历史** | +| C. 完整字符属性生态替代 | 明确覆盖 category/default/alias、stickiness、特殊属性、yank、undo、overlay-aware 查询等 | **查询边界已达到；overlay lifecycle 明确排除** | + +合理的近期目标是先完整达到 B；C 应当被设计成显式兼容层，而不是重新实现 +Emacs 的底层属性引擎。 + +--- + +## 1. 审计方法与证据边界 + +本报告使用了四类证据： + +1. **源码审计**：逐模块检查公开入口、解析器、属性合并、层栈编解码、响应式 + 注册与刷新路径。 +2. **文档交叉检查**：比较 README、函数 docstring、架构文档和 CHANGELOG。 +3. **动态验证**：运行完整编译、ERT、doctest、随机顺序测试，并对关键语义 + 编写最小批处理复现。 +4. **官方语义基线**：以 GNU Emacs Lisp Reference Manual 的 + [Text Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Text-Properties.html)、 + [Examining Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Examining-Properties.html)、 + [Changing Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Changing-Properties.html)、 + [Property Search](https://www.gnu.org/software/emacs/manual/html_node/elisp/Property-Search.html)、 + [Sticky Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Sticky-Properties.html) + 和 [Special Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Special-Properties.html) + 为比较基线。 + +报告使用以下证据标记： + +| 标记 | 含义 | +| --- | --- | +| 已确认 | 有源码路径和动态复现，或有明确测试证明 | +| 高置信推断 | 源码控制流明确，但尚未加入永久回归测试 | +| 需阈值 | 已有 benchmark 基线，但尚未固化为发布阈值 | + +本报告没有把“测试全绿”等同于“没有问题”。现有测试主要证明已经写入测试的 +行为；本次发现的问题恰好说明，缺少跨 API 等价性和状态空间测试时，固定回归 +测试无法证明语义完备性。 + +--- + +## 2. 仓库现状 + +### 2.1 模块结构 + +当前代码采用线性模块边界： + +```text +tp-core + → tp-reactive + → tp-layer + → tp-ops + → tp-search + → tp-render + → tp-stack + → tp-palette + → tp-builtins + → tp.el +``` + +职责总体清晰： + +| 模块 | 当前职责 | 审计评价 | +| --- | --- | --- | +| `tp-core.el` | 区间、plist/face 合并、底层工具 | 边界清晰，但部分“便利查询”会丢失位置信息 | +| `tp-reactive.el` | 依赖、watcher、批量队列、缓冲区注册表 | 机制完整，但生命周期依赖所有写入都经过登记入口 | +| `tp-layer.el` | 层定义、解析、展开、栈存储编码 | 是语义复杂度最高的所有者，直接应用与受管理应用混在同一解析体系 | +| `tp-ops.el` | 核心增删改查、`tp-text` | 重载较多；字符串/缓冲区契约未完全统一 | +| `tp-search.el` | 模式、搜索、导航、替换 | 功能丰富，但返回模型与 nil 查询语义分裂 | +| `tp-render.el` | 响应式重渲染、最小文本更新 | 已有差异更新意识，但层重新定义的 old/new 所有权不足 | +| `tp-stack.el` | 命名层栈操作 | 特性强；本质上是独立于原生 plist 的受管理状态机 | +| `tp-query.el` | 原生文本 lookup/change 封装、修改策略 | text-only Stage 3 与 overlay-aware Stage 5 查询已完成 | +| `tp-palette.el` | 主题色数据 | 独立性好；主题变化后的已应用结果没有完整刷新协议 | +| `tp-builtins.el` | 内置层和显示辅助 | 适合作为上层可选能力，不应决定核心属性语义 | + +模块化本身是成功的。当前最大的架构问题已经不再是“文件太大”，而是： + +> **原生属性操作、层定义展开、受管理层栈、响应式重渲染在 API 层共享了过多 +> 隐式规则，却没有共享一个完整的语义规范。** + +继续拆文件不会自动解决这个问题；首先应收敛状态所有权和公开契约。 + +### 2.2 当前质量基线 + +| 项目 | 当前结果 | +| --- | --- | +| 包版本 | 0.3.0 | +| Emacs 基线 | 28.1+ | +| CI 矩阵 | 28.1 / 29.4 / 30.1 | +| ERT | 636 个，全部通过 | +| doctest | 92 个断言，全部通过 | +| 随机顺序 ERT | 636 个，全部通过；本次种子 `747555` | +| 字节编译 | warning-as-error 下通过 | + +这说明仓库已经有良好的维护基础，尤其是模块加载、固定回归、文档示例和多版本 +兼容性方面。问题主要集中在**未被现有用例枚举到的语义组合**，不是基础工程 +完全缺失。 + +--- + +## 3. 设计上做得好的部分 + +### 3.1 `set` / `reset` / `add` 给出了有价值的高层词汇 + +README 把三者区分为： + +- `tp-set`：只覆盖指定键，保留其他键； +- `tp-reset`：完整替换区间属性； +- `tp-add`：对 face 和嵌套 plist 做合并。 + +这个词汇比直接记忆多个原生函数更容易使用，也确实表达了三个常见意图。 +尤其 `tp-add` 对 face 合并的封装，是原生 API 之上的真实增值，不是简单改名。 + +### 3.2 字符串和缓冲区共用同一组概念 + +核心 API 能处理字符串、当前缓冲区和显式缓冲区，模式/正则/搜索/层栈也尽量 +保持两类对象都可用。这是合理的产品方向。问题不是“应否统一”，而是当前统一 +只发生在函数名层面，坐标、修改性和返回值尚未完全统一。 + +### 3.3 层栈解决了原生文本属性缺少来源身份的问题 + +原生文本属性只保存当前每个字符的 plist，不记录“这个 face 是哪个业务层写入 +的”。tp 用 `tp-name` 和 `tp-layers` 保存来源与顺序，使以下操作成为可能： + +- 按名称删除某一层，而不是猜测具体属性值； +- 上移、下移、旋转、隐藏、显示； +- 保留下层并只渲染当前顶层； +- 更新被覆盖或隐藏的响应式层； +- 将多个业务状态组合在一个文本范围上。 + +这是仓库最有差异化的能力，应继续作为核心卖点。 + +### 3.4 响应式系统已经考虑了增量更新和生命周期 + +当前实现有： + +- 变量 watcher； +- 依赖注册； +- 层到缓冲区的索引； +- buffer-local 值； +- 批量更新； +- 已隐藏/埋藏层的写穿； +- `tp-text` 的最小编辑更新； +- 匿名层回收； +- 对“插入已带属性字符串绕过登记”的已知缺口给出手工跟踪入口。 + +这不是一个简单 demo。不过，这也意味着它已经是一套小型渲染系统，需要以 +状态机和生命周期的标准来测试，而不能只按几个属性函数来测试。 + +### 3.5 CI 和文档覆盖明显高于一般小型 Elisp 库 + +多版本编译、warning-as-error、完整 ERT、随机顺序和 doctest 都是有效资产。 +`docs/ARCHITECTURE.md` 也对模块职责和反向钩子边界做了明确说明。后续不应推翻 +这些基础，而应补充“语义规范”和“等价性测试”两块缺失拼图。 + +--- + +## 4. “完整替代”所需的 Emacs 语义基线 + +### 4.1 原生模型不是稳定的 interval 对象模型 + +Emacs 的基本模型是： + +- 字符串或缓冲区中的每个字符携带一个属性 plist； +- `[START, END)` 是操作范围； +- property change functions 从值变化推导边界； +- interval 是实现和检查视图，不是用户持有的稳定业务实体。 + +GNU 手册专门说明了 +[Why Text Properties are not Intervals](https://www.gnu.org/software/emacs/manual/html_node/elisp/Not-Intervals.html)。 + +这意味着 tp 可以提供 `tp-intervals` 作为便利视图，但不应把 interval 的分割 +方式当成稳定身份，也不应让公开返回值依赖内部 interval 碎片数量。 + +当前多个层栈修改函数返回“改写的 property run 数量”。这个数会随无关属性 +边界变化而变化，因此更像调试指标，不是稳定的业务结果。 + +### 4.2 读取不是简单的 `plist-get` + +原生读取可能涉及： + +1. 字符上的直接文本属性； +2. `category` 符号 plist 提供的默认值； +3. `default-text-properties`； +4. `char-property-alias-alist`； +5. 对 `get-char-property` 而言，还包括 overlay 与优先级。 + +因此以下三个问题必须明确区分： + +- 该字符是否**直接携带**属性键； +- Emacs 解析后该字符的**有效属性值**是什么； +- 这个值来自文本、category/default/alias，还是 overlay。 + +当前 tp 的特定属性读取会调用 `get-text-property`，因此会**间接继承** +category/default/alias 的有效值解析；而“全部属性”和 presence 查询使用 +`text-properties-at`，只看到直接 plist。问题不是底层能力完全缺失，而是公开 +API 没有明确命名 direct/effective/source 三种视图，也没有相应兼容性测试。 + +### 4.3 nil 是合法值，不等于缺失 + +在 plist 模型中： + +```elisp +(property nil) +``` + +与完全没有 `property` 键不是同一状态。前者可以显式遮蔽较低优先级来源。 + +因此任何完整替代 API 都必须为下列查询提供不同结果： + +1. 缺少键； +2. 存在键且值为 nil； +3. 存在键且值为非 nil； +4. 调用者没有传 VALUE，表示匹配任意值。 + +当前 tp 在若干路径中使用 `plist-get` 的真值或参数 `nil` 同时表达多个状态， +这是最需要优先消除的语义根因之一。 + +### 4.4 写属性会参与修改、撤销和 hook + +GNU Emacs 中，缓冲区文本属性变化通常会： + +- 设置 buffer modified； +- 进入 undo； +- 触发相关 modification hooks； +- 受 `read-only` 和 `inhibit-read-only` 影响。 + +`with-silent-modifications` 可以用于不应污染 modified/undo 的纯属性更新，但它 +有明确边界，不能粗暴包住真实文本修改。 + +tp 当前一些路径尊重原生行为，另一些路径通过 +[`tp-with-current-buffer`](../tp-core.el#L110-L115) 无条件绑定 +`inhibit-read-only`。如果目标是原生语义替代，这种“默认强制写入”必须成为 +显式策略，而不是辅助宏的隐藏副作用。 + +### 4.5 属性会影响未来编辑和交互 + +`front-sticky`、`rear-nonsticky` 与 `text-property-default-nonsticky` 决定新文本 +怎样继承属性；`insert-and-inherit` 与普通 `insert` 又不同。 + +此外，以下属性不是被动数据： + +- `read-only`； +- `modification-hooks`、`insert-in-front-hooks`、`insert-behind-hooks`； +- `invisible`、`display`、`composition`； +- `keymap`、`local-map`、`help-echo`； +- `field`； +- `cursor-intangible`、`cursor-sensor-functions`； +- `yank-handler`。 + +tp 可以通过通用 setter 写入这些属性，实际行为仍由 Emacs 执行；但“可以写入 +一个键”不等于“tp 已经完整建模它的读取、继承、复制、冲突和生命周期语义”。 + +### 4.6 overlay 不是文本属性，但字符属性查询会看到它 + +overlay： + +- 不随复制文本一起复制； +- 属性变化不进入 buffer modified/undo； +- 有独立的优先级、边界和 hook； +- 会被 `get-char-property`、字段和显示相关语义看到。 + +因此建议把目标写清楚： + +- “完整文本属性 façade”可以不提供 overlay 创建/移动 API； +- 但如果承诺替代 `get-char-property` 或“所有字符属性操作”，就必须提供 + overlay-aware 查询模式和明确的来源信息。 + +--- + +## 5. 当前能力矩阵 + +状态说明： + +- **较完整**：当前 API 足以承担主要工作，契约也基本清楚； +- **部分**：有入口，但存在语义缺口或对象间不一致； +- **间接**：可以写入原生键，行为由 Emacs 执行，tp 没有独立建模； +- **缺失**：没有与目标相匹配的公开能力； +- **超出当前边界**：不一定应该实现，但必须在定位中排除。 + +| 语义面 | 当前能力 | 状态 | 主要缺口 | +| --- | --- | --- | --- | +| 任意属性键写入 | `tp-set/reset/add` | 较完整 | 重载、返回值、read-only 策略仍不统一 | +| 单键增改 | `tp-set` | 较完整 | 名字与原生 `set-text-properties` 易混淆 | +| 全 plist 替换 | `tp-reset` | 较完整 | 与 `tp-text` 的属性保留说明需更精确 | +| face/嵌套 plist 合并 | `tp-add` | 较完整 | 自定义合并规则需正式规范化 | +| 单键/多键删除 | `tp-remove`、`tp-clear` | 部分 | 字符串子属性删除可留下“存在但为 nil”的键 | +| 位置读取 | `tp-at`、`tp-member`、`tp-lookup` | 已达到 Stage 3/5 | overlay lifecycle 不属于 lookup | +| 区间读取 | `tp-get`、`tp-intervals` | 部分 | `tp-get` 丢弃 nil 值；坐标模式不统一 | +| 属性汇总 | `tp-plist` | 部分 | last-value-wins，丢失属性对应的区间信息 | +| 属性边界 | `tp-intervals`、内部 map、`tp-property-change` | 已达到 text-only Stage 3 | public interval relative 默认作为兼容例外保留 | +| 搜索相等值 | `tp-forward/backward/search`、`tp-property-any/not-all` | 已达到 text-only Stage 3 | 字符串/缓冲区 public 返回仍保持历史兼容差异 | +| predicate 搜索 | `tp-forward/backward/search` | 已达到 text-only Stage 3 | public 返回仍兼容历史 | +| 模式/正则批量写入 | `tp-match-*`、`tp-regexp-*` | 较完整 | 默认绕过 read-only 的策略需显式化 | +| 字符串复制式操作 | 整串 `tp-set/reset/add` | 较完整 | 与字符串区间原地修改形成两套模型 | +| 字符串长度变化替换 | `tp-text` 可返回新字符串 | 部分 | 初次多 interval 属性合并存在错误 | +| category 默认值 | `tp-lookup :mode :text-source/:text-effective` | 已达到 text-only Stage 3 | overlay lifecycle 不参与 | +| `default-text-properties` | `tp-lookup :mode :text-source/:text-effective` | 已达到 text-only Stage 3 | overlay lifecycle 不参与 | +| property alias | `tp-lookup :mode :text-source/:text-effective` | 已达到 text-only Stage 3 | overlay lifecycle 不参与 | +| text-only / char-property 查询 | `tp-lookup` text/char modes | 已达到 Stage 3/5 | overlay 创建/移动/删除/priority 管理排除 | +| stickiness/插入继承 | 直接委托 Emacs | 已文档化并测试 | 无 tp wrapper | +| buffer modified/undo | `tp-with-mutation-policy` + Emacs 副作用 | 三种组合已文档化并测试 | 三种组合之外不承诺统一策略 | +| silent property update | `tp-with-mutation-policy` | 已达到 Stage 3 | `:silent` + `:respect` 明确拒绝 | +| kill/yank 属性处理 | 直接委托 Emacs | 已文档化并测试 | 无 tp wrapper | +| 特殊显示/交互属性 | 可通用写入，行为委托 Emacs | 已文档化 | 无 source/priority wrapper | +| narrowing | 依赖原生缓冲区 | 已文档化并测试 | - | +| indirect buffer | 依赖原生共享文本 | 已文档化并测试 | - | +| 命名层/层栈 | `define-tp`、stack API、managed lifecycle API | Stage 4 已达到 | compositional layer 仍是可选扩展 | +| 响应式重渲染 | watcher + registry + render + theme generation diagnostics | Stage 4 已达到 | benchmark 基线已记录，非发布阈值 | +| overlay 创建/移动/删除 | 无 | 明确排除 | 使用 Emacs 原生 overlay lifecycle | + +### 5.1 能否设置所有原生属性 + +多数情况下可以通过通用 plist 写入任意属性键，因此 `tp-set` 的表达力不受一个 +固定 allowlist 限制。 + +但 [`tp--builtin-text-properties`](../tp-core.el#L45-L72) 被用于禁止层名与 +原生属性名冲突。这个手工列表： + +- 不可能天然随 Emacs 新版本保持完整； +- 已缺少如 `cursor-sensor-functions` 等官方属性； +- 同时包含 `evaporate` 这类 overlay-only 概念。 + +所以它不应被视为原生属性语义的权威目录。更稳妥的做法是给 tp 层使用独立命名 +空间，或只禁止 tp 自己的保留元数据键；不要试图手工穷举 Emacs 属性名。 + +--- + +## 6. 已确认的问题与风险排序 + +### 6.1 汇总 + +| ID | 优先级 | 问题 | 证据 | 影响 | +| --- | --- | --- | --- | --- | +| TP-A01 | P0 | 初次 `tp-text` 应用会把位置 0 的内嵌属性扩散到后续 interval | 动态复现 + 源码 | 输出属性错误 | +| TP-A02 | P0/P1 | 静态层重定义不刷新；已触发刷新时旧键仍可残留 | 两组动态复现 + 源码 | 已显示内容与定义不一致 | +| TP-A03 | P1 | 显式 nil 无法覆盖 `tp-text` 内嵌属性 | 动态复现 + 源码 | nil 语义错误 | +| TP-A04 | P1 | 搜索 API 把省略 VALUE 与 VALUE=nil 混为一体，且字符串/缓冲区结果不一致 | 动态复现 + 源码 | 无法精确搜索 nil | +| TP-A05 | P1 | 字符串子属性删除可留下 `(PROPERTY nil)`，缓冲区路径则移除键 | 动态复现 + 源码 | 同一 API 两种状态 | +| TP-A06 | P1 | `NOERROR` 捕获所有内部错误 | 动态复现 + 源码 | 真实 bug 被静默吞掉 | +| TP-A07 | P1 | 直接层应用与层栈应用的身份语义分裂 | 源码 + 文档/测试 | 用户难以预测后续层操作 | +| TP-A08 | P1 | 修改性、坐标和返回值在对象/函数族之间不一致 | 源码 + 文档 | 很难成为稳定 façade | +| TP-A09 | P1 | 多处文档与实际实现矛盾 | 源码/docstring | 用户按文档编程会出错 | +| TP-A10 | P1 | 隐藏层存在时，外部直接属性编辑会被后续栈操作静默丢弃 | 动态复现 + 源码明确说明 | 用户属性数据丢失 | +| TP-A11 | P1/P2 | transform/compute 等业务计算失败后 fallback/跳过，observer 错误又无结构化报告 | 源码 | 产生貌似有效但错误或过期的输出 | +| TP-A12 | P2 | 响应式注册依赖入口完整性，插入带属性字符串需手工登记 | 源码明确承认 | 更新可能延迟或漏掉 | +| TP-A13 | P2 | 缺少全矩阵原生等价性和 CI 性能阈值 | 测试审计 | 无法证明“完整替代”与性能 SLA | + +### 6.2 TP-A01：初次 `tp-text` 多 interval 属性扩散 + +**状态：已确认。** + +[`tp--merge-string-props-into-plist`](../tp-core.el#L326-L352) 明确只读取字符串 +位置 0 的属性。初次 `tp-text` 处理路径随后把这一结果作为整个替换区域的基础 +属性；虽然部分路径又按 interval 应用属性，但位置 0 的值已经被提前合入，造成 +后续 interval 污染。 + +最小语义场景： + +```text +FINAL-TEXT: + [0,2) face=bold + [2,4) face=italic +``` + +本次批处理复现中： + +- 字符串初次应用的后半段同时得到 `bold` 与 `italic`； +- 缓冲区初次应用把 `bold` 扩散到整个替换范围。 + +而后续响应式更新已有按 interval 保留属性的专门路径 +([`tp-render.el`](../tp-render.el#L339-L427))。这说明当前同一功能的“初次应用” +和“更新应用”使用了两套不完全一致的合并引擎。 + +现有 [`tp-render-tests.el`](../tp-render-tests.el#L318-L334) 覆盖了后续响应式更新， +没有覆盖初次应用的这个状态。 + +**根因：** + +不是简单漏了一个条件，而是“字符串内嵌属性的所有者”在两个阶段不一致： + +- 一条路径把位置 0 属性提升为全区域属性； +- 另一条路径把内嵌属性视为 per-interval 数据。 + +**修复方向：** + +只保留一个 per-interval 合并入口。禁止任何初次应用路径把 position 0 的属性 +当成整串代表值。修复前先加入字符串与缓冲区两组红色回归测试。 + +### 6.3 TP-A02：层重定义存在两条独立的刷新缺陷 + +**状态：两条均已确认。** + +#### A. 静态层重定义不触发已应用区域刷新 + +静态 simple 层的定义路径只更新 `tp-layer-alist`，没有调用 +`tp--layer-refresh`（[`tp-layer.el`](../tp-layer.el#L427-L439)）。 + +复现流程： + +```elisp +(tp-layer-reset) +(define-tp audit-static () '(face bold help-echo "old")) + +;; 在临时缓冲区插入 "abc" 并 push audit-static 后： +(define-tp audit-static () '(face italic help-echo "new")) +``` + +实际： + +```text +face=bold +help-echo="old" +stack=((audit-static face bold help-echo "old")) +``` + +预期： + +```text +face=italic +help-echo="new" +stack=((audit-static face italic help-echo "new")) +``` + +因此 `face` 也完全不刷新，这与“旧键残留”不是同一个问题。 + +#### B. 已触发 refresh 时，只更新新键，不删除旧键 + +响应式层重定义会触发 refresh，但 +[`tp--merge-props-into-stack-entry`](../tp-render.el#L142-L152) +只复制旧 entry 后写入新 plist 出现的键； +[`tp--update-layer-regions`](../tp-render.el#L190-L233) +也只遍历新 props 做 `put-text-property`。 + +复现把响应式层从： + +```elisp +(face (:foreground $audit-fg) help-echo "old") +``` + +重定义为： + +```elisp +(face (:background $audit-bg)) +``` + +实际： + +```text +face=(:background "blue") +help-echo="old" +stack=((audit-reactive face (:background "blue") help-echo "old")) +``` + +预期 `help-echo` 被删除。 + +**共同根因：** + +层定义更新没有统一的生命周期协议： + +- 静态定义更新没有进入刷新路径； +- 刷新路径又只持有“新层定义”，没有完整替换“旧层 entry”。 + +**修复方向：** + +所有可刷新 managed layer 都应经过同一 old/new entry 替换路径，再从完整 stack +重建可见 plist。对于直接应用但不保留 `tp-name` 的层，应明确它是一次性模板 +展开，不承诺随定义更新。 + +### 6.4 TP-A03：显式 nil 不能覆盖内嵌属性 + +**状态：已确认。** + +[`tp--merge-embedded-props`](../tp-ops.el#L66-L84) 使用： + +```elisp +(let ((existing (plist-get result key))) + (if existing ... embedded-value)) +``` + +当调用者明确传入 `(custom nil)` 时，`plist-get` 返回 nil，代码把它误判为 +“调用者没有这个键”，最终让内嵌值覆盖显式 nil。 + +本次复现： + +```text +内嵌字符串：custom=embedded +调用属性：custom=nil +期望：custom 键存在，值为 nil +实际：custom=embedded +``` + +**修复方向：** + +凡是判断“键是否由调用者提供”必须使用 `plist-member`；`plist-get` 只用于取值。 +随后应全库搜索相同模式，而不是只修这一处。 + +### 6.5 TP-A04：VALUE=nil 无法表达精确搜索 + +**状态：已确认。** + +[`tp-search`](../tp-search.el#L904-L992) 的条件是： + +```elisp +(or (null value) + (equal prop-val value)) +``` + +因此 nil 同时表示： + +- 调用者省略 VALUE，匹配“属性存在且任意值”； +- 调用者明确传入 nil，匹配“属性存在且值为 nil”。 + +两者无法区分。 + +更严重的是 [`tp-forward`](../tp-search.el#L521-L566)： + +- 字符串路径委托给 `tp-search`，nil 是 wildcard； +- 缓冲区路径把 nil 传给 `text-property-search-forward` 并固定 predicate 为 + `equal`，语义不同； +- 字符串返回前 N 个 `(START END VALUE)` 列表； +- 缓冲区返回第 N 次搜索的 `prop-match`。 + +本次动态复现确认，同一份属性布局、同一个 nil 参数，在字符串和缓冲区路径上 +匹配到了不同区间。 + +**修复方向：** + +使用不可与合法属性值冲突的 sentinel 表示“VALUE 未提供/任意值”，例如内部 +`tp--any-value`；公共 API 可以通过显式 keyword 或拆分入口表达。所有对象路径 +应先产生同一种规范化 match 结构，再决定是否移动 point。 + +### 6.6 TP-A05：字符串子属性删除留下 nil 键 + +**状态：已确认。** + +字符串子属性删除路径会用 `plist-put` 把父属性重建为 nil，再以 +`set-text-properties` 写回，因此保留属性键、只把值设为 nil；缓冲区路径则会 +真正删除属性键。 + +本次复现中，同样的子属性删除后： + +- 字符串 `tp-member` 返回 `(face nil)`； +- 缓冲区 `tp-member` 返回 nil。 + +相关实现位于 [`tp-ops.el`](../tp-ops.el#L1050-L1072)。 + +**修复方向：** + +先定义子属性删除后父属性为空时的唯一契约： + +- 若父属性没有剩余有效内容，应移除父键； +- 若业务确实需要显式 nil，应由调用者明确请求，而不是删除操作偶然产生。 + +字符串和缓冲区必须使用同一个纯函数计算“旧值 → 新值/删除标记”，然后各自 +只负责写回。 + +### 6.7 TP-A06：`NOERROR` 吞掉层内部执行错误 + +**状态：已确认。** + +[`tp-put-layer`](../tp-stack.el#L279-L342) 的 `NOERROR` 路径使用宽泛的 +`condition-case nil ... (error ...)`。本次定义一个解析成功但求值时主动报错的 +参数化层后，`NOERROR=t` 返回 nil，内部的真实错误也被吞掉。 + +`NOERROR` 合理的语义应当仅是： + +> 找不到指定层/无法解析用户给出的层名时不报错。 + +它不应当吞掉： + +- 参数化层 body 的 bug； +- 响应式计算错误； +- 非法属性结构； +- 栈编解码不变量破坏； +- 任意其他内部异常。 + +**修复方向：** + +不要围住整个执行路径捕获 `error`。先进行可返回“not found”的窄解析，再让后续 +错误自然传播。 + +### 6.8 TP-A07：命名层有两种不兼容的应用语义 + +**状态：已确认。** + +直接属性操作中的层名解析： + +```elisp +(tp-set object 'my-layer ...) +``` + +通常展开为该层的属性，但不保存 `tp-name` +([`tp-layer.el`](../tp-layer.el#L1353-L1366))。因此它是“一次性模板展开”。 + +层栈操作： + +```elisp +(tp-push-layer object 'my-layer ...) +(tp-put-layer object ... 'my-layer ...) +``` + +会保存 `tp-name` 和 `tp-layers` +([`tp-layer.el`](../tp-layer.el#L1419-L1477))，因此是“受管理实例”。 + +这两种行为各自都可以合理，但使用同一个“应用层”词汇会让用户自然期待： + +- 后续可按层名查询或删除； +- 层重定义会更新已应用区域； +- 响应式系统能找到该层； +- 直接设置与 push 只差栈位置。 + +实际并非如此。 + +**修复方向：** + +正式命名两个概念： + +1. **展开模板**：把层定义解析成普通 plist，不保留身份，不参与生命周期； +2. **挂载层实例**：保存身份、进入层栈、可刷新、可按名操作。 + +关键不是增加包装函数，而是让文档、函数名、返回值和测试始终使用同一词汇。 + +### 6.9 TP-A08：修改性、坐标和返回值没有统一模型 + +**状态：已确认。** + +#### 修改性 + +`tp-set/reset/add`： + +- 整串字符串形式返回新字符串； +- 字符串 region 形式原地修改； +- 缓冲区原地修改。 + +层栈的大多数字符串形式又是原地修改 +([`tp-stack.el`](../tp-stack.el#L494-L524))。 + +这意味着仅从函数名或 OBJECT 类型无法判断是否修改原对象，还必须记住调用形式。 + +#### 返回值 + +当前常见返回值包括： + +- 新字符串； +- 原字符串； +- `(START . END)`； +- 被修改的 property run 数量； +- `prop-match`； +- `(START END VALUE)` 列表； +- nil； +- 层栈查询中的 union、最大深度、首个 top。 + +其中“property run 数量”不是稳定业务语义，因为无关属性边界也能改变 run 数量。 + +#### 坐标 + +字符串通常为 0-based、缓冲区为 1-based，这是原生约定，本身合理；但 +[`tp-intervals`](../tp-core.el#L117-L148) 的缓冲区结果默认又改为相对 START 的 +0-based offset，只有 `ABSOLUTE` 才返回原生坐标。一个用户从查询结果继续调用 +`tp-set` 时容易发生 off-by-one。 + +**修复方向：** + +不必强行让字符串和缓冲区使用同一坐标基数，但必须统一： + +- 默认返回 OBJECT 的原生坐标； +- 相对坐标必须通过显式选项请求； +- 查询返回值使用同一种结构； +- 原地修改与复制式转换必须能从入口名称或显式参数判断； +- 修改函数返回稳定的“是否变化/结果对象”，诊断统计另设调试入口。 + +### 6.10 TP-A09：文档和实现存在明确矛盾 + +**状态：已确认。** + +代表性例子： + +1. [`tp--resolve-props`](../tp-layer.el#L1160-L1205) docstring 说符号层名会包含 + `tp-name`，实现却明确传入 nil，不包含 `tp-name` + ([`tp-layer.el`](../tp-layer.el#L1359-L1366))。 +2. [`define-tp`](../tp-layer.el#L316-L367) 的当前使用示例仍声称直接 `tp-set` + 会得到 `tp-name`，与 README 和当前实现相反。 +3. [`tp-search-map`](../tp-search.el#L1053-L1101) docstring 说字符串长度不同时 + 会截断/部分替换，但实际实现 + [`tp--replace-match-text`](../tp-search.el#L670-L736) 会明确报错。 +4. README 宣称“统一 API 参数规范”，但同一文档同时记录了字符串复制/原地 + 修改和搜索结果结构的差异。 + +**修复方向：** + +先写机器可验证的语义表，再从该表更新 README 与 docstring。避免继续分别修补 +中英文文档和函数说明而没有共同规范。 + +### 6.11 TP-A10：隐藏层状态会静默覆盖外部直接属性编辑 + +**状态：已确认，且内部 docstring 已明确说明。** + +当任意层处于 hidden 状态时，`tp-layers` 保存完整层栈，字符的其他直接属性只是 +临时渲染表面。栈编解码文档明确说明，期间发生的原生或 tp 直接属性编辑会在 +下一次 stack operation 时被丢弃 +([`tp-layer.el`](../tp-layer.el#L1519-L1565))。 + +本次最小复现： + +1. push 一个 `face=bold` 的 managed layer； +2. hide 该层； +3. 直接写入 `help-echo="external"`； +4. show 该层。 + +show 前： + +```text +(help-echo "external" + tp-layers ((tp-hidden t face bold tp-name audit-hidden))) +``` + +show 后： + +```text +(face bold tp-name audit-hidden) +``` + +`help-echo` 无提示地消失。这不是单纯的内部实现细节，而是用户数据所有权冲突， +应当与 correctness 缺陷一起处理，不能推迟到新增高级层功能之后。 + +**修复方向：** + +阶段 0 就必须选定默认规则。最小且安全的默认是：managed hidden range 检测到 +无法归属的直接属性变化时，在下一次栈写入前明确报出冲突；若决定采用 +“收编为匿名层”或“明确覆盖”，也必须由公开契约和回归测试证明，不能静默决定。 + +### 6.12 TP-A11：业务计算与 observer 的错误边界混在一起 + +**状态：源码确认，具体产品策略待定。** + +当前： + +- transform 出错后 message 并返回原文本 + ([`tp-ops.el`](../tp-ops.el#L50-L64))； +- initial compute 出错后 message 并跳过赋值 + ([`tp-reactive.el`](../tp-reactive.el#L352-L368))； +- watcher 出错后 message 并继续 + ([`tp-reactive.el`](../tp-reactive.el#L306-L318))。 + +三者不应使用同一策略： + +- transform/compute 决定业务输出，失败后 fallback 或跳过会留下貌似有效、实际 + 错误或过期的文本，应默认传播到外层错误边界； +- watcher 如果只是 observer，隔离单个 callback 可以合理，但必须留下可查询的 + 结构化失败，而不只是易被忽略的 minibuffer message。 + +**修复方向：** + +先按“计算结果所有者”和“副作用观察者”分类，再收敛错误边界。不要为每个函数 +新增一个静默选项；默认让业务计算失败，顶层批量渲染可以汇总多个错误。 + +### 6.13 TP-A12：响应式注册表依赖入口完整性 + +**状态：源码明确承认。** + +[`tp-reactive-layer-buffers`](../tp-reactive.el#L86-L103) 已记录： + +> 插入一个已经带 `tp-name` 的 propertized string 会绕过 buffer operation 的 +> 登记路径。 + +当前补救是： + +- unknown 时进行学习性全 buffer scan； +- 用户调用 `tp-reactive-track-buffer` 手工登记。 + +这在“高层工具箱”定位下可以接受，但在“所有文本属性操作替代层”定位下不够： +用户可以通过原生 `insert`、substring、kill/yank、间接缓冲区等多种路径让属性 +进入缓冲区，注册表无法假设所有变化都经过 tp。 + +**扩展方向：** + +提供一个明确的 managed mount/attach 生命周期；不要尝试监听所有原生属性变化。 +对于外部插入的属性，提供显式 `track/attach` 和可选的 after-change 集成，并在 +文档中说明成本。 + +### 6.14 TP-A13：测试数量多，但不能证明语义完备 + +**状态：已确认。** + +现有 604 个 ERT 和 92 个 doctest 对固定回归很有价值，但缺少： + +- 与原生函数的等价性测试； +- 随机生成属性 interval 的 property-based 测试； +- `nil`、缺失、默认值、category、alias 的组合； +- 字符串/缓冲区同构场景； +- undo、modified、read-only、hook、stickiness； +- indirect buffer 和 narrowing； +- 将大缓冲区、碎片 interval、深层栈、响应式 fan-out 的性能基准固化为 CI 阈值； +- 主要交互命令的 `call-interactively` 路径； +- 调色板/主题切换后的动态视觉验证。 + +`tp-run-shuffled.el` 只是改变测试顺序，不会生成新的输入状态。它能发现全局状态 +泄漏，但不能替代属性状态空间测试。 + +--- + +## 7. API 语义专项分析 + +### 7.1 `tp-set` 的名称容易与原生 `set-text-properties` 发生反向联想 + +原生： + +- `put-text-property`：单键覆盖； +- `add-text-properties`：添加/覆盖给定键； +- `set-text-properties`：完整替换 plist。 + +tp： + +- `tp-set`：部分覆盖； +- `tp-reset`：完整替换； +- `tp-add`：深度/face 合并。 + +tp 内部体系是自洽的，但熟悉 Emacs 的用户看到 `set` 往往会联想到“完整替换”。 +无需为了原生名字机械改 API，但应在语义规范第一屏给出映射表，并让返回值也 +尽量接近相应原生操作： + +| 用户意图 | tp 当前入口 | 最接近的原生概念 | +| --- | --- | --- | +| 覆盖指定键 | `tp-set` | `add-text-properties` / 多次 `put-text-property` | +| 替换全部属性 | `tp-reset` | `set-text-properties` | +| 按自定义规则合并 | `tp-add` | `add-face-text-property` + 自定义 merge | + +### 7.2 过载解析器降低了可预测性 + +[`tp--parse-args`](../tp-ops.el#L248-L317) 支持多种调用形式，并根据： + +- 第一个参数是 string 还是 number； +- 第二个 symbol 当前是否已注册为层； +- 第三个参数是否非 nil； +- 余下参数是否看似 object； + +推断用户意图。 + +这使调用含义依赖全局层注册状态。例如同一个 symbol 在定义为层前后可能进入 +不同解析分支。参数化层还允许 flat、wrapped args 与 extra plist 组合。 + +这种便利适合 REPL，但不适合作为“完整替代层”的唯一规范入口。 + +建议： + +- 保留便利调用作为外观层； +- 内部和正式规范使用单一的 canonical request； +- 在解析完成后立刻得到明确的 `object/start/end/operation/properties/mutation` + 语义，后续模块不再重新猜测； +- 错误应在解析边界一次性报告，不在深层以 nil 继续。 + +这不要求新增多个文件，也不要求引入新依赖；一个小型、明确的数据结构或参数 +规范即可。 + +### 7.3 查询 API 应区分四种问题 + +当前 `tp-at`、`tp-member`、`tp-get`、`tp-plist`、`tp-search` 混合回答了不同问题： + +1. 某位置的全部直接属性是什么？ +2. 某直接属性键是否存在？ +3. 某属性的有效值是什么？ +4. 哪些连续区域满足某个 predicate？ + +建议把这四个问题写成正式语义，再决定是否保留现有函数名。尤其： + +- `tp-get` 不应过滤合法 nil； +- `tp-member` 应只回答 presence，不顺带承担范围读取； +- `tp-plist` 的“跨区间 last-value-wins 汇总”应明确标成 summary，而不是区域的 + 属性真相； +- 搜索结果应包含 range、value，并可选包含 source，不依赖对象类型改变结构。 + +### 7.4 层栈不是原生属性的“自然叠加” + +当前层栈只把顶层可见属性渲染到字符的直接 plist，下层放入 `tp-layers` 存储。 +这意味着它更接近图像编辑器的图层栈，而不是 CSS cascade 或多个独立属性来源 +的逐键组合。 + +例如： + +- 顶层只含 `face`； +- 下层含 `help-echo`； + +当前“只显示顶层”模型下，下层 `help-echo` 不一定继续生效。用户若把“属性层” +理解为“每个键按层优先级组合”，会得到不同预期。 + +建议正式命名两种可能模型： + +1. **exclusive layer**：只有最高可见层的整个 plist 生效；当前模型； +2. **compositional layer**：每个属性键独立按优先级求值。 + +无需立即实现第二种，但必须在文档中把第一种说清。若未来扩展第二种，也应作为 +显式模式，不能悄悄改变现有栈语义。 + +### 7.5 区域查询的标量返回值存在信息损失 + +[`tp-layer-list`](../tp-stack.el#L117-L126) 返回区域中出现过的层名 union； +[`tp-layer-count`](../tp-stack.el#L128-L136) 返回所有 run 的最大深度； +[`tp-layer-top`](../tp-stack.el#L143-L157) 返回第一个带名字的 top。 + +这些定义不是错误，但函数名看起来像在描述“整个区域的统一状态”。当区域内部 +异质时，调用者无法从标量结果判断： + +- 每个 run 是否相同； +- 某层覆盖全部区域还是只出现一次； +- top 是否统一； +- count 的分布是什么。 + +建议保留便利标量，同时提供或强化 run-aware 查询作为权威入口。标量 docstring +中应直接出现 union/max/first，而不是只写“in region”。 + +### 7.6 错误策略应只有两个边界 + +合理的错误边界： + +1. 参数解析/公共命令边界：把非法用户输入转成清晰错误； +2. 可选的用户 callback 边界：说明 callback 失败是否终止渲染。 + +当前策略混合了： + +- transform 出错后 message 并退回原文本 + ([`tp-ops.el`](../tp-ops.el#L50-L64))； +- watcher 出错后 message 并继续 + ([`tp-reactive.el`](../tp-reactive.el#L306-L318))； +- initial compute 出错后跳过 + ([`tp-reactive.el`](../tp-reactive.el#L352-L368))； +- `NOERROR` 可能吞任意内部错误； +- 普通参数错误则向上传播。 + +建议分别规定： + +- pure computation/transform 失败：默认传播，或由顶层统一汇总； +- watcher 作为副作用 observer：可以隔离，但必须记录结构化失败； +- “not found” 使用普通返回值，不用异常； +- 内部不变量错误永不被 `NOERROR` 吞掉。 + +### 7.7 `tp-text` 跨越了属性、文本替换与响应式状态三个领域 + +`tp-text` 看似一个属性键，实际上可能： + +- 替换真实字符串/缓冲区文本； +- 合并新字符串携带的属性； +- 保留旧范围属性； +- 执行 transform； +- 识别 layer identity； +- 更新响应式变量； +- 触发最小差异编辑。 + +它不是普通 text property，而是一条命令协议。把它与任意 plist 键放在同一个 +解析和合并通道中，容易造成 position 0 采样、属性所有权和重复刷新等问题。 + +建议将 `tp-text` 明确定义为“文本 replacement directive”： + +- 先计算 replacement text； +- 再按 interval 计算其内嵌属性； +- 再执行文本修改； +- 最后应用 layer/props； +- 不把 directive 自身持久化为普通文本属性。 + +公开便利语法可以不变，但内部状态机必须与普通 property merge 分离。 + +--- + +## 8. 架构与状态所有权建议 + +### 8.1 保留现有模块，先确立三个语义域 + +不建议为了本次问题再拆一批 `utils`/adapter 文件。现有模块足以承载下面三个 +清晰语义域： + +#### 域 1：原生属性 façade + +负责： + +- 字符串/缓冲区直接属性读取； +- 区间增删改； +- 搜索与 change boundary； +- 原生坐标、修改、undo/read-only 语义； +- category/default/alias/overlay-aware 的显式查询模式。 + +它不拥有层身份。 + +#### 域 2：受管理层实例 + +负责： + +- layer identity； +- stack entry； +- hide/show/move/merge； +- old/new layer contribution； +- mount/attach/detach； +- 响应式依赖和重渲染。 + +它不应把直接外部属性偷偷吸收到某个层，也不应在下次 stack operation 时静默 +丢弃用户不知道属于谁的属性。 + +#### 域 3：上层表现组件 + +负责： + +- palette； +- builtin layers； +- 主题感知； +- UI 辅助。 + +它可以使用前两个域，但不应让核心包无条件承担全部上层状态和加载成本。 + +### 8.2 明确直接属性与 managed layer 的冲突规则 + +当前 stack codec 文档已经说明：存在隐藏层时，之后的直接原生/tp 属性编辑可能 +在下次栈操作中被丢弃 +([`tp-layer.el`](../tp-layer.el#L1519-L1565))。 + +这是重要的用户数据所有权问题，不能只放在内部 docstring。 + +应选择并文档化一种策略： + +1. **严格模式（推荐默认）**：managed range 上发现无法归属的外部直接修改时， + 栈操作报出冲突； +2. **adopt 模式**：把外部直接属性采集成一个显式匿名层； +3. **overwrite 模式**：明确允许栈状态覆盖外部直接修改。 + +关键是不能静默决定。 + +### 8.3 层刷新必须做完整 entry 替换 + +层实例应保存： + +- identity； +- 当前定义或参数； +- 当前解析后的完整 props； +- hidden 状态； +- 必要时的实例参数/版本。 + +重定义/响应式更新时，先生成新 entry，再用新 entry 替换旧 entry，最后从完整 +stack 重新计算可见属性。这样自然解决旧键残留，无需猜测哪些直接属性属于旧层。 + +### 8.4 不要重新实现 Emacs 属性引擎 + +完整替代的正确方向不是自己模拟： + +- undo； +- stickiness； +- special property behavior； +- overlay priority； +- font-lock； +- field motion。 + +这些应继续交给 Emacs。tp 的职责是： + +- 提供完整、显式、可组合的 façade； +- 不破坏原生副作用； +- 对不支持或不建模的部分给出逃生口； +- 用等价性测试证明委托正确。 + +--- + +## 9. 性能与可扩展性分析 + +### 9.1 当前值得保留的优化 + +- layer → buffer 注册表避免每次都扫描 `buffer-list`； +- unknown 状态与 known-empty 分开； +- kill-buffer 清理； +- property interval 遍历； +- `tp-text` 更新尝试做最小文本差异； +- 批量响应式刷新； +- 避免相同值重复 `put-text-property`。 + +### 9.2 主要性能风险 + +以下风险已有可复现 benchmark 基线，但仍不应把单机耗时直接当成发布阈值： + +| 场景 | 风险来源 | 已记录指标 | +| --- | --- | --- | +| 大缓冲区、高 interval 碎片 | 多次 `next-property-change` 与 plist 复制 | `large-text` 与 `fragmented` rows | +| 层多且频繁 move/hide/show | 每 run 解码、重建完整 stack | `stack-depth` rows | +| 响应式 fan-out | watcher × layer × buffer | `reactive-fanout` rows | +| unknown layer | `buffer-list` 学习性扫描 | 尚未单独拆出 | +| `tp-text` 长文本变化 | 差异计算、删除插入、marker/undo | `large-text` rows | +| 匿名层 | 注册表增长和 GC 扫描 | 尚未单独拆出 | +| palette/theme | 重新解析颜色和重渲染 | `theme-managed-refresh` rows | + +`make benchmark` 在 Emacs 30.2 上完成固定 seeds `1`、`7`、`42`、`747555` +以及可复现 generated seed `8675309`。完整记录见 `docs/BENCHMARKS.md`。 +代表性 seed 42 结果： + +| Scenario | Requested / actual | Operations | Scanned | Changed | Refreshed | Elapsed (s) | +| --- | ---: | ---: | ---: | ---: | ---: | ---: | +| large text | 100,000 | 2 | 100,000 | 100,000 | 0 | 0.000302 | +| large text | 1,000,000 | 2 | 1,000,000 | 1,000,000 | 0 | 0.000318 | +| fragmented intervals | 1,000 | 1 | 1,000 | 500 | 0 | 0.047154 | +| fragmented intervals | 10,000 | 1 | 10,000 | 5,000 | 0 | 0.514766 | +| fragmented intervals | 50,000 | 1 | 50,000 | 25,000 | 0 | 2.769766 | +| stack depth | 1 | 2 | 2,000 | 2,000 | 0 | 0.000892 | +| stack depth | 5 | 6 | 2,000 | 2,000 | 0 | 0.003121 | +| stack depth | 20 | 21 | 2,000 | 2,000 | 0 | 0.012660 | +| stack depth | 50 | 51 | 2,000 | 2,000 | 0 | 0.039089 | +| reactive fan-out | 1 / 1 | 1 | 1 | 1 | 1 | 0.001139 | +| reactive fan-out | 10 / 10 | 1 | 10 | 10 | 10 | 0.008153 | +| reactive fan-out | 100 / 100 | 1 | 100 | 100 | 100 | 0.064352 | +| reactive fan-out | 500 / 200 | 1 | 200 | 200 | 200 | 0.127140 | +| theme refresh | 1 / 1 | 1 | 1,000 | 0 | 1 | 0.001691 | + +### 9.3 返回“修改 run 数”会诱导错误优化 + +run 数受无关属性边界影响，既不是修改字符数，也不是修改业务对象数。如果公开 +返回这个值，用户可能把它当成稳定统计或用于控制流。 + +建议： + +- 公开返回 `changed-p` 或结果对象； +- debug/benchmark API 可返回 `runs-visited/runs-written/chars-covered`； +- 不把实现碎片结构暴露成业务保证。 + +### 9.4 `dash` 依赖可以作为低优先级简化项 + +当前 `dash` 主要用于少量 list 操作，很多可以由 `seq`/`cl-lib` 表达。移除依赖 +可能降低安装摩擦，但不是当前语义问题的根因。 + +只有在： + +- 能减少公开安装复杂度； +- 不引入自制 helper 堆栈； +- 完整测试仍通过； + +时才值得处理。优先级应低于 correctness 和 API contract。 + +--- + +## 10. 测试策略升级 + +### 10.1 第一层：为已确认问题补红色回归 + +必须先加入： + +1. `tp-text` 初次应用保留多个内嵌 property interval； +2. 字符串与缓冲区各一组； +3. 显式 nil 覆盖内嵌非 nil； +4. 静态层重定义触发 managed region 刷新； +5. 已触发刷新时删除旧层属性键； +6. `NOERROR` 只吞 unresolved layer，不吞 layer body error； +7. 字符串和缓冲区子属性删除得到相同 presence； +8. 精确搜索 nil 与 wildcard 是两种调用； +9. hidden managed range 上的外部直接编辑不会静默丢失； +10. transform/compute 与 watcher 分别遵守其错误边界； +11. search-map docstring 与实际长度规则一致。 + +### 10.2 第二层：原生等价性测试 + +对 façade 中承诺等价的操作，使用同一随机输入分别执行： + +```text +native primitive +vs. +tp canonical API +``` + +比较： + +- 文本内容； +- `equal-including-properties`； +- 每个 change boundary； +- property presence 与 value； +- buffer modified； +- undo 后内容和属性； +- point/marker； +- 错误类型。 + +建议覆盖： + +- 空区间、单字符、对象末尾； +- 相邻同值/不同值 interval； +- nil 值与缺失； +- 多种 Lisp 值； +- narrowing； +- read-only； +- sticky boundaries； +- category/default/alias； +- indirect buffer。 + +### 10.3 第三层：状态机测试 managed layers + +随机生成操作序列： + +```text +push → put → hide → redefine → show → move → external edit +→ reactive update → delete → flatten +``` + +每一步验证不变量： + +- 每个 stack entry 身份唯一/顺序正确； +- hidden entry 不泄漏到 rendered plist； +- show 后得到最新定义； +- 删除层不会删除其他来源属性； +- encode/decode round-trip； +- 同一操作重复执行幂等； +- 不相关区域不变化。 + +### 10.4 第四层：性能回归 + +性能基准不应只给一次绝对耗时。建议固定： + +- Emacs 主版本； +- 文本长度； +- property run 数； +- 层数； +- buffer 数； +- 响应式依赖 fan-out； +- 重复次数和 GC 策略。 + +记录斜率和阈值，例如： + +- 10 倍 run 数不应出现 100 倍增长； +- 更新已知单 buffer 层时不得扫描全部 buffer； +- 无变化刷新不得写入属性或改变 modified flag。 + +### 10.5 交互与视觉验证 + +为交互命令增加少量 `call-interactively` 路径，验证 prefix、region、current buffer +和错误消息。palette/display/theme 相关能力应增加 GUI Emacs 的可重复截图或状态 +检查，尤其是主题切换后已应用层是否刷新。 + +--- + +## 11. 分阶段实施路线 + +### 阶段 0：冻结目标语义，不新增大功能 + +产出一份短小、可测试的 `API-SEMANTICS.md`，至少规定： + +- 对象和坐标； +- 字符串复制/原地修改； +- buffer modified/undo/read-only； +- presence 与 nil； +- wildcard sentinel； +- 返回结构； +- 直接模板展开 vs managed mount； +- 错误传播； +- tp-text replacement； +- 外部属性与层栈冲突。 + +停止条件：每个公开核心函数都能映射到该规范中的一条操作语义。 + +### 阶段 1：修复 P0/P1 正确性问题 + +顺序： + +1. 为 TP-A01～A06 和 TP-A10 写失败测试； +2. 合并 `tp-text` 初次/更新的 per-interval 属性算法； +3. 全库用 presence-aware 判断替换真值判断； +4. 引入 internal wildcard sentinel； +5. 层 entry 使用完整替换； +6. 收窄 `NOERROR`； +7. 落实 managed range 外部编辑的唯一默认冲突策略； +8. 区分业务计算失败与 observer 失败； +9. 同步 docstring、README 和 doctest。 + +停止条件：回归测试全绿，现有 604 ERT/92 doctest 不退化。 + +### 阶段 2：建立 canonical façade + +状态：已完成（内部模型）。公开入口和历史返回值保持兼容。 + +不要先追求更多便利重载。先保证内部存在唯一规范路径： + +```text +request + = object + + native range + + operation + + properties/value/predicate + + mutation policy + + error/read-only policy +``` + +现有 `tp-set/reset/add/...` 可以继续作为外观入口，但都解析到同一规范路径。 + +停止条件： + +- [x] 字符串与缓冲区的等价场景只在 I/O 边界分支； +- [x] 查询内部结果结构不再随对象类型改变；公开返回保持历史兼容； +- [x] 内部 canonical range 使用原生坐标；`tp-intervals` / `tp-intervals-map` 的缓冲区 relative 默认是保留的公开兼容例外； +- [x] “是否原地修改”可从公开调用清楚判断。 + +### 阶段 3：补齐原生文本属性语义 + +状态：已完成（text-only）。overlay-aware 字符属性查询见阶段 5。 + +按价值从高到低： + +1. [x] presence-aware exact nil； +2. [x] next/previous single/all property change； +3. [x] `text-property-any` / `not-all` / predicate search 对齐； +4. [x] direct vs effective lookup； +5. [x] category/default/alias 有效值委托成为明确且经过测试的 lookup 契约； +6. [x] read-only、modified、undo 和 silent modification 的三种有效策略； +7. [x] stickiness 与 insert 行为直接委托 Emacs，无 tp wrapper； +8. [x] copy/insert/kill/yank 属性保留与过滤直接委托 Emacs，无 tp wrapper； +9. [x] narrowing 与 indirect buffer 坐标/共享文本行为通过原生等价性测试。 + +停止条件：与选定 GNU Emacs 基线的原生等价性测试通过。 + +### 阶段 4：完善 managed layer 生命周期 + +状态：已完成。 + +建议扩展： + +- [x] 显式 managed layer attach/detach； +- [x] 层实例参数和版本； +- [x] old/new entry 全量替换与参数化 args refresh； +- [x] 已选外部编辑冲突策略在 push/hide/show/merge 全路径保持一致； +- [x] 单 managed layer 使用 `tp-layers` 保存 authoritative `tp-meta`，direct rendered/public stack query 不暴露 `tp-meta`； +- [x] 插入带层字符串后的显式 attach； +- [x] theme generation 与 enable/disable conservative refresh diagnostics； +- [x] registry 诊断与泄漏检查入口； +- [x] layer transaction 的结构化成功/失败和 rollback 报告； +- [ ] compositional layer 作为可选扩展，未纳入当前完成条件。 + +停止条件：随机操作序列下 stack/render/registry 不变量持续成立。 + +### 阶段 5：可选的字符属性兼容层 + +状态：已完成（lookup）。overlay lifecycle 明确排除。 + +若产品确实要使用“所有字符属性操作”定位，再增加： + +- [x] text-only 与 overlay-aware lookup 模式； +- [x] source-aware result，overlay 获胜时报告 `:overlay` 与 overlay identity； +- [x] overlay priority/change boundary 委托 Emacs `get-char-property-and-overlay`； +- [x] fields、buttons、display 等特殊属性行为委托 Emacs，不提供高层 wrapper。 + +不建议把 overlay 的创建/移动/删除硬塞进现有文本属性函数；应保持清晰边界。 + +停止条件：文档明确哪些语义由 tp 提供，哪些委托 Emacs，哪些刻意排除。 + +--- + +## 12. 可拓展方向 + +以下扩展建立在前述 correctness 与 contract 完成之后。 + +### 12.1 语义查询层 + +可提供： + +- direct/effective/source-aware property query； +- overlay-aware 可选模式； +- 区域一致性判断，例如“整个区域是否同值”； +- run-aware layer snapshot； +- 属性来源解释器：某个最终 face 来自哪个层/category/overlay。 + +这会比再增加几个重载 setter 更能支持调试和复杂 UI。 + +### 12.2 compositional layer + +在现有 exclusive stack 之外，可增加按属性键独立合成的模式： + +```text +top layer: face +middle layer: help-echo +bottom layer: keymap +``` + +最终三个键都可生效，同键才按优先级覆盖。它适合： + +- 语法 + 诊断 + 交互提示并存； +- hover/click/face 分属不同业务来源； +- 响应式状态只更新自己拥有的键。 + +必须通过显式 layer mode 启用，以免改变现有语义。 + +### 12.3 transaction 与冲突检测 + +对复杂 UI，允许在一次事务中： + +- 读取当前 stack version； +- 修改多个层； +- 一次重建； +- 收集 changed ranges； +- 失败时不留下半更新状态。 + +冲突检测可发现原生外部修改，避免下次 stack operation 静默覆盖。 + +### 12.4 增量索引和诊断 + +暴露只读诊断： + +- 某层登记了哪些 buffer； +- 某 buffer 有哪些 managed layer； +- 某层依赖哪些变量； +- 最近一次更新访问/写入多少 run； +- 未追踪但扫描发现了哪些层； +- 匿名层为何仍存活。 + +这能把响应式问题从“猜”变为可观察。 + +### 12.5 theme-aware 生命周期 + +调色板当前在解析颜色时读取 frame 的主题类型 +([`tp-parse-color`](../tp-palette.el#L256-L302))，但静态已应用结果不会自然随 +主题变化。 +可以引入： + +- theme generation/version； +- enable/disable-theme hook 后批量失效； +- 只重渲染真正依赖 palette 的层； +- theme change 的视觉回归。 + +### 12.6 与 font-lock/jit-lock 的协作 + +对于大缓冲区，主动给整段文本写 face 不一定是最佳方案。可探索： + +- 层定义生成 font-lock rule； +- jit-lock 按可见范围物化； +- tp 管理来源身份和规则，Emacs 管理惰性字体化； +- 明确 `face` 与 `font-lock-face` 的优先级和清理策略。 + +这适合语法、诊断等长文档场景，但需要单独的小型验证，不应直接扩展全库。 + +### 12.7 可选核心加载 + +`require 'tp` 当前加载 palette/builtins。未来若安装时间或最小依赖成为真实问题， +可以提供： + +- 核心 façade； +- managed layers/reactive； +- palette/builtins； + +三个明确 feature 入口。只有在有启动性能或依赖数据支持时再做，不为拆分而拆分。 + +--- + +## 13. 推荐的产品定位与文案 + +### 当前版本推荐 + +> tp 为 GNU Emacs 字符串和缓冲区提供高层文本属性操作 API，并在原生属性之上 +> 增加命名层栈、响应式属性、批量匹配和调色板能力。它覆盖常见属性工作流，但 +> category/default/alias、stickiness、undo、yank、special properties 和 +> overlays 的底层行为仍由 Emacs 执行，其中部分尚未成为 tp 的显式 API 契约。 + +### 达到阶段 3 后可使用 + +> tp 是 GNU Emacs 文本属性操作的完整高层 façade：常见原生读取、写入、搜索、 +> 复制和编辑语义均有明确映射，同时可选择受管理层栈和响应式扩展。 + +### 不建议使用 + +> tp 完全替代 Emacs 的所有文本属性和字符属性系统。 + +除非 overlay-aware、category/default/alias、stickiness、undo/yank 等都有明确 +覆盖矩阵和等价性测试，否则这句话无法被验证。 + +--- + +## 14. “可以宣称完整替代”的验收清单 + +只有同时满足以下条件，才建议宣称“完整文本属性操作替代层”： + +### 核心契约 + +- [x] 字符串/缓冲区的修改性在公开入口上可预测； +- [x] 默认坐标是对象原生坐标（`tp-intervals` / `tp-intervals-map` 的 relative 默认为公开兼容例外）； +- [x] 所有 text-only 查询区分缺失与显式 nil； +- [x] wildcard 与 VALUE=nil 不复用同一个参数状态； +- [x] 内部查询结果结构不随对象类型改变；部分 public returns 保持历史兼容； +- [x] Stage 1 错误传播与 NOERROR 范围有规范； +- [x] read-only/modified/undo 的三种 mutation policy 组合有测试保证。 + +### 原生覆盖 + +- [x] put/add/set/remove/remove-list/clear 有明确映射； +- [x] text-properties-at/get-text-property 有明确映射； +- [x] property change/search 家族有明确映射； +- [x] category/default/alias 有 direct/effective 区分； +- [x] get-char-property / get-char-property-and-overlay 查询有明确映射； +- [x] stickiness 与插入继承有文档和测试； +- [x] copy/substring/insert/kill/yank 有文档和测试； +- [x] special properties 明确委托给 Emacs，不被 tp 破坏； +- [x] narrowing/indirect buffer 行为通过测试。 + +### managed layers + +- [x] 直接模板展开和 managed layer 实例名称不同、行为不同； +- [x] 层重定义能删除旧贡献； +- [x] hidden/buried layer 始终保存最新 entry； +- [x] 外部直接属性修改不会被静默丢失； +- [x] 插入 propertized string 后的 attach/track 行为明确； +- [x] 参数化 mounted layer args/version refresh 通过测试； +- [x] transaction success/failure rollback 与 diagnostics 通过测试； +- [x] theme generation diagnostics 通过测试。 + +### 工程证据 + +- [x] 原生等价性测试覆盖选定 Emacs 版本； +- [x] 性能基准覆盖大文本、碎片 interval、深层栈和 fan-out（结果为 advisory baseline，不是发布阈值）； +- [x] 中英文 README、docstring、doctest 来自同一语义规范； +- [ ] CI 全绿且 warning 为零。 + +--- + +## 15. 最终优先级 + +### 立即处理 + +1. TP-A01：`tp-text` 初次多 interval 属性扩散； +2. TP-A10：阻止 managed hidden range 静默丢弃外部直接属性； +3. TP-A02：静态层重定义与层刷新 old/new 所有权； +4. TP-A03/A04/A05：presence、nil、wildcard、删除状态统一； +5. TP-A06：收窄 `NOERROR`； +6. TP-A11：收敛业务计算与 observer 错误边界； +7. 修复已确认 docstring/实现矛盾。 + +### 下一版本的设计重点 + +1. CI/WERROR/full-suite release evidence 汇总； +2. 可选 compositional layer 的小型验证； +3. theme refresh 的真实依赖定向优化； +4. 将 benchmark advisory baseline 转为 CI 阈值； +5. overlay lifecycle 是否继续排除的长期产品边界复审。 + +### 在语义收敛后再扩展 + +1. compositional layers； +2. transaction/冲突检测； +3. overlay-aware/source-aware 查询； +4. theme-aware 刷新； +5. font-lock/jit-lock 集成； +6. 性能与诊断工具； +7. 可选核心加载。 + +--- + +## 16. 验证记录 + +本次审计在 Emacs 30.2 上完成以下验证： + +```text +compile-all（WERROR=t） 通过 +ERT 604/604 通过 +doctest 92/92 通过 +benchmark 通过，fixed seeds=1/7/42/747555，generated seed=8675309 +shuffled ERT 604/604 通过，seed=747555 +``` + +测试使用仓库 Makefile 和单独加载的 dash 2.20.0。所有动态问题复现都在同一代码 +快照 `a65d799` 上执行。 + +本报告的结论边界是： + +- “已有测试全绿”是已确认事实； +- TP-A01～A06、TP-A10 和 TP-A11 已有回归测试覆盖； +- 性能部分记录 advisory baseline，没有把单机耗时声明为发布阈值； +- overlay 是否进入产品范围是定位决策，但 overlay-aware 查询是任何“字符属性 + 完整替代”声明不可回避的边界。 + +## 17. 官方参考 + +- [GNU Emacs Lisp Reference Manual: Text Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Text-Properties.html) +- [Examining Text Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Examining-Properties.html) +- [Changing Text Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Changing-Properties.html) +- [Text Property Search Functions](https://www.gnu.org/software/emacs/manual/html_node/elisp/Property-Search.html) +- [Why Text Properties are not Intervals](https://www.gnu.org/software/emacs/manual/html_node/elisp/Not-Intervals.html) +- [Stickiness of Text Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Sticky-Properties.html) +- [Properties with Special Meanings](https://www.gnu.org/software/emacs/manual/html_node/elisp/Special-Properties.html) +- [Fields](https://www.gnu.org/software/emacs/manual/html_node/elisp/Fields.html) +- [Yanking](https://www.gnu.org/software/emacs/manual/html_node/elisp/Yanking.html) +- [Insertion](https://www.gnu.org/software/emacs/manual/html_node/elisp/Insertion.html) +- [Narrowing](https://www.gnu.org/software/emacs/manual/html_node/elisp/Narrowing.html) +- [Indirect Buffers](https://www.gnu.org/software/emacs/manual/html_node/elisp/Indirect-Buffers.html) +- [Overlay Properties](https://www.gnu.org/software/emacs/manual/html_node/elisp/Overlay-Properties.html) + +## 18. 最小动态复现 + +以下表达式均在仓库根目录、Emacs 30.2、dash 2.20.0、快照 `a65d799` 上复核。 +通用命令为： + +```sh +EMACS=/Applications/Emacs.app/Contents/MacOS/Emacs +DASH=/path/to/dash-2.20.0 +"$EMACS" -Q --batch -L . -L "$DASH" -l tp.el --eval '' +``` + +将下面每个完整表达式作为 `--eval` 的参数即可。使用其他受支持 Emacs 版本时， +应同时记录版本和输出。 + +### 18.1 TP-A01：初次 `tp-text` 多 interval 污染 + +```elisp +(let* ((payload + (concat + (propertize "AB" (quote face) (quote bold)) + (propertize "CD" (quote face) (quote italic)))) + (result (tp-set "xxxx" (quote tp-text) payload))) + (princ + (format "string: p0=%S p2=%S\n" + (get-text-property 0 (quote face) result) + (get-text-property 2 (quote face) result))) + (with-temp-buffer + (insert "xxxx") + (tp-set 1 5 (list (quote tp-text) payload)) + (princ + (format "buffer: p1=%S p3=%S\n" + (get-text-property 1 (quote face)) + (get-text-property 3 (quote face)))))) +``` + +实际： + +```text +string: p0=bold p2=(bold italic) +buffer: p1=bold p3=bold +``` + +预期后半段只为 `italic`。 + +### 18.2 TP-A02-A：静态层重定义不刷新 + +```elisp +(progn + (tp-layer-reset) + (define-tp audit-static () + (quote (face bold help-echo "old"))) + (with-temp-buffer + (insert "abc") + (tp-push-layer 1 4 (quote audit-static)) + (define-tp audit-static () + (quote (face italic help-echo "new"))) + (princ + (format "face=%S help=%S stack=%S\n" + (get-text-property 1 (quote face)) + (get-text-property 1 (quote help-echo)) + (tp-layer-stack-at 1))))) +``` + +实际： + +```text +face=bold help="old" +stack=((audit-static face bold help-echo "old")) +``` + +### 18.3 TP-A02-B：已触发 refresh 仍残留旧键 + +```elisp +(progn + (tp-layer-reset) + (defvar audit-fg "red") + (defvar audit-bg "blue") + (define-tp audit-reactive () + :props (quote + (face (:foreground $audit-fg) + help-echo "old"))) + (with-temp-buffer + (insert "abc") + (tp-push-layer 1 4 (quote audit-reactive)) + (define-tp audit-reactive () + :props (quote (face (:background $audit-bg)))) + (princ + (format "face=%S help=%S stack=%S\n" + (get-text-property 1 (quote face)) + (get-text-property 1 (quote help-echo)) + (tp-layer-stack-at 1))))) +``` + +实际： + +```text +face=(:background "blue") help="old" +stack=((audit-reactive face (:background "blue") help-echo "old")) +``` + +预期 stack 和直接属性中都不再存在 `help-echo`。 + +### 18.4 TP-A03：显式 nil 被内嵌值覆盖 + +```elisp +(let* ((payload + (propertize "X" (quote custom) (quote embedded))) + (result + (tp-set "x" + (quote tp-text) payload + (quote custom) nil))) + (princ + (format "member=%S props=%S\n" + (tp-member 0 (quote custom) result) + (text-properties-at 0 result)))) +``` + +实际： + +```text +member=(custom embedded) +props=(custom embedded tp-text #("X" 0 1 (custom embedded))) +``` + +预期 `member=(custom nil)`。 + +### 18.5 TP-A04：nil 搜索在字符串与缓冲区中不同 + +```elisp +(let ((s (copy-sequence "abc"))) + (put-text-property 0 1 (quote p) (quote x) s) + (put-text-property 2 3 (quote p) nil s) + (princ + (format "string=%S\n" + (tp-forward (quote p) nil s 1))) + (with-temp-buffer + (insert "abc") + (put-text-property 1 2 (quote p) (quote x)) + (put-text-property 3 4 (quote p) nil) + (goto-char 1) + (let ((match + (tp-forward (quote p) nil (current-buffer) 1))) + (princ + (format + "buffer=%S\n" + (and match + (list (prop-match-beginning match) + (prop-match-end match) + (prop-match-value match)))))))) +``` + +实际： + +```text +string=((0 1 x)) +buffer=(2 4 nil) +``` + +字符串路径把 nil 当作 wildcard，缓冲区路径按 nil 值搜索，并把“缺失”和 +“显式 nil”的相邻范围合并为一个有效值为 nil 的 match。 + +### 18.6 TP-A05：子属性删除后的 presence 不同 + +```elisp +(let* ((s + (propertize "x" + (quote face) + (quote (:underline t)))) + (result + (tp-remove s (quote face) :underline))) + (princ + (format "string=%S props=%S\n" + (tp-member 0 (quote face) result) + (text-properties-at 0 result))) + (with-temp-buffer + (insert + (propertize "x" + (quote face) + (quote (:underline t)))) + (tp-remove 1 2 (quote (face :underline))) + (princ + (format "buffer=%S props=%S\n" + (tp-member 1 (quote face)) + (text-properties-at 1))))) +``` + +实际： + +```text +string=(face nil) props=(face nil) +buffer=nil props=nil +``` + +### 18.7 TP-A06：`NOERROR` 吞掉层 body 错误 + +```elisp +(progn + (define-tp audit-boom (x) + (error "audit boom %S" x)) + (let ((s (copy-sequence "x"))) + (princ + (format "result=%S props=%S\n" + (tp-push-layer + s (quote (audit-boom 1)) t) + (text-properties-at 0 s))))) +``` + +实际： + +```text +result=nil props=nil +``` + +关闭 `NOERROR` 时同一层 body 会正常抛出 `audit boom 1`。 + +### 18.8 TP-A10：外部直接属性被后续栈操作丢弃 + +```elisp +(progn + (tp-layer-reset) + (define-tp audit-hidden () + (quote (face bold))) + (let ((s (copy-sequence "x"))) + (tp-push-layer s (quote audit-hidden)) + (tp-hide-layer s (quote audit-hidden)) + (put-text-property + 0 1 (quote help-echo) "external" s) + (princ + (format "before=%S\n" + (text-properties-at 0 s))) + (tp-show-layer s (quote audit-hidden)) + (princ + (format "after=%S\n" + (text-properties-at 0 s))))) +``` + +实际： + +```text +before=(help-echo "external" + tp-layers ((tp-hidden t face bold tp-name audit-hidden))) +after=(face bold tp-name audit-hidden) +``` + +`help-echo` 在 `tp-show-layer` 后无提示消失。 diff --git a/docs/reactive-text-properties-en.md b/docs/reactive-text-properties-en.md index b27e949..247f6ca 100644 --- a/docs/reactive-text-properties-en.md +++ b/docs/reactive-text-properties-en.md @@ -488,7 +488,8 @@ The transform function: - Receives the raw `tp-text` string value - Returns the transformed string for display - Is applied both on initial display and reactive updates -- Errors in transform functions are caught and logged +- Must return a string; errors and non-string results propagate rather + than leaving stale output visible > 📖 **For more optimization features like batched updates and debug mode, see [Reactive System Optimization](reactive-optimization-en.md)** diff --git a/docs/reactive-text-properties.md b/docs/reactive-text-properties.md index 04a63b8..313c9ca 100644 --- a/docs/reactive-text-properties.md +++ b/docs/reactive-text-properties.md @@ -488,7 +488,7 @@ tp.el 的响应式系统借鉴了 Vue 的 API，提供了三个强大的关键 - 接收原始的 `tp-text` 字符串值 - 返回用于显示的转换后字符串 - 在初始显示和响应式更新时都会应用 -- 转换函数中的错误会被捕获并记录 +- 必须返回字符串；错误或非字符串返回值会向上传播，避免继续显示陈旧结果 > 📖 **更多优化功能如批量更新和调试模式，请参阅 [响应式系统优化文档](reactive-optimization.md)** diff --git a/postmortem/2026-07-28-api-semantics-phase-1.md b/postmortem/2026-07-28-api-semantics-phase-1.md new file mode 100644 index 0000000..eabdf0e --- /dev/null +++ b/postmortem/2026-07-28-api-semantics-phase-1.md @@ -0,0 +1,66 @@ +# API 语义收敛阶段 1：属性所有权必须先于便利重载 + +## 背景 + +仓库审计发现的错误并非彼此独立的条件遗漏。`tp-text` 属性扩散、层重定义残留、显式 nil 丢失、搜索 nil 分裂、隐藏层覆盖外部编辑，都来自同一个更深的问题： + +> 调用者、内嵌字符串、普通 Emacs 属性、层定义和 managed stack 对同一属性键的所有权没有统一表达。 + +继续为每个入口增加特殊分支会扩大语义分裂，因此本阶段先冻结 `docs/API-SEMANTICS.md`，再在拥有状态的层修复。 + +## 决策 + +### 1. presence 是数据，不是真值 + +属性缺失与 present-nil 必须使用 `plist-member` 一类 presence-aware 判断区分。搜索中 VALUE 省略不能再借用 nil 表达，因而增加唯一哨兵 `tp-any-value`。选择唯一对象而不是某个普通符号，是为了避免与合法属性值冲突。 + +### 2. `tp-text` 的属性所有者是 interval + +内嵌字符串的位置 0 不能代表整串。初次应用与响应式更新都按每个真实 property interval 计算，外部 props 在每段上覆盖内嵌 props，显式 nil 也参与覆盖。 + +逐段算出待写属性后仍必须执行调用者选择的操作语义：`tp-set` 覆盖指定键，`tp-reset` 替换完整属性集合，`tp-add` 合并 face-family 和嵌套 plist。实现中一度让“属性已逐段应用”的返回标志绕过了这一步，导致文本内容相同时 reset 留下旧键、add 覆盖而不合并。最终把 operation 传到唯一的逐段写入点，并为字符串/缓冲区和 `tp-text nil` 初始化路径加入回归断言。 + +### 3. 层重定义必须拿到 old 与 new + +只传 layer name 会让渲染器无法判断哪些键应删除。定义入口在替换注册表前保存 old props，渲染器随后执行： + +1. 仅删除仍等于旧值的旧层键； +2. 保留无关键和已经被外部改写的值； +3. 写入新定义； +4. 同步 direct render 与 buried/hidden stack entry。 + +这比完整 `set-text-properties` 更安全，因为后者会错误取得整个区间的所有权。 + +### 4. 隐藏层冲突默认失败 + +隐藏层存在时，直接属性只是 managed stack 的渲染缓存。外部直接写入无法可靠归属到某一层。三个候选方案中： + +- 静默覆盖会丢用户数据； +- 自动收编为匿名层会凭空改变 stack 结构； +- 明确失败能保留双方状态并暴露所有权冲突。 + +因此选择 `tp-layer-conflict`，并保证在 managed write 前检查。 + +### 5. NOERROR 只处理可预期的解析失败 + +增加 `tp-unresolved-layer`，NOERROR 仅捕获这一类型。层 body、compute、transform 和内部不变量错误不属于“未找到”，必须传播。 + +### 6. 业务计算与 observer 分开 + +transform/compute 决定渲染结果，失败后继续会产生貌似有效的陈旧输出，因此错误传播。watcher 是副作用观察者，单个失败不应阻断 managed update；错误以结构化 plist 记录在 `tp-reactive-observer-errors`，同时保留用户可见消息。 + +## 有意延期 + +参数化 mounted layer entry 没有保存调用实参，重定义时无法重新求值。为避免猜测参数或引入兼容包装，本阶段明确不自动刷新参数化实例。后续应让 managed entry 保存参数和定义版本，再设计迁移。 + +字符串/缓冲区搜索返回结构、复制/原地修改策略和 stack mutator 的 run-count 返回值也仍有历史差异；它们属于 canonical façade 阶段，不能混入正确性补丁。 + +## 验证标准 + +本阶段以以下证据作为停止条件： + +- 每个确认问题先有失败回归测试； +- 聚焦测试覆盖字符串/缓冲区、present-nil、静态/响应式重定义和 hidden conflict； +- warning-as-error 字节编译通过； +- 全量 ERT、固定种子乱序 ERT 与 README doctest 通过； +- 中英文 README、docstring、架构文档和 changelog 与规范同步。 diff --git a/postmortem/2026-07-28-complete-text-property-facade.md b/postmortem/2026-07-28-complete-text-property-facade.md new file mode 100644 index 0000000..4c33ab2 --- /dev/null +++ b/postmortem/2026-07-28-complete-text-property-facade.md @@ -0,0 +1,69 @@ +# 完整文本属性 facade：把“替代”定义为语义覆盖，而不是重写 Emacs + +## 背景 + +仓库最初能够便捷地写入、搜索和组合文本属性，但“可以替代所有文本属性操作”仍缺少可验证边界：直接值与有效值混在一起，显式 nil 难以观察，参数化 managed layer 丢失实参，overlay-aware 字符属性没有统一入口，主题变化和多步写入也没有生命周期证据。 + +本轮没有复制 Emacs 的 interval、overlay、undo、yank 或 stickiness 引擎。目标改为更严格也更可维护的定义： + +> `tp` 为高频文本属性工作流提供统一 facade；原生语义由 GNU Emacs 执行并以等价测试锁定；overlay 生命周期等不应被包装的能力明确委托。 + +## 决策 + +### 1. 一个 lookup record，五种明确模式 + +新增 `tp-lookup-result` 和 `tp-lookup`，而没有继续增加 `tp-direct-at`、`tp-char-at` 等平行入口。模式区分： + +- `:text-direct`：只看直接 text plist； +- `:text-effective`：等价于 `get-text-property`； +- `:text-source`：报告 direct/category/alias/default/absent； +- `:char`：等价于 overlay-aware `get-char-property`； +- `:char-source`：同时报告来源和获胜 overlay。 + +record 的 `present-p` 是必要字段，因为 nil 既可能是合法直接值，也可能表示缺失。`overlay` 只在 overlay 真正提供获胜值时设置。 + +### 2. 原生编辑语义优先委托 + +property change、any/not-all 只做签名统一，直接调用对应 Emacs primitive。copy、substring、insert、insert-and-inherit、kill/yank、stickiness、narrowing 和 indirect buffer 不增加包装层；测试证明 facade 不会破坏这些行为，文档给出委托边界。 + +`with-silent-modifications` 原生会绑定 `inhibit-read-only`。因此 `:silent + :respect` 无法诚实实现：伪装支持会让策略名与实际行为冲突。本轮只支持 ordinary/respect、ordinary/inhibit、silent/inhibit，并对矛盾组合立即报错。 + +### 3. managed metadata 属于存储，不属于渲染属性 + +managed entry 使用单一保留键 `tp-meta` 保存 schema、entry id、原始 spec、实参、arglist、定义版本和 entry 版本。没有把这些字段拆成大量普通 text-property key，避免污染用户属性命名空间。 + +`tp-meta` 必须保留在 authoritative stack storage 中，但必须从直接渲染属性和公开 stack query 中剥离。冲突比较也只比较渲染投影，否则 metadata 自身会制造假冲突。 + +参数化 layer 重定义现在可用保存的 args 重新求值。旧 entry 若没有 args，不猜测、不静默套用错误参数；诊断将其标为 legacy limitation。 + +完整存储模式下的直接属性明确对应第一个可见 entry。definition/reactive refresh 具备 old/new 所有权上下文，因此会先把原生直接编辑协调进该 entry，再刷新定义，以保留外部值；普通 stack decode 没有这层上下文，仍对缓存不一致发出 `tp-layer-conflict`。所有层都隐藏时出现直接属性同样属于冲突。 + +### 4. attach、diagnostics、transaction 是显式生命周期 + +插入已经带属性的字符串不会经过普通 buffer 写入注册路径，因此提供显式 attach 扫描。detach 可以移除 managed identity/storage，并由调用者选择是否保留当前渲染结果。 + +诊断 API 必须是只读的：不能移动 point、修改 modified state、undo、文本属性或 registry（清除已死亡 buffer 除外）。 + +多步 managed 写入通过 opt-in transaction 包装。事务保存受影响范围的精确文本与属性状态；buffer 事务使用 live markers 跟踪范围内的插入和删除，任一步失败都恢复快照。默认重新抛出结构化 `tp-layer-transaction-error`，只有显式 NOERROR 才把失败转换为结构化返回值。 + +### 5. 主题检测与刷新分层 + +palette 模块只负责检测 `enable-theme` / `disable-theme`、递增 generation 并发出 hook；managed renderer 负责刷新。v1 允许保守扫描全部 managed ranges，因为错误地漏刷比多刷一次更危险。诊断记录 hook 来源、generation、刷新模式、范围和错误，为后续 dependency-targeted 优化保留证据。 + +## 有意排除 + +- 不提供 overlay 创建、移动、删除、evaporation 或 priority mutation API； +- 不重写 category、alias、default、undo、yank 或 stickiness 引擎； +- 不引入 compositional layer 语义； +- 不改变现有公共 mutator 的历史返回值； +- 不提高 Emacs 28.1 或 Dash 2.19.1 baseline。 + +## 验证标准 + +完成声明必须同时具备： + +- direct/effective/source/char lookup 的原生等价测试； +- managed metadata、参数化刷新、attach/detach、只读诊断、事务回滚和主题 lifecycle 测试； +- 全量 ERT、固定 seed 乱序 ERT、doctest 和 warning-as-error 编译； +- 大文本、碎片 interval、深 stack、reactive fan-out 与主题刷新的可复现实测； +- 中英文 README、API semantics、architecture、audit checklist 和 changelog 同步。 diff --git a/tp-benchmark.el b/tp-benchmark.el new file mode 100644 index 0000000..cb29b5d --- /dev/null +++ b/tp-benchmark.el @@ -0,0 +1,217 @@ +;;; tp-benchmark.el --- Batch benchmarks for tp -*- lexical-binding: t -*- + +;; Copyright (C) 2024-2026 Geekinney + +;; Author: Geekinney (kinneyzhang666@gmail.com) + +;;; Commentary: + +;; Run with: +;; emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run + +;;; Code: + +(require 'cl-lib) +(require 'tp) + +(defconst tp-benchmark--fixed-seeds '(1 7 42 747555) + "Fixed deterministic benchmark seeds.") + +(defconst tp-benchmark--generated-seed 8675309 + "Printed generated seed. Fixed so the benchmark output is reproducible.") + +(defvar tp-bench-fanout-color nil + "Reactive color variable used by `tp-benchmark-run'.") + +(defun tp-benchmark--print (plist) + "Print one benchmark row from PLIST." + (princ + (concat + (mapconcat + (lambda (key) + (format "%s=%S" (substring (symbol-name key) 1) + (plist-get plist key))) + '(:scenario :status :fixture :seed :requested :actual :operations + :scanned :changed :refreshed :elapsed :gcs :note) + " ") + "\n"))) + +(defun tp-benchmark--random-string (size seed) + "Return deterministic random string of SIZE using SEED." + (let ((state seed) + (chars "abcdefghijklmnopqrstuvwxyz") + (result (make-string size ?a)) + (pos 0)) + (while (< pos size) + (setq state (mod (+ (* state 1103515245) 12345) 2147483648)) + (aset result pos (aref chars (mod state (length chars)))) + (setq pos (1+ pos))) + result)) + +(defun tp-benchmark--measure (scenario fixture seed requested actual body) + "Measure BODY after GC and print a benchmark row." + (garbage-collect) + (let* ((gc-start gcs-done) + (start (float-time)) + (result (funcall body)) + (elapsed (- (float-time) start))) + (tp-benchmark--print + (append + (list :scenario scenario :status 'ok :fixture fixture :seed seed + :requested requested :actual actual) + result + (list :elapsed elapsed :gcs (- gcs-done gc-start) :note nil))))) + +(defun tp-benchmark--blocked (scenario fixture seed requested note) + "Print a blocked benchmark row." + (tp-benchmark--print + (list :scenario scenario :status 'blocked :fixture fixture :seed seed + :requested requested :actual 0 :operations 0 :scanned 0 + :changed 0 :refreshed 0 :elapsed nil :gcs 0 :note note))) + +(defun tp-benchmark--large-text (size seed) + "Benchmark large text property set/search for SIZE and SEED." + (let ((text (tp-benchmark--random-string size seed))) + (tp-set 0 size '(tp-bench t) text) + (unless (equal (tp-search text 'tp-bench t) (list (list 0 size t))) + (error "large-text correctness failed")) + (set-text-properties 0 size nil text) + (tp-benchmark--measure + 'large-text 'string seed size size + (lambda () + (tp-set 0 size '(tp-bench t) text) + (let ((matches (tp-search text 'tp-bench t))) + (unless (equal matches (list (list 0 size t))) + (error "timed large-text correctness failed")) + (list :operations 2 :scanned size :changed size + :refreshed 0 :note (length matches))))))) + +(defun tp-benchmark--fragmented (runs seed) + "Benchmark RUNS fragmented property intervals using SEED." + (let ((text (make-string runs ?x))) + (cl-loop for i below runs + when (zerop (mod i 2)) + do (put-text-property i (1+ i) 'tp-bench i text)) + (unless (= (length (tp-search text 'tp-bench)) (/ (1+ runs) 2)) + (error "fragmented correctness failed")) + (tp-benchmark--measure + 'fragmented 'string seed runs runs + (lambda () + (let ((matches (tp-search text 'tp-bench))) + (list :operations 1 :scanned runs :changed (length matches) + :refreshed 0 :note nil)))))) + +(defun tp-benchmark--define-stack-layers (depth) + "Define DEPTH benchmark stack layers." + (cl-loop for i below depth + do (eval `(define-tp ,(intern (format "tp-bench-stack-%d" i)) + () '(face bold))))) + +(defun tp-benchmark--stack-depth (depth seed) + "Benchmark stack operations at DEPTH using SEED." + (tp-layer-reset) + (tp-benchmark--define-stack-layers depth) + (with-temp-buffer + (insert (make-string 2000 ?s)) + (cl-loop for i below depth + do (tp-push-layer 1 2001 + (intern (format "tp-bench-stack-%d" i)))) + (unless (= (tp-layer-count 1 2001) depth) + (error "stack-depth correctness failed")) + (set-text-properties 1 2001 nil) + (tp-benchmark--measure + 'stack-depth 'buffer seed depth depth + (lambda () + (cl-loop for i below depth + do (tp-push-layer 1 2001 + (intern (format "tp-bench-stack-%d" i)))) + (unless (= (tp-layer-count 1 2001) depth) + (error "timed stack-depth correctness failed")) + (let ((top (tp-layer-top 1 2001))) + (list :operations (1+ depth) :scanned 2000 :changed 2000 + :refreshed 0 :note top)))))) + +(defun tp-benchmark--define-fanout-layer (seed) + "Define one reactive layer for SEED." + (set 'tp-bench-fanout-color "red") + (eval '(define-tp tp-bench-fanout () + :props '(face (:foreground $tp-bench-fanout-color)) + :data '((tp-bench-fanout-color . "red")))) + seed) + +(defun tp-benchmark--reactive-fanout (requested seed) + "Benchmark reactive fanout REQUESTED using SEED." + (let ((actual (min requested 200))) + (tp-layer-reset) + (tp-reactive-reset) + (tp-benchmark--define-fanout-layer seed) + (let ((buffers nil)) + (unwind-protect + (progn + (dotimes (i actual) + (let ((buf (generate-new-buffer + (format " *tp-bench-fanout-%d*" i)))) + (push buf buffers) + (with-current-buffer buf + (insert "x") + (tp-set 1 2 'tp-bench-fanout)))) + (setq tp-bench-fanout-color "blue") + (with-current-buffer (car buffers) + (unless (equal (plist-get (get-text-property 1 'face) + :foreground) + "blue") + (error "reactive-fanout correctness failed"))) + (tp-benchmark--measure + 'reactive-fanout 'buffers seed requested actual + (lambda () + (setq tp-bench-fanout-color "green") + (list :operations 1 :scanned actual :changed actual + :refreshed actual + :note (format "requested=%d actual=%d" + requested actual))))) + (mapc (lambda (buf) + (when (buffer-live-p buf) (kill-buffer buf))) + buffers))))) + +(defun tp-benchmark--theme-refresh (seed) + "Benchmark current theme managed refresh hook using SEED." + (if (not (fboundp 'tp--refresh-managed-after-theme-change)) + (tp-benchmark--blocked + 'theme-managed-refresh 'buffer seed 1 + "tp--refresh-managed-after-theme-change unavailable") + (tp-layer-reset) + (with-temp-buffer + (insert (make-string 1000 ?t)) + (define-tp tp-bench-theme () '(face (:foreground "red"))) + (tp-push-layer 1 1001 'tp-bench-theme) + (tp--refresh-managed-after-theme-change 'benchmark) + (unless tp-theme-last-refreshed-ranges + (error "theme-refresh correctness failed")) + (tp-benchmark--measure + 'theme-managed-refresh 'buffer seed 1 1 + (lambda () + (tp--refresh-managed-after-theme-change 'benchmark) + (list :operations 1 :scanned 1000 :changed 0 + :refreshed (length tp-theme-last-refreshed-ranges) + :note tp-theme-last-refresh-mode)))))) + +(defun tp-benchmark-run () + "Run tp benchmarks in batch mode." + (interactive) + (princ (format "tp-benchmark emacs=%S generated-seed=%d fixed-seeds=%S\n" + emacs-version tp-benchmark--generated-seed + tp-benchmark--fixed-seeds)) + (dolist (seed (append tp-benchmark--fixed-seeds + (list tp-benchmark--generated-seed))) + (dolist (size '(100000 1000000)) + (tp-benchmark--large-text size seed)) + (dolist (runs '(1000 10000 50000)) + (tp-benchmark--fragmented runs seed)) + (dolist (depth '(1 5 20 50)) + (tp-benchmark--stack-depth depth seed)) + (dolist (fanout '(1 10 100 500)) + (tp-benchmark--reactive-fanout fanout seed)) + (tp-benchmark--theme-refresh seed))) + +(provide 'tp-benchmark) +;;; tp-benchmark.el ends here diff --git a/tp-builtins.el b/tp-builtins.el index c89dcf7..5b4ac21 100644 --- a/tp-builtins.el +++ b/tp-builtins.el @@ -203,5 +203,48 @@ the gallery window." keymap) rear-nonsticky (keymap)))) +(defun tp--managed-theme-ranges () + "Return managed buffer ranges and the layer names found in them." + (let (ranges) + (dolist (buffer (buffer-list)) + (when (buffer-live-p buffer) + (tp--map-intervals + buffer nil nil + (lambda (start end props) + (let ((names (delq nil + (cons (plist-get props 'tp-name) + (mapcar + (lambda (entry) + (plist-get entry 'tp-name)) + (plist-get props 'tp-layers)))))) + (when names + (push (list :buffer buffer :start start :end end + :layers (delete-dups names)) + ranges))))))) + (nreverse ranges))) + +(defun tp--refresh-managed-after-theme-change (_source) + "Conservatively refresh all managed layers after a theme change." + (let* ((ranges (tp--managed-theme-ranges)) + (layers (delete-dups + (apply #'append + (mapcar (lambda (range) + (copy-sequence + (plist-get range :layers))) + ranges)))) + errors) + (dolist (layer layers) + (condition-case condition + (tp--layer-refresh layer) + (error + (push (list :kind 'theme-refresh :layer layer + :condition condition) + errors)))) + (setq tp-theme-last-refresh-mode :conservative + tp-theme-last-refreshed-ranges ranges + tp-theme-last-refresh-errors (nreverse errors)))) + +(add-hook 'tp-theme-change-hook #'tp--refresh-managed-after-theme-change) + (provide 'tp-builtins) ;;; tp-builtins.el ends here diff --git a/tp-char-tests.el b/tp-char-tests.el new file mode 100644 index 0000000..8806f7a --- /dev/null +++ b/tp-char-tests.el @@ -0,0 +1,136 @@ +;;; tp-char-tests.el --- Character lookup tests for tp.el -*- lexical-binding: t -*- + +;;; Commentary: + +;; Stage 5 tests for `tp-lookup' character-property modes. These tests use +;; GNU Emacs public primitives as the oracle for overlay-aware behavior. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'tp) +(require 'tp-query) + +(defun tp-char-tests--source-result (position property) + "Return `tp-lookup' result for PROPERTY at POSITION in `:char-source' mode." + (tp-lookup position property :mode :char-source)) + +(ert-deftest tp-char-test-char-mode-returns-overlay-only-value () + "The :char lookup mode returns the native overlay-only char property." + (with-temp-buffer + (insert "x") + (let ((overlay (make-overlay 1 2))) + (overlay-put overlay 'state 'overlay-only) + (let ((result (tp-lookup 1 'state :mode :char))) + (should (tp-lookup-result-present-p result)) + (should (eq (tp-lookup-result-value result) + (get-char-property 1 'state))) + (should (eq (tp-lookup-result-value result) 'overlay-only)) + (should (eq (tp-lookup-result-mode result) :char)))))) + +(ert-deftest tp-char-test-char-source-reports-winning-overlay-identity () + "The :char-source lookup mode reports the native winning overlay." + (with-temp-buffer + (insert "x") + (let ((low (make-overlay 1 2)) + (high (make-overlay 1 2))) + (overlay-put low 'priority 1) + (overlay-put low 'state 'low) + (overlay-put high 'priority 10) + (overlay-put high 'state 'high) + (let* ((native (get-char-property-and-overlay 1 'state)) + (result (tp-char-tests--source-result 1 'state))) + (should (eq (car native) 'high)) + (should (eq (cdr native) high)) + (should (tp-lookup-result-present-p result)) + (should (eq (tp-lookup-result-value result) (car native))) + (should (eq (tp-lookup-result-source result) :overlay)) + (should (eq (tp-lookup-result-overlay result) (cdr native))))))) + +(ert-deftest tp-char-test-text-effective-ignores-overlay-value () + "The :text-effective lookup mode ignores overlay properties." + (with-temp-buffer + (insert "x") + (put-text-property 1 2 'state 'text) + (let ((overlay (make-overlay 1 2))) + (overlay-put overlay 'state 'overlay) + (let ((result (tp-lookup 1 'state :mode :text-effective))) + (should (tp-lookup-result-present-p result)) + (should (eq (tp-lookup-result-value result) + (get-text-property 1 'state))) + (should (eq (tp-lookup-result-value result) 'text)))))) + +(ert-deftest tp-char-test-text-source-direct-nil-stops-fallback () + "The :text-source lookup mode treats explicit nil text as present." + (with-temp-buffer + (insert "x") + (let ((category (make-symbol "tp-char-category")) + (default-text-properties '(state default))) + (put category 'state 'category) + (put-text-property 1 2 'category category) + (put-text-property 1 2 'state nil) + (let ((result (tp-lookup 1 'state :mode :text-source))) + (should (tp-lookup-result-present-p result)) + (should-not (tp-lookup-result-value result)) + (should (eq (tp-lookup-result-source result) :text-direct)))))) + +(ert-deftest tp-char-test-text-source-classifies-category-source () + "The :text-source lookup mode classifies category fallback." + (with-temp-buffer + (insert "x") + (let ((category (make-symbol "tp-char-category"))) + (put category 'state 'category) + (put-text-property 1 2 'category category) + (let ((result (tp-lookup 1 'state :mode :text-source))) + (should (tp-lookup-result-present-p result)) + (should (eq (tp-lookup-result-value result) 'category)) + (should (eq (tp-lookup-result-source result) :category)))))) + +(ert-deftest tp-char-test-text-source-classifies-alias-source () + "The :text-source lookup mode classifies alias fallback." + (with-temp-buffer + (insert "x") + (let ((char-property-alias-alist '((state alternate)))) + (put-text-property 1 2 'alternate 'alias) + (let ((result (tp-lookup 1 'state :mode :text-source))) + (should (tp-lookup-result-present-p result)) + (should (eq (tp-lookup-result-value result) 'alias)) + (should (eq (tp-lookup-result-source result) :alias)))))) + +(ert-deftest tp-char-test-text-source-classifies-default-source () + "The :text-source lookup mode classifies default fallback." + (with-temp-buffer + (insert "x") + (let ((default-text-properties '(state default))) + (let ((result (tp-lookup 1 'state :mode :text-source))) + (should (tp-lookup-result-present-p result)) + (should (eq (tp-lookup-result-value result) 'default)) + (should (eq (tp-lookup-result-source result) :default)))))) + +(ert-deftest tp-char-test-text-source-classifies-absent-source () + "The :text-source lookup mode classifies absent properties." + (with-temp-buffer + (insert "x") + (let ((result (tp-lookup 1 'state :mode :text-source))) + (should-not (tp-lookup-result-present-p result)) + (should-not (tp-lookup-result-value result)) + (should (eq (tp-lookup-result-source result) :absent))))) + +(ert-deftest tp-char-test-char-source-follows-native-overlay-nil-fallback () + "The :char-source lookup mode follows native explicit nil overlay fallback." + (with-temp-buffer + (insert "x") + (put-text-property 1 2 'state 'text) + (let ((overlay (make-overlay 1 2))) + (overlay-put overlay 'state nil) + (let* ((native (get-char-property-and-overlay 1 'state)) + (result (tp-char-tests--source-result 1 'state))) + (should (eq (car native) 'text)) + (should-not (cdr native)) + (should (tp-lookup-result-present-p result)) + (should (eq (tp-lookup-result-value result) (car native))) + (should-not (tp-lookup-result-overlay result)))))) + +(provide 'tp-char-tests) +;;; tp-char-tests.el ends here diff --git a/tp-core-tests.el b/tp-core-tests.el index 9f5e49b..0b825dc 100644 --- a/tp-core-tests.el +++ b/tp-core-tests.el @@ -68,6 +68,71 @@ "The face-family property list contains the three face properties." (should (equal tp-face-properties '(face font-lock-face mouse-face)))) +;;; Stage 2 canonical façade + +(ert-deftest tp-core-test-native-range-string-and-buffer-coordinates () + "Canonical ranges store concrete objects and native coordinates." + (let* ((str (copy-sequence "abcd")) + (range (tp--native-range-from-object str 1 3))) + (should (tp--native-range-p range)) + (should (eq (tp--native-range-kind range) :string)) + (should (eq (tp--native-range-object range) str)) + (should (equal (list (tp--native-range-start range) + (tp--native-range-end range)) + '(1 3)))) + (with-temp-buffer + (insert "abcd") + (narrow-to-region 2 4) + (let ((range (tp--native-range-from-object nil nil nil))) + (should (eq (tp--native-range-kind range) :buffer)) + (should (eq (tp--native-range-object range) (current-buffer))) + (should (equal (list (tp--native-range-start range) + (tp--native-range-end range)) + '(2 4)))))) + +(ert-deftest tp-core-test-presence-distinguishes-three-value-states () + "Canonical presence distinguishes absence, explicit nil, and a value." + (let ((str (copy-sequence "abc"))) + (put-text-property 0 1 'state nil str) + (put-text-property 1 2 'state 'ready str) + (let ((nil-value (tp--presence-at 0 'state str)) + (value (tp--presence-at 1 'state str)) + (absent (tp--presence-at 2 'state str))) + (should (tp--presence-present-p nil-value)) + (should-not (tp--presence-value nil-value)) + (should (tp--presence-present-p value)) + (should (eq (tp--presence-value value) 'ready)) + (should-not (tp--presence-present-p absent)) + (should-not (tp--presence-value absent))))) + +(ert-deftest tp-core-test-canonical-request-match-and-result-adapters () + "Canonical records preserve policy and adapt only at public boundaries." + (let* ((str (copy-sequence "abcd")) + (range (tp--native-range-from-object str 1 3)) + (request (tp--make-request + :operation :set :range range :props '(face bold) + :mutation :copy :read-only :respect + :noerror nil :public-return :range)) + (match (tp--make-match range 'face 'bold)) + (result (tp--make-result + :request request :matches (list match) + :count 1 :object str :native 'native-value))) + (should (tp--request-p request)) + (should (eq (tp--request-operation request) :set)) + (should (eq (tp--request-mutation request) :copy)) + (should (equal (tp--match-to-list match) '(1 3 bold))) + (let ((native-match (tp--match-to-prop-match match))) + (should (= (prop-match-beginning native-match) 1)) + (should (= (prop-match-end native-match) 3)) + (should (eq (prop-match-value native-match) 'bold))) + (should (equal (tp--result-public-value result) '(1 . 3))) + (setf (tp--request-public-return request) :matches) + (should (equal (tp--result-public-value result) '((1 3 bold)))) + (setf (tp--request-public-return request) :count) + (should (= (tp--result-public-value result) 1)) + (setf (tp--request-public-return request) :native) + (should (eq (tp--result-public-value result) 'native-value)))) + ;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map (ert-deftest tp-core-test-intervals-buffer-relative-default () diff --git a/tp-core.el b/tp-core.el index 2dd3a74..7052ac4 100644 --- a/tp-core.el +++ b/tp-core.el @@ -23,6 +23,7 @@ (require 'cl-lib) (require 'dash) (require 'seq) +(require 'text-property-search) (defgroup tp nil "Group for tp.el text property manipulation." @@ -114,6 +115,84 @@ FORMAT-STRING and ARGS are passed to `format'." (let ((inhibit-read-only t)) ,@body))) +(cl-defstruct (tp--native-range + (:constructor tp--make-native-range + (object kind start end))) + object kind start end) + +(cl-defstruct (tp--presence + (:constructor tp--make-presence (present-p value))) + present-p value) + +(cl-defstruct (tp--request + (:constructor tp--make-request + (&key operation range props property value + predicate mutation read-only noerror + public-return))) + operation range props property value predicate mutation read-only + noerror public-return) + +(cl-defstruct (tp--match + (:constructor tp--make-match (range property value))) + range property value) + +(cl-defstruct (tp--result + (:constructor tp--make-result + (&key request value matches count object native))) + request value matches count object native) + +(defun tp--object-kind (object) + "Return the canonical kind for OBJECT." + (if (stringp object) :string :buffer)) + +(defun tp--object-bounds (object) + "Return native bounds for OBJECT." + (if (stringp object) + (cons 0 (length object)) + (with-current-buffer (or object (current-buffer)) + (cons (point-min) (point-max))))) + +(defun tp--native-range-from-object (object start end) + "Return a concrete native range for OBJECT from START to END." + (let* ((obj (or object (current-buffer))) + (bounds (tp--object-bounds obj))) + (tp--make-native-range + obj (tp--object-kind obj) + (max (or start (car bounds)) (car bounds)) + (min (or end (cdr bounds)) (cdr bounds))))) + +(defun tp--presence-at (pos property &optional object) + "Return canonical presence of PROPERTY at POS in OBJECT." + (let ((cell (plist-member (text-properties-at pos object) property))) + (tp--make-presence (and cell t) (cadr cell)))) + +(defun tp--match-to-list (match) + "Convert MATCH to the historical (START END VALUE) list." + (let ((range (tp--match-range match))) + (list (tp--native-range-start range) + (tp--native-range-end range) + (tp--match-value match)))) + +(defun tp--match-to-prop-match (match) + "Convert MATCH to an Emacs `prop-match' object." + (let ((range (tp--match-range match))) + (make-prop-match :beginning (tp--native-range-start range) + :end (tp--native-range-end range) + :value (tp--match-value match)))) + +(defun tp--result-public-value (result) + "Return RESULT using its request's public return convention." + (pcase (tp--request-public-return (tp--result-request result)) + (:range + (let ((range (tp--request-range (tp--result-request result)))) + (cons (tp--native-range-start range) + (tp--native-range-end range)))) + (:matches (mapcar #'tp--match-to-list (tp--result-matches result))) + (:count (tp--result-count result)) + (:object (tp--result-object result)) + (:native (tp--result-native result)) + (_ (tp--result-value result)))) + (defun tp-intervals (start end &optional object absolute) "Return list of property intervals from START to END in OBJECT. Each element is (START END PROPERTIES). OBJECT defaults to current @@ -323,34 +402,6 @@ Returns the modified face value with the layer's face contribution removed." ;; Unknown - return as-is (t face-value))) -(defun tp--merge-string-props-into-plist (str props) - "Merge text properties from string STR into PROPS plist. -Properties from PROPS take precedence over those in STR. -Returns the merged plist where new props override embedded props. -For simplicity, only considers properties at position 0 of STR." - (if (not (tp--string-has-properties-p str)) - props - (let ((str-props (text-properties-at 0 str)) - (result (copy-sequence props))) - ;; Merge each property from the string into result - ;; Props values take precedence over embedded string values - (cl-loop for (key val) on str-props by #'cddr - do (let ((existing (plist-get result key))) - (if existing - ;; Props already has this key - merge with props taking precedence - (setq result - (plist-put result key - (cond - ;; Face properties need special merging - ;; Pass embedded val as face1 (base), existing as face2 (override) - ((memq key tp-face-properties) - (tp--merge-face-values val existing)) - ;; Other properties - props value takes precedence - (t existing)))) - ;; Props doesn't have this key - add from string - (setq result (plist-put result key val))))) - result))) - (defun tp--merge-face-values (face1 face2) "Merge two face values into one. FACE1 is the earlier value, FACE2 is the later value. @@ -361,8 +412,9 @@ Returns the merged face value. Role: this is the merge engine for face values that arrive together in a SINGLE call's property spec - `tp--merge-duplicate-keys' reduces repeated face/font-lock-face/mouse-face keys through it, and -`tp--merge-string-props-into-plist' uses it to fold a string's embedded -face into caller props. Argument order is (EARLIER LATER); LATER wins. +`tp--merge-embedded-props' uses it for each property run of a +propertized replacement string. Argument order is (EARLIER LATER); +LATER wins. Note: `tp--prepend-face' is a sibling engine used by `tp-add' to merge an INCOMING face value into one already present on the text. Its diff --git a/tp-doctest.el b/tp-doctest.el index 3b99ddc..b5db87e 100644 --- a/tp-doctest.el +++ b/tp-doctest.el @@ -85,7 +85,7 @@ (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-search-map #'upcase 'marker nil my-string) + (tp-search-map #'upcase 'marker tp-any-value my-string) (substring-no-properties my-string))) (chk "F-teaser-fullname" '(help-echo "John Doe" face (:foreground "purple") tp-name full-name-layer) (progn @@ -120,6 +120,40 @@ (tp-set 1 6 '(face bold)) (tp-member 1 'face))) +;; ---- tp-lookup ---- +(chk "Q-lookup-direct-nil-absent" '((t nil :text-direct) (nil nil :absent)) + (let ((str (copy-sequence "ab"))) + (put-text-property 0 1 'state nil str) + (let ((nil-result (tp-lookup 0 'state :object str :mode :text-direct)) + (absent-result (tp-lookup 1 'state :object str :mode :text-direct))) + (list (list (tp-lookup-result-present-p nil-result) + (tp-lookup-result-value nil-result) + (tp-lookup-result-source nil-result)) + (list (tp-lookup-result-present-p absent-result) + (tp-lookup-result-value absent-result) + (tp-lookup-result-source absent-result)))))) +(chk "Q-lookup-source-category" '(category-value :category) + (let* ((str (copy-sequence "a")) + (category (make-symbol "tp-doc-category"))) + (put category 'state 'category-value) + (put-text-property 0 1 'category category str) + (let ((result (tp-lookup 0 'state :object str :mode :text-source))) + (list (tp-lookup-result-value result) + (tp-lookup-result-source result))))) +(chk "Q-lookup-char-source-overlay" '(high :overlay t) + (with-temp-buffer + (insert "x") + (let ((low (make-overlay 1 2)) + (high (make-overlay 1 2))) + (overlay-put low 'priority 1) + (overlay-put low 'state 'low) + (overlay-put high 'priority 10) + (overlay-put high 'state 'high) + (let ((result (tp-lookup 1 'state :mode :char-source))) + (list (tp-lookup-result-value result) + (tp-lookup-result-source result) + (eq (tp-lookup-result-overlay result) high)))))) + ;; ---- tp-remove nested ---- (chk "R-remove-nested" '(:color "blue") (let ((original (propertize "Hello" 'face '(:underline (:style wave :color "blue"))))) @@ -134,7 +168,7 @@ (goto-char 1) (let ((match (tp-forward 'marker t))) (when match (prop-match-beginning match))))) -(chk "N-fwd-nil" '(1 7) +(chk "N-fwd-any" '(7 12) (with-temp-buffer (insert "Hello World Test") (tp-set 7 12 '(marker t)) @@ -159,20 +193,20 @@ (let ((my-string (copy-sequence "Hello World Hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-forward 'marker nil my-string 2))) + (tp-forward 'marker tp-any-value my-string 2))) ;; ---- tp-forward-do / tp-search-map examples ---- (chk "DO-fdo" "hello world HELLO" (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-forward-do #'upcase 'marker nil my-string 2) + (tp-forward-do #'upcase 'marker tp-any-value my-string 2) (substring-no-properties my-string))) (chk "DO-bdo" "HELLO world hello" (let ((my-string (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) my-string) (tp-set 12 17 '(marker t) my-string) - (tp-backward-do #'upcase 'marker nil my-string 2) + (tp-backward-do #'upcase 'marker tp-any-value my-string 2) (substring-no-properties my-string))) (chk "DO-fdo-pos" '("hello world HELLO" (12 17)) (let ((my-string (copy-sequence "hello world hello")) @@ -183,7 +217,7 @@ (lambda (text start end) (setq match-info (list start end)) (upcase text)) - 'marker nil my-string 2) + 'marker tp-any-value my-string 2) (list (substring-no-properties my-string) match-info))) (chk "SM-idx" '("AAA BBB CCC" ((0 0 3) (1 4 7) (2 8 11))) (let ((my-string (copy-sequence "aaa bbb ccc")) @@ -195,7 +229,7 @@ (lambda (text start end idx) (push (list idx start end) positions) (upcase text)) - 'marker nil my-string) + 'marker tp-any-value my-string) (list (substring-no-properties my-string) (nreverse positions)))) ;; ---- Layer definitions ---- @@ -355,7 +389,7 @@ (insert "Hello World") (tp-put-layer 1 10 '(tp-color "red") 0) (tp-at 1 'face)))) -(chk "P-stack" '(:face (:background "yellow") :top highlight :layers (highlight base) :hidden 1) +(chk "P-stack" '(:face (:background "yellow") :top highlight :layers (highlight base) :hidden 2) (progn (tp-layer-reset) (define-tp base () '(face default)) @@ -368,6 +402,20 @@ :top (tp-layer-top 1 10) :layers (tp-layer-list 1 10) :hidden (length (tp-at 1 'tp-layers)))))) +(chk "P-transaction-ok" '(ok (1 . 4) bold) + (progn + (tp-layer-reset) + (define-tp tx-base () '(face bold)) + (define-tp tx-temp () '(face italic)) + (with-temp-buffer + (insert "abcd") + (let ((result + (tp-layer-transaction + 1 4 (current-buffer) + (lambda () (tp-put-layer 1 3 'tx-base 0))))) + (list (plist-get result :status) + (plist-get result :range) + (tp-at 1 'face)))))) ;; ---- Utilities ---- (chk "U-intervals" '((0 5 (face bold)) (5 6 nil) (6 11 (face italic))) @@ -561,7 +609,7 @@ (chk "X-do-shortfall-all-or-nothing" '(1 "hello world") (let ((str (copy-sequence "hello world"))) (tp-set 0 5 '(marker t) str) - (list (tp-forward-do #'upcase 'marker nil str 3) + (list (tp-forward-do #'upcase 'marker tp-any-value str 3) (substring-no-properties str)))) ;; ---- 0.3.0: search bounds and SUBEXP ---- diff --git a/tp-layer-tests.el b/tp-layer-tests.el index 29971eb..a1dafd7 100644 --- a/tp-layer-tests.el +++ b/tp-layer-tests.el @@ -428,14 +428,19 @@ (should (equal (get-text-property 0 'help-echo s) "tip"))))) (ert-deftest tp-layer-test-multi-arg-normalize-layer-spec () - "tp--normalize-layer-spec accepts (LAYER ARG1 ARG2) specs." + "Normalized parameterized specs retain args in managed metadata." (tp-layer-tests--with-clean (define-tp tp-layer-test-fgbg (fg bg) `(face (:foreground ,fg :background ,bg))) - (should (equal (tp--normalize-layer-spec - '(tp-layer-test-fgbg "red" "blue")) - '(face (:foreground "red" :background "blue") - tp-name tp-layer-test-fgbg))))) + (let* ((entry (tp--normalize-layer-spec + '(tp-layer-test-fgbg "red" "blue"))) + (meta (plist-get entry 'tp-meta))) + (should (equal (plist-get entry 'face) + '(:foreground "red" :background "blue"))) + (should (eq (plist-get entry 'tp-name) 'tp-layer-test-fgbg)) + (should (equal (plist-get meta :args) '("red" "blue"))) + (should (equal (plist-get meta :arglist) '(fg bg))) + (should (integerp (plist-get meta :definition-version)))))) (ert-deftest tp-layer-test-multi-arg-tp-put-layer () "tp-put-layer accepts multi-argument parameterized layer specs." @@ -650,12 +655,16 @@ text property list\"." (let ((err (should-error (tp--normalize-layer-spec '(tp-lt-colors "red"))))) (should (string-match-p "expects 2 args, got 1" (cadr err)))) - ;; Correct arity through the stack path is unchanged. + ;; Correct arity through the stack path keeps the rendered facade + ;; while authoritative metadata lives in stack storage. (let ((s (copy-sequence "st"))) (tp-push-layer s '(tp-lt-colors "red" "blue")) - (should (equal (text-properties-at 0 s) - '(face (:foreground "red" :background "blue") - tp-name tp-lt-colors)))))) + (should (equal (get-text-property 0 'face s) + '(:foreground "red" :background "blue"))) + (should (eq (get-text-property 0 'tp-name s) 'tp-lt-colors)) + (let* ((entry (car (get-text-property 0 'tp-layers s))) + (meta (plist-get entry 'tp-meta))) + (should (equal (plist-get meta :args) '("red" "blue"))))))) ;;; API-SYM-01: public tp-group-props-with-args mirrors the layer pair diff --git a/tp-layer.el b/tp-layer.el index e57e1ff..59b88a4 100644 --- a/tp-layer.el +++ b/tp-layer.el @@ -22,20 +22,59 @@ (require 'tp-core) (require 'tp-reactive) +(define-error 'tp-unresolved-layer "Unresolved tp layer or group") +(define-error 'tp-layer-conflict "Conflicting edit in a managed tp range") + (defvar tp--layer-refresh-function nil "Function re-rendering regions that carry a given layer, or nil. -Installed by tp-render.el. Called with (LAYER-NAME) after a layer is -redefined, so text that already uses the layer picks up the new -definition. When nil, redefinition only updates the registry.") +Installed by tp-render.el. Called with +\(LAYER-NAME nil nil OLD-PROPS) after a non-parameterized layer is +redefined, so text that already uses the layer can replace the old +owned properties with the new definition. When nil, redefinition +only updates the registry.") -(defun tp--layer-refresh (layer-name) +(defun tp--layer-refresh (layer-name &optional old-props) "Re-render regions carrying LAYER-NAME via `tp--layer-refresh-function'." (when tp--layer-refresh-function - (funcall tp--layer-refresh-function layer-name))) + (funcall tp--layer-refresh-function layer-name nil nil old-props))) (defvar tp-layer-alist nil "Alist of layer definitions: (LAYER-NAME . PROPERTIES).") +(defvar tp--layer-definition-counter 0 + "Monotonic counter used for layer definition versions.") + +(defvar tp--layer-definition-versions nil + "Alist of layer definition versions: (LAYER-NAME . VERSION).") + +(defvar tp--managed-entry-counter 0 + "Monotonic counter used for managed stack entry ids.") + +(defun tp--layer-definition-version (layer-name) + "Return LAYER-NAME's current definition version, or 0." + (or (cdr (assq layer-name tp--layer-definition-versions)) 0)) + +(defun tp--bump-layer-definition-version (layer-name) + "Increment and return LAYER-NAME's definition version." + (setq tp--layer-definition-counter (1+ tp--layer-definition-counter)) + (setf (alist-get layer-name tp--layer-definition-versions) + tp--layer-definition-counter) + tp--layer-definition-counter) + +(defun tp--store-layer-entry (layer-name entry &optional bump-version) + "Store LAYER-NAME registry ENTRY, optionally bumping its version." + (if (assoc layer-name tp-layer-alist) + (setf (cdr (assoc layer-name tp-layer-alist)) entry) + (push (cons layer-name entry) tp-layer-alist)) + (when bump-version + (tp--bump-layer-definition-version layer-name)) + (assoc layer-name tp-layer-alist)) + +(defun tp--next-managed-entry-id () + "Return a fresh managed entry id symbol." + (setq tp--managed-entry-counter (1+ tp--managed-entry-counter)) + (intern (format "tp-entry-%d" tp--managed-entry-counter))) + (defvar tp-layer-groups nil "Alist of layer groups: (GROUP-NAME . (LAYER-NAME1 LAYER-NAME2 ...)).") @@ -248,7 +287,9 @@ the text properties explicitly. If a layer with the same NAME already exists, it will be overwritten. The layer is stored in `tp-layer-alist'." (declare (indent defun)) - (let* ((parsed (tp--parse-define-layer-args args)) + (let* ((old-props (when (assoc name tp-layer-alist) + (tp-layer-props name t))) + (parsed (tp--parse-define-layer-args args)) (properties (plist-get parsed :props)) (data (plist-get parsed :data)) (watch (plist-get parsed :watch)) @@ -299,17 +340,19 @@ The layer is stored in `tp-layer-alist'." ;; Set layer properties with resolved values (let ((resolved-props (tp--resolve-reactive-symbols properties))) (tp--set-layer-props name resolved-props)) + (tp--bump-layer-definition-version name) ;; Update any text regions that already have this layer applied ;; This ensures re-definition immediately updates applied text - (tp--layer-refresh name) + (tp--layer-refresh name old-props) (assoc name tp-layer-alist)) ;; No reactive symbols - use static properties (progn ;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition) (tp--unregister-reactive-deps name) (tp--set-layer-props name properties) + (tp--bump-layer-definition-version name) ;; Update any text regions that already have this layer applied - (tp--layer-refresh name) + (tp--layer-refresh name old-props) (assoc name tp-layer-alist))))) ;;;###autoload @@ -340,7 +383,11 @@ Format 3 - Non-parameterized with reactive features Usage: (tp-set \"emacs\" \\='tp-bold t) (tp-set 0 5 \\='(tp-bold t) \"emacs\") - ;; => #(\"emacs\" 0 5 (tp-name tp-bold face bold)) + ;; => #(\"emacs\" 0 5 (face bold)) + +Direct `tp-set' use expands a non-reactive layer as a property +template and does not retain `tp-name'. Use `tp-push-layer' or +`tp-put-layer' when the text must retain managed layer identity. ARGLIST must be either: - An empty list () for non-parameterized layers @@ -420,12 +467,13 @@ delegates to `tp--define-layer-internal' for proper reactive handling." (if arglist ;; Parameterized - store for later evaluation (let ((entry (list arglist body))) - (if (assoc name tp-layer-alist) - (setf (cdr (assoc name tp-layer-alist)) entry) - (push (cons name entry) tp-layer-alist)) + (tp--store-layer-entry name entry t) + (tp--layer-refresh name nil) (assoc name tp-layer-alist)) ;; Non-parameterized - check for reactive symbols - (let ((reactive-syms (tp--collect-reactive-symbols body))) + (let ((reactive-syms (tp--collect-reactive-symbols body)) + (old-props (when (assoc name tp-layer-alist) + (tp-layer-props name t)))) (if reactive-syms ;; Has reactive symbols - use tp--define-layer-internal for proper handling (tp--define-layer-internal name body) @@ -433,9 +481,8 @@ delegates to `tp--define-layer-internal' for proper reactive handling." ;; Clean up old reactive dependencies if the layer was previously reactive (tp--unregister-reactive-deps name) (let ((entry (list nil `',body))) - (if (assoc name tp-layer-alist) - (setf (cdr (assoc name tp-layer-alist)) entry) - (push (cons name entry) tp-layer-alist)) + (tp--store-layer-entry name entry t) + (tp--layer-refresh name old-props) (assoc name tp-layer-alist)))))) (defun tp--layer-group-element-format (element) @@ -539,42 +586,42 @@ COMPUTE is the list of computed variable definitions. TRANSFORM, if non-nil, is registered in `tp-layer-transforms'; when nil, any previously registered transform for LAYER-NAME is removed (mirroring `tp--define-layer-internal')." - ;; Register or unregister transform function - (if transform - (if (assoc layer-name tp-layer-transforms) - (setcdr (assoc layer-name tp-layer-transforms) transform) - (push (cons layer-name transform) tp-layer-transforms)) - (setq tp-layer-transforms (assq-delete-all layer-name tp-layer-transforms))) - (let* ((reactive-syms (tp--collect-reactive-symbols props)) - (computed-vars (when compute (mapcar #'car compute))) - (all-reactive-syms (delete-dups reactive-syms)) - (props-vars (mapcar #'tp--reactive-var-symbol reactive-syms)) - (all-vars-to-define (delete-dups - (append data - props-vars - computed-vars)))) - (if (or all-reactive-syms data compute) - ;; Has reactive features - register dependencies and resolve at runtime - (progn - (tp--unregister-reactive-deps layer-name) - (tp--ensure-reactive-variables all-vars-to-define) - (when data - (tp--register-layer-data layer-name data)) - (when compute - (tp--register-layer-computed layer-name compute) - (tp--apply-initial-computed compute)) - (tp--register-reactive-deps layer-name all-reactive-syms props) - (when watch - (tp--register-layer-watchers layer-name watch)) - (let ((resolved-props (tp--resolve-reactive-symbols props))) - (tp--set-layer-props layer-name resolved-props)) - (tp--layer-refresh layer-name)) - ;; No reactive symbols - use static properties - (progn + (let ((old-props (when (assoc layer-name tp-layer-alist) + (tp-layer-props layer-name t)))) + ;; Register or unregister transform function + (if transform + (if (assoc layer-name tp-layer-transforms) + (setcdr (assoc layer-name tp-layer-transforms) transform) + (push (cons layer-name transform) tp-layer-transforms)) + (setq tp-layer-transforms + (assq-delete-all layer-name tp-layer-transforms))) + (let* ((reactive-syms (tp--collect-reactive-symbols props)) + (computed-vars (when compute (mapcar #'car compute))) + (all-reactive-syms (delete-dups reactive-syms)) + (props-vars (mapcar #'tp--reactive-var-symbol reactive-syms)) + (all-vars-to-define + (delete-dups (append data props-vars computed-vars)))) + (if (or all-reactive-syms data compute) + (progn + (tp--unregister-reactive-deps layer-name) + (tp--ensure-reactive-variables all-vars-to-define) + (when data + (tp--register-layer-data layer-name data)) + (when compute + (tp--register-layer-computed layer-name compute) + (tp--apply-initial-computed compute)) + (tp--register-reactive-deps layer-name all-reactive-syms props) + (when watch + (tp--register-layer-watchers layer-name watch)) + (tp--set-layer-props + layer-name (tp--resolve-reactive-symbols props)) + (tp--bump-layer-definition-version layer-name) + (tp--layer-refresh layer-name old-props)) (tp--unregister-reactive-deps layer-name) (tp--set-layer-props layer-name props) - (tp--layer-refresh layer-name))) - layer-name)) + (tp--bump-layer-definition-version layer-name) + (tp--layer-refresh layer-name old-props)) + layer-name))) (defun tp--define-layer-internal-group (name &rest elements) "Define a layer group named NAME containing multiple layers. @@ -758,9 +805,7 @@ Stores as (LAYER-NAME . PROPERTIES) for backward compatibility with reactive layers. This is an internal function used by layer definition macros and reactive updates." - (if (assoc layer-name tp-layer-alist) - (setf (cdr (assoc layer-name tp-layer-alist)) properties) - (push (cons layer-name properties) tp-layer-alist))) + (tp--store-layer-entry layer-name properties)) (defun tp--set-group-layers (group-name layer-names) "Set LAYER-NAMES for group GROUP-NAME in `tp-layer-groups'. @@ -1177,7 +1222,8 @@ PROPS can be: - A plist (handles anonymous layers with reactive variables) If PROPS is a symbol: -- First checks `tp-layer-alist' and returns the layer properties WITH `tp-name' +- First checks `tp-layer-alist' and expands the layer properties + WITHOUT `tp-name' for direct property setting - Then checks `tp-layer-groups' and returns properties WITH `tp-layers' If PROPS is (LAYER-NAME ARG) or (LAYER-NAME ARG EXTRA-PROPS...): @@ -1201,8 +1247,10 @@ If PROPS is a plist: Returns nil if PROPS is a symbol but no matching layer/group is found. -For layer names, includes `tp-name' property for reactive text property support. -For group names, includes `tp-layers' property with the full layer stack." +Reactive anonymous properties retain `tp-name' so they can be +updated. Plain layer names used through direct property APIs do not; +use stack APIs for a managed mount. Group names include `tp-layers' +with the full layer stack." (cond ;; Already a plist - check for reactive variables and add tp-name ((listp props) @@ -1389,6 +1437,9 @@ Also resets all reactive text property watchers, dependencies, and transforms." (tp-reactive-reset) (setq tp-layer-alist nil) (setq tp-layer-groups nil) + (setq tp--layer-definition-counter 0) + (setq tp--layer-definition-versions nil) + (setq tp--managed-entry-counter 0) (setq tp-layer-transforms nil) (setq tp--group-generated-layers nil) (setq tp--anonymous-layer-registry nil)) @@ -1399,6 +1450,8 @@ Also unregisters any reactive dependencies and transforms for this layer, and drops any anonymous-layer registry entries interned for it." (tp--unregister-reactive-deps name) (setq tp-layer-alist (assq-delete-all name tp-layer-alist)) + (setq tp--layer-definition-versions + (assq-delete-all name tp--layer-definition-versions)) (setq tp-layer-transforms (assq-delete-all name tp-layer-transforms)) (setq tp--anonymous-layer-registry (cl-remove-if (lambda (cell) (eq (cdr cell) name)) @@ -1416,6 +1469,42 @@ untouched." (assq-delete-all name tp--group-generated-layers)) (setq tp-layer-groups (assq-delete-all name tp-layer-groups))) +(defun tp--managed-entry-meta (name origin spec args arglist) + "Build managed metadata for NAME with ORIGIN, SPEC, ARGS and ARGLIST." + (list :schema 1 + :entry-id (tp--next-managed-entry-id) + :origin origin + :spec (copy-tree spec) + :args (copy-tree args) + :arglist (copy-tree arglist) + :definition-version (tp--layer-definition-version name) + :entry-version 1 + :mode 'exclusive + :palette-deps nil + :palette-generation (if (boundp 'tp-theme-generation) + tp-theme-generation 0) + :legacy-no-args nil)) + +(defun tp--stamp-managed-entry (props name spec args arglist origin) + "Return PROPS stamped with managed metadata for NAME." + (plist-put (copy-tree props) + 'tp-meta + (tp--managed-entry-meta name origin spec args arglist))) + +(defun tp--entry-render-projection (props) + "Return rendered PROPS without stack-only bookkeeping." + (let ((result (copy-sequence props))) + (dolist (key '(tp-meta tp-hidden tp-layers)) + (cl-remf result key)) + result)) + +(defun tp--entry-authoritative-storage-p (layer-list) + "Return non-nil when LAYER-LIST requires `tp-layers' authority." + (seq-some (lambda (layer) + (or (tp--stack-hidden-p layer) + (plist-member layer 'tp-meta))) + layer-list)) + (defun tp--normalize-layer-spec (layer-spec) "Normalize LAYER-SPEC to a plist with tp-name. Used by layer stack functions that need tp-name for identification. @@ -1438,9 +1527,11 @@ LAYER-SPEC can be: layer-spec layer-spec)) ;; Non-parameterized layer or old-format layer ((assoc layer-spec tp-layer-alist) - (or (tp-layer-props layer-spec t) ; include tp-name for layer stack - (error "Layer %S not found in tp-layer-alist" layer-spec))) - (t (error "Layer %S not found in tp-layer-alist" layer-spec)))) + (tp--stamp-managed-entry + (or (tp-layer-props layer-spec t) + (error "Layer %S not found in tp-layer-alist" layer-spec)) + layer-spec layer-spec nil nil 'defined)) + (t (signal 'tp-unresolved-layer (list layer-spec))))) ;; List starting with symbol - check if it's a parameterized layer ((and (listp layer-spec) @@ -1453,9 +1544,11 @@ LAYER-SPEC can be: ;; many arguments as the layer has parameters ((and (tp-layer-parameterized-p name) (= (length rest) (length (tp-layer-arglist name)))) - (or (tp-layer-props-with-args name rest t) ; include tp-name - (error "Failed to resolve parameterized layer %S with args %S" - name rest))) + (tp--stamp-managed-entry + (or (tp-layer-props-with-args name rest t) + (error "Failed to resolve parameterized layer %S with args %S" + name rest)) + name layer-spec rest (tp-layer-arglist name) 'parameterized)) ;; ARG-1: a parameterized layer with the wrong number of ;; arguments must not fall through to the named-inline branch, ;; which would build an odd-length plist and die with the @@ -1465,11 +1558,15 @@ LAYER-SPEC can be: name (length (tp-layer-arglist name)) (length rest))) ;; Named inline layer: (NAME &rest PLIST) (rest - (append rest (list 'tp-name name))) + (tp--stamp-managed-entry + (append rest (list 'tp-name name)) + name layer-spec nil nil 'inline)) ;; Just a symbol in a list - treat as non-parameterized layer ((null rest) - (or (tp-layer-props name t) - (error "Layer %S not found in tp-layer-alist" name)))))) + (tp--stamp-managed-entry + (or (tp-layer-props name t) + (signal 'tp-unresolved-layer (list name))) + name layer-spec nil nil 'defined))))) ;; Plist (starts with keyword or property name) ((and (listp layer-spec) layer-spec) @@ -1516,6 +1613,29 @@ A layer is hidden when its plist carries a non-nil `tp-hidden' entry; see `tp-hide-layer'." (and (plist-get layer 'tp-hidden) t)) +(defun tp--plist-equivalent-p (left right) + "Return non-nil when LEFT and RIGHT contain the same plist entries." + (let ((left-proj (tp--entry-render-projection left)) + (right-proj (tp--entry-render-projection right))) + (and (cl-loop for (key val) on left-proj by #'cddr + always (and (plist-member right-proj key) + (equal (plist-get right-proj key) val))) + (cl-loop for (key val) on right-proj by #'cddr + always (and (plist-member left-proj key) + (equal (plist-get left-proj key) val)))))) + +(defun tp--assert-hidden-render-cache (direct stack) + "Signal `tp-layer-conflict' unless DIRECT matches rendered STACK." + (let ((expected (seq-find (lambda (layer) + (not (tp--stack-hidden-p layer))) + stack))) + (unless (tp--plist-equivalent-p direct + (tp--entry-render-projection expected)) + (signal 'tp-layer-conflict + (list "Direct properties changed while a layer was hidden" + :actual direct + :expected (tp--entry-render-projection expected)))))) + (defun tp--stack-props-to-list (props) "Return the ordered layer stack stored in raw text properties PROPS. The result is a list of layer plists, top layer first, including @@ -1526,17 +1646,20 @@ This is the inverse of `tp--stack-build-props': when any entry of the `tp-layers' bookkeeping property is hidden, that property holds the whole ordered stack and the direct properties are only a render cache of the topmost non-hidden layer; otherwise the direct properties are -the top layer and `tp-layers' holds the layers below it. Direct -property edits made outside the stack API (for example `tp-set') are -therefore discarded by the next stack operation while any layer is -hidden." +the top layer and `tp-layers' holds the layers below it. + +When full-stack storage is active, an external direct-property edit +cannot be assigned to a managed layer safely. Rather than discard it, +signal `tp-layer-conflict' before decoding or rebuilding the stack." (let* ((idx (-elem-index 'tp-layers props)) (top (if idx (-remove-at-indices (list idx (1+ idx)) props) props)) (belows (plist-get props 'tp-layers))) - (if (seq-some #'tp--stack-hidden-p belows) - belows + (if (tp--entry-authoritative-storage-p belows) + (progn + (tp--assert-hidden-render-cache top belows) + belows) (tp--layer-stack-to-list top belows)))) (defun tp--stack-build-props (layer-list) @@ -1547,18 +1670,19 @@ garbage (tp-layers nil) property. Consumers must therefore tolerate an absent `tp-layers' property (both `plist-get' and `tp--stack-map-region' do). -When any layer in LAYER-LIST is hidden (non-nil `tp-hidden' entry, -see `tp-hide-layer'), the storage switches to full-stack mode: the -direct properties are those of the topmost non-hidden layer (or no -layer properties at all when every layer is hidden) and the -`tp-layers' property holds the complete ordered LAYER-LIST. -`tp--stack-props-to-list' reverses either representation." +When any layer in LAYER-LIST is hidden or carries `tp-meta', the +storage switches to full-stack mode: the direct properties are the +render projection of the topmost non-hidden layer (or no layer +properties at all when every layer is hidden) and the `tp-layers' +property holds the complete ordered LAYER-LIST. `tp--stack-props-to-list' +reverses either representation." (cond ((null layer-list) nil) - ((seq-some #'tp--stack-hidden-p layer-list) - (append (seq-find (lambda (layer) - (not (tp--stack-hidden-p layer))) - layer-list) + ((tp--entry-authoritative-storage-p layer-list) + (append (tp--entry-render-projection + (seq-find (lambda (layer) + (not (tp--stack-hidden-p layer))) + layer-list)) (list 'tp-layers layer-list))) ((null (cdr layer-list)) (copy-sequence (car layer-list))) (t (append (car layer-list) diff --git a/tp-managed-tests.el b/tp-managed-tests.el new file mode 100644 index 0000000..d5c0110 --- /dev/null +++ b/tp-managed-tests.el @@ -0,0 +1,303 @@ +;;; tp-managed-tests.el --- ERT tests for managed lifecycle APIs -*- lexical-binding: t -*- + +;;; Commentary: + +;; Stage 4 RED tests for additive managed lifecycle behavior. These +;; tests intentionally drive public entry points and should fail until +;; managed metadata, diagnostics, transactions, and theme generation are +;; implemented. + +;;; Code: + +(require 'ert) +(require 'tp) + +(defmacro tp-managed-tests--with-clean (&rest body) + "Run BODY in a temp buffer with clean layer/reactive state." + (declare (indent 0)) + `(unwind-protect + (with-temp-buffer + (tp-layer-reset) + (tp-reactive-reset) + (setq tp-reactive-observer-errors nil) + ,@body) + (tp-layer-reset) + (tp-reactive-reset) + (setq tp-reactive-observer-errors nil))) + +(defun tp-managed-tests--require-api (fn) + "Assert FN exists and return its function binding." + (should (fboundp fn)) + (symbol-function fn)) + +(defun tp-managed-tests--raw-intervals () + "Return raw text and property intervals for the current buffer." + (list (buffer-substring-no-properties (point-min) (point-max)) + (tp-intervals (point-min) (point-max) nil t))) + +(defun tp-managed-tests--managed-buffer-diagnostics () + "Call `tp-managed-buffer-diagnostics' after asserting it exists." + (tp-managed-tests--require-api 'tp-managed-buffer-diagnostics) + (tp-managed-buffer-diagnostics (current-buffer))) + +(defun tp-managed-tests--managed-layer-diagnostics (layer) + "Call `tp-managed-layer-diagnostics' for LAYER after asserting it exists." + (tp-managed-tests--require-api 'tp-managed-layer-diagnostics) + (tp-managed-layer-diagnostics layer)) + +(defun tp-managed-tests--managed-diagnostics () + "Call `tp-managed-diagnostics' after asserting it exists." + (tp-managed-tests--require-api 'tp-managed-diagnostics) + (tp-managed-diagnostics)) + +(ert-deftest tp-managed-test-metadata-is-not-public-stack-or-rendered () + "Managed tp-meta is stripped from public stack query and rendered props." + (tp-managed-tests--with-clean + (insert "abcd") + (tp-put-layer 1 4 + '(stage4-visible + face (:foreground "red") + help-echo "visible" + tp-meta (:schema 1 + :entry-id stage4-entry-a + :origin inline + :args ("red" 7))) + 0) + (let* ((stack (tp-layer-stack-at 1)) + (top (cdr (assq 'stage4-visible stack))) + (rendered (text-properties-at 1))) + (should (assq 'stage4-visible stack)) + (should-not (plist-member top 'tp-meta)) + (should-not (plist-member rendered 'tp-meta)) + (should (equal (plist-get rendered 'face) '(:foreground "red"))) + (should (equal (plist-get rendered 'help-echo) "visible"))))) + +(ert-deftest tp-managed-test-parameterized-mounted-layer-retains-args () + "Parameterized mounted layer diagnostics retain each entry's args." + (tp-managed-tests--with-clean + (insert "abcdefgh") + (define-tp stage4-color (fg bg) + `(face (:foreground ,fg :background ,bg))) + (tp-put-layer 1 4 '(stage4-color "red" "blue") 0) + (tp-put-layer 5 8 '(stage4-color "green" "black") 0) + (let* ((diag (tp-managed-tests--managed-layer-diagnostics 'stage4-color)) + (entries (plist-get diag :entries)) + (args (mapcar (lambda (entry) (plist-get entry :args)) entries))) + (should (member '("red" "blue") args)) + (should (member '("green" "black") args))))) + +(ert-deftest tp-managed-test-parameterized-mounted-layer-refreshes-after-redefine () + "Parameterized mounted entries re-render from stored args after redefine." + (tp-managed-tests--with-clean + (insert "abcdefgh") + (define-tp stage4-redef (fg bg) + `(face (:foreground ,fg :background ,bg))) + (tp-put-layer 1 4 '(stage4-redef "red" "blue") 0) + (tp-put-layer 5 8 '(stage4-redef "green" "black") 0) + (define-tp stage4-redef (fg bg) + `(face (:foreground ,fg :background ,bg :weight bold))) + (should (equal (get-text-property 1 'face) + '(:foreground "red" :background "blue" :weight bold))) + (should (equal (get-text-property 5 'face) + '(:foreground "green" :background "black" :weight bold))))) + +(ert-deftest tp-managed-test-attach-finds-inserted-managed-string () + "Attach registers layers copied in through a propertized string." + (tp-managed-tests--with-clean + (define-tp stage4-attached () '(face (:box t))) + (let ((payload (copy-sequence "xy"))) + (tp-put-layer payload 'stage4-attached 0) + (insert payload)) + (tp-managed-tests--require-api 'tp-attach-managed-layers) + (should (equal (tp-attach-managed-layers 1 3 (current-buffer)) + '(stage4-attached))) + (should (equal (tp-reactive-layer-buffers 'stage4-attached) + (list (current-buffer)))))) + +(ert-deftest tp-managed-test-detach-removes-managed-storage-and-keeps-rendered () + "Detach with KEEP-RENDERED removes managed storage but preserves visible props." + (tp-managed-tests--with-clean + (insert "abcd") + (define-tp stage4-detach () '(face italic help-echo "kept")) + (tp-put-layer 1 4 'stage4-detach 0) + (tp-managed-tests--require-api 'tp-detach-managed-layers) + (should (equal (tp-detach-managed-layers 1 4 (current-buffer) t) + '(stage4-detach))) + (should-not (plist-member (text-properties-at 1) 'tp-layers)) + (should-not (plist-member (text-properties-at 1) 'tp-meta)) + (should-not (plist-member (text-properties-at 1) 'tp-name)) + (should (eq (get-text-property 1 'face) 'italic)) + (should (equal (get-text-property 1 'help-echo) "kept")) + (should-not (tp-reactive-layer-buffers 'stage4-detach)))) + +(ert-deftest tp-managed-test-buffer-diagnostics-are-read-only () + "Managed buffer diagnostics do not mutate text, props, point, or modified state." + (tp-managed-tests--with-clean + (insert "abcd") + (define-tp stage4-diag () '(face bold)) + (tp-put-layer 1 4 'stage4-diag 0) + (goto-char 3) + (set-buffer-modified-p nil) + (let ((before-state (tp-managed-tests--raw-intervals)) + (before-point (point)) + (before-modified (buffer-modified-p)) + (before-undo buffer-undo-list)) + (let ((diag (tp-managed-tests--managed-buffer-diagnostics))) + (should (plist-member diag :layers)) + (should (member 'stage4-diag (plist-get diag :layers)))) + (should (equal (tp-managed-tests--raw-intervals) before-state)) + (should (= (point) before-point)) + (should (eq (buffer-modified-p) before-modified)) + (should (eq buffer-undo-list before-undo))))) + +(ert-deftest tp-managed-test-layer-transaction-rolls-back-on-body-error () + "tp-layer-transaction restores raw properties when the body errors." + (tp-managed-tests--with-clean + (insert "abcdef") + (define-tp stage4-base () '(face bold help-echo "base")) + (define-tp stage4-temp () '(face italic help-echo "temp")) + (tp-put-layer 1 6 'stage4-base 0) + (let ((before (tp-managed-tests--raw-intervals))) + (tp-managed-tests--require-api 'tp-layer-transaction) + (let ((err (should-error + (tp-layer-transaction + 1 6 (current-buffer) + (lambda () + (tp-put-layer 1 3 'stage4-temp 0) + (error "stage4 boom")))))) + (should (eq (car err) 'tp-layer-transaction-error))) + (should (equal (tp-managed-tests--raw-intervals) before))))) + +(ert-deftest tp-managed-test-buffer-transaction-rolls-back-length-changes () + "Buffer rollback tracks insertions and deletions inside the live range." + (dolist (mutation '(insert delete)) + (tp-managed-tests--with-clean + (insert (propertize "abcdef" 'face 'bold)) + (let ((before (buffer-substring (point-min) (point-max)))) + (should-error + (tp-layer-transaction + 2 5 (current-buffer) + (lambda () + (pcase mutation + ('insert + (goto-char 3) + (insert (propertize "XYZ" 'help-echo "temporary"))) + ('delete + (delete-region 3 4))) + (error "length-changing rollback")))) + (should (equal-including-properties + (buffer-substring (point-min) (point-max)) + before)))))) + +(ert-deftest tp-managed-test-layer-transaction-success-keeps-body-result () + "Successful transactions expose the body's result and changed ranges." + (tp-managed-tests--with-clean + (insert "abcd") + (define-tp stage4-success () '(face bold)) + (let ((result + (tp-layer-transaction + 1 4 (current-buffer) + (lambda () + (tp-push-layer 1 4 'stage4-success) + :body-result)))) + (should (eq (plist-get result :status) 'ok)) + (should (eq (plist-get result :ok) t)) + (should (eq (plist-get result :result) :body-result)) + (should (plist-get result :changed-ranges))))) + +(ert-deftest tp-managed-test-layer-transaction-noerror-returns-structured-failure () + "NOERROR transaction failures return operation data and rollback status." + (tp-managed-tests--with-clean + (insert "abcdef") + (define-tp stage4-base2 () '(face bold)) + (define-tp stage4-temp2 () '(face italic)) + (tp-put-layer 1 6 'stage4-base2 0) + (let ((before (tp-managed-tests--raw-intervals))) + (tp-managed-tests--require-api 'tp-layer-transaction) + (let ((result (tp-layer-transaction + 1 6 (current-buffer) + (lambda () + (tp-put-layer 2 5 'stage4-temp2 0) + (signal 'error '("stage4 noerror"))) + t))) + (should (eq (plist-get result :status) 'error)) + (should (plist-get result :operation-id)) + (should (plist-member result :stage)) + (should (equal (plist-get result :range) '(1 . 6))) + (should (eq (plist-get result :rollback-applied) t)) + (should (plist-get result :original-condition))) + (should (equal (tp-managed-tests--raw-intervals) before))))) + +(ert-deftest tp-managed-test-string-transaction-restores-every-property-run () + "String rollback restores characters and every distinct property run." + (tp-managed-tests--with-clean + (let ((text (copy-sequence "abcdef"))) + (put-text-property 0 2 'face 'bold text) + (put-text-property 2 4 'face 'italic text) + (put-text-property 4 6 'help-echo "tail" text) + (let ((before (copy-sequence text))) + (should-error + (tp-layer-transaction + 0 6 text + (lambda () + (set-text-properties 0 6 '(face underline) text) + (signal 'error '("rollback string"))))) + (should (equal-including-properties text before)))))) + +(ert-deftest tp-managed-test-fixed-seed-stack-state-machine () + "Fixed seeds preserve public stack order across varied operations." + (dolist (seed '(1 7 42 747555)) + (tp-managed-tests--with-clean + (insert "x") + (dolist (name '(stage4-sm-a stage4-sm-b stage4-sm-c)) + (eval `(define-tp ,name () '(face bold)))) + (let ((state seed) + (names '(stage4-sm-a stage4-sm-b stage4-sm-c)) + model) + (dotimes (_ 40) + (setq state (mod (+ (* state 1103515245) 12345) 2147483648)) + (pcase (% state 4) + (0 + (let ((name (nth (% (/ state 4) 3) names))) + (unless (memq name model) + (tp-push-layer 1 2 name) + (push name model)))) + (1 + (when model + (tp-pop-layer 1 2) + (setq model (cdr model)))) + (2 + (when (cdr model) + (tp-move-layer 1 2 0 -1) + (setq model (append (cdr model) (list (car model)))))) + (3 + (when model + (tp-hide-layer 1 2 (car model)) + (tp-show-layer 1 2 (car model))))) + (should (equal (mapcar #'car (tp-layer-stack-at 1)) model))))))) + +(ert-deftest tp-managed-test-theme-generation-diagnostics-increments-on-theme-hooks () + "Theme lifecycle diagnostics record generation and hook source." + (tp-managed-tests--with-clean + (insert "abcd") + (define-tp stage4-theme () '(face (:foreground "red"))) + (tp-put-layer 1 4 'stage4-theme 0) + (let* ((before (tp-managed-tests--managed-diagnostics)) + (before-theme (plist-get before :theme)) + (before-generation (plist-get before-theme :generation))) + (should (integerp before-generation)) + (enable-theme 'user) + (let* ((after-enable (tp-managed-tests--managed-diagnostics)) + (theme (plist-get after-enable :theme))) + (should (> (plist-get theme :generation) before-generation)) + (should (eq (plist-get theme :last-hook-source) 'enable-theme)) + (should (member (plist-get theme :refresh-mode) + '(:dependency-targeted :conservative))) + (should (plist-get theme :refreshed-ranges))) + (disable-theme 'user) + (let* ((after-disable (tp-managed-tests--managed-diagnostics)) + (theme (plist-get after-disable :theme))) + (should (eq (plist-get theme :last-hook-source) 'disable-theme)))))) + +(provide 'tp-managed-tests) +;;; tp-managed-tests.el ends here diff --git a/tp-native-tests.el b/tp-native-tests.el new file mode 100644 index 0000000..b7addfc --- /dev/null +++ b/tp-native-tests.el @@ -0,0 +1,210 @@ +;;; tp-native-tests.el --- Native text-property equivalence tests -*- lexical-binding: t -*- + +;;; Commentary: + +;; Stage 3/5 tests for the explicit GNU Emacs text/character property +;; compatibility boundary. Tests compare tp entry points with public Emacs +;; primitives rather than duplicating their expected implementation. + +;;; Code: + +(require 'ert) +(require 'tp) + +(ert-deftest tp-native-test-lookup-direct-presence-states () + "Direct lookup distinguishes absence, explicit nil, and a value." + (let ((str (copy-sequence "abc"))) + (put-text-property 0 1 'state nil str) + (put-text-property 1 2 'state 'ready str) + (let ((nil-value (tp-lookup 0 'state :object str :mode :text-direct)) + (value (tp-lookup 1 'state :object str :mode :text-direct)) + (absent (tp-lookup 2 'state :object str :mode :text-direct))) + (should (tp-lookup-result-present-p nil-value)) + (should-not (tp-lookup-result-value nil-value)) + (should (eq (tp-lookup-result-source nil-value) :text-direct)) + (should (tp-lookup-result-present-p value)) + (should (eq (tp-lookup-result-value value) 'ready)) + (should-not (tp-lookup-result-present-p absent)) + (should (eq (tp-lookup-result-source absent) :absent))))) + +(ert-deftest tp-native-test-lookup-effective-source-matrix () + "Source lookup explains direct, category, alias, and default values. +Like native lookup, a nil alias value falls through to the default." + (let* ((str (copy-sequence "abcd")) + (category (make-symbol "tp-native-category")) + (char-property-alias-alist '((state alternate))) + (default-text-properties '(state default))) + (put category 'state 'category) + (put-text-property 0 1 'state nil str) + (put-text-property 1 2 'category category str) + (put-text-property 2 3 'alternate 'alias str) + (put-text-property 3 4 'alternate nil str) + (dolist (case '((0 nil :text-direct) + (1 category :category) + (2 alias :alias) + (3 default :default))) + (pcase-let ((`(,position ,value ,source) case)) + (let ((result (tp-lookup + position 'state :object str :mode :text-source))) + (should (tp-lookup-result-present-p result)) + (should (equal (tp-lookup-result-value result) value)) + (should (eq (tp-lookup-result-source result) source)) + (should (equal + (tp-lookup-result-value + (tp-lookup position 'state + :object str :mode :text-effective)) + (get-text-property position 'state str)))))))) + +(ert-deftest tp-native-test-property-change-matches-emacs () + "Single/all and next/previous change queries match Emacs primitives." + (let ((str (copy-sequence "abcdef"))) + (put-text-property 0 3 'state 1 str) + (put-text-property 3 6 'state 2 str) + (put-text-property 1 2 'unrelated t str) + (should (equal + (tp-property-change + 0 :property 'state :object str :limit 6 :direction :next) + (next-single-property-change 0 'state str 6))) + (should (equal + (tp-property-change 0 :object str :limit 6 :direction :next) + (next-property-change 0 str 6))) + (should (equal + (tp-property-change + 6 :property 'state :object str :limit 0 :direction :previous) + (previous-single-property-change 6 'state str 0))) + (should (equal + (tp-property-change 6 :object str :limit 0 :direction :previous) + (previous-property-change 6 str 0))))) + +(ert-deftest tp-native-test-property-any-not-all-match-emacs () + "Region equality predicates preserve exact nil behavior." + (let ((str (copy-sequence "abcd"))) + (put-text-property 0 2 'state nil str) + (put-text-property 2 4 'state 'ready str) + (dolist (value '(nil ready missing)) + (should (equal (tp-property-any 0 4 'state value str) + (text-property-any 0 4 'state value str))) + (should (equal (tp-property-not-all 0 4 'state value str) + (text-property-not-all 0 4 'state value str)))))) + +(ert-deftest tp-native-test-mutation-policy-respect-and-inhibit () + "Read-only override is explicit and ordinary mode records changes." + (with-temp-buffer + (insert "abc") + (put-text-property 1 2 'read-only t) + (should-error + (tp-with-mutation-policy + '(:modified :ordinary :read-only :respect) + (tp-set 1 2 '(face bold)))) + (tp-with-mutation-policy + '(:modified :ordinary :read-only :inhibit) + (tp-set 1 2 '(face bold))) + (should (eq (get-text-property 1 'face) 'bold))) + (with-temp-buffer + (buffer-enable-undo) + (insert "abc") + (setq buffer-undo-list nil) + (set-buffer-modified-p nil) + (tp-with-mutation-policy + '(:modified :ordinary :read-only :respect) + (tp-set 1 2 '(face bold))) + (should (buffer-modified-p)) + (should (consp buffer-undo-list)))) + +(ert-deftest tp-native-test-mutation-policy-silent () + "Silent property writes keep modified and undo state unchanged." + (with-temp-buffer + (buffer-enable-undo) + (insert "abc") + (setq buffer-undo-list nil) + (set-buffer-modified-p nil) + (tp-with-mutation-policy + '(:modified :silent :read-only :inhibit) + (tp-set 1 2 '(face bold))) + (should (eq (get-text-property 1 'face) 'bold)) + (should-not (buffer-modified-p)) + (should-not buffer-undo-list)) + (should-error + (tp-with-mutation-policy + '(:modified :silent :read-only :respect) + nil)) + (should-error + (tp-with-mutation-policy '(:unknown t) nil)) + (should-error + (tp-with-mutation-policy '(:modified nil) nil)) + (should-error + (tp-with-mutation-policy '(:modified) nil))) + +(ert-deftest tp-native-test-stickiness-and-insertion-delegation () + "tp-set properties retain native insert and insert-and-inherit behavior." + (with-temp-buffer + (insert "ab") + (tp-set 1 2 '(face bold)) + (goto-char 2) + (insert "x") + (should-not (get-text-property 2 'face))) + (with-temp-buffer + (insert "ab") + (tp-set 1 2 '(face bold)) + (goto-char 2) + (insert-and-inherit "x") + (should (eq (get-text-property 2 'face) 'bold)))) + +(ert-deftest tp-native-test-copy-insert-and-yank-filtering () + "Copy and yank primitives preserve/filter tp-applied properties natively." + (let* ((source (tp-set "abcd" 'face 'bold 'secret 7)) + (copy (copy-sequence source)) + (slice (substring source 1 3))) + (should (equal-including-properties source copy)) + (should (eq (get-text-property 0 'face slice) 'bold)) + (with-temp-buffer + (let ((yank-excluded-properties '(secret))) + (insert-for-yank source)) + (should (eq (get-text-property 1 'face) 'bold)) + (should-not (get-text-property 1 'secret)) + (should (eq (get-text-property + 0 'face (buffer-substring 1 3)) + 'bold)) + (should-not (text-properties-at + 0 (buffer-substring-no-properties 1 3)))))) + +(ert-deftest tp-native-test-narrowing-and-indirect-buffer-coordinates () + "Public operations keep native positions across narrowing and indirection." + (let ((base (generate-new-buffer " *tp-native-base*")) + indirect) + (unwind-protect + (progn + (with-current-buffer base + (insert "abcdef") + (setq indirect + (make-indirect-buffer base " *tp-native-indirect*" t))) + (with-current-buffer indirect + (narrow-to-region 2 5) + (should (equal (tp-set 2 4 '(state shared)) '(2 . 4))) + (let ((result (tp-lookup 3 'state :mode :text-direct))) + (should (eq (tp-lookup-result-object result) indirect)) + (should (= (tp-lookup-result-position result) 3)) + (should (eq (tp-lookup-result-value result) 'shared)))) + (with-current-buffer base + (should (eq (get-text-property 3 'state) 'shared)))) + (when (buffer-live-p indirect) (kill-buffer indirect)) + (when (buffer-live-p base) (kill-buffer base))))) + +(ert-deftest tp-native-test-emacs-28-required-primitives-exist () + "The selected native mapping stays within the Emacs 28.1 baseline." + (dolist (function '(object-intervals + text-property-search-forward + text-property-search-backward + make-prop-match + with-silent-modifications + overlays-at + get-char-property + get-char-property-and-overlay + text-property-any + text-property-not-all + previous-single-property-change + previous-property-change)) + (should (fboundp function)))) + +(provide 'tp-native-tests) +;;; tp-native-tests.el ends here diff --git a/tp-ops-tests.el b/tp-ops-tests.el index 7c10db5..387010f 100644 --- a/tp-ops-tests.el +++ b/tp-ops-tests.el @@ -278,5 +278,54 @@ (should (equal (tp-member 1 'my-prop) '(my-prop nil))) (should (equal (tp-member 1 'other) nil)))) +;;; Stage 2 canonical operation requests + +(ert-deftest tp-ops-test-parser-builds-canonical-string-request () + "The flexible string parser ends at one canonical request." + (let* ((str (copy-sequence "hello")) + (request (tp--parse-args str 'face 'bold nil :set)) + (range (tp--request-range request))) + (should (tp--request-p request)) + (should (eq (tp--request-operation request) :set)) + (should (equal (tp--request-props request) '(face bold))) + (should (eq (tp--request-mutation request) :copy)) + (should (eq (tp--request-public-return request) :object)) + (should (eq (tp--native-range-object range) str)) + (should (equal (list (tp--native-range-start range) + (tp--native-range-end range)) + '(0 5))))) + +(ert-deftest tp-ops-test-parser-builds-canonical-buffer-request () + "The region parser resolves nil to a concrete current-buffer range." + (with-temp-buffer + (insert "hello") + (let* ((request (tp--parse-args 2 5 '(face bold) nil :add)) + (range (tp--request-range request))) + (should (eq (tp--request-operation request) :add)) + (should (eq (tp--request-mutation request) :in-place)) + (should (eq (tp--request-public-return request) :range)) + (should (eq (tp--native-range-object range) (current-buffer))) + (should (equal (list (tp--native-range-start range) + (tp--native-range-end range)) + '(2 5)))))) + +;;; TP-A05: removing the last sub-property removes its parent key + +(ert-deftest tp-ops-test-remove-last-sub-key-removes-string-parent () + "String sub-property removal does not leave a present nil parent." + (let* ((str (propertize "x" 'face '(:underline t))) + (result (tp-remove str 'face :underline))) + (should-not (tp-member 0 'face result)))) + +(ert-deftest tp-ops-test-remove-last-sub-key-string-buffer-parity () + "String and buffer removal both omit an emptied parent property." + (let* ((str (propertize "x" 'face '(:underline t))) + (result (tp-remove str 'face :underline))) + (should-not (plist-member (text-properties-at 0 result) 'face))) + (with-temp-buffer + (insert (propertize "x" 'face '(:underline t))) + (tp-remove 1 2 '(face :underline)) + (should-not (plist-member (text-properties-at 1) 'face)))) + (provide 'tp-ops-tests) ;;; tp-ops-tests.el ends here diff --git a/tp-ops.el b/tp-ops.el index 02c6d7c..b56540f 100644 --- a/tp-ops.el +++ b/tp-ops.el @@ -48,35 +48,34 @@ Searches through `tp-reactive-deps' to find the original reactive props." nil)) (defun tp--tp-text-transform (layer-name text) - "Return TEXT transformed by LAYER-NAME's `:transform', or TEXT. -Transform errors are reported and TEXT is returned unchanged; a -non-string transform result is ignored as well." + "Return TEXT transformed by LAYER-NAME's `:transform'. +Signal when the transform fails or returns a non-string value." (let ((transform-fn (when layer-name (cdr (assoc layer-name tp-layer-transforms))))) (if (not transform-fn) text - (condition-case err - (let ((result (funcall transform-fn text))) - (tp-debug-log " Transform %s: %S -> %S" layer-name text result) - (if (stringp result) result text)) - (error - (message "tp: transform error for %s: %s" layer-name err) - text))))) + (let ((result (funcall transform-fn text))) + (unless (stringp result) + (error "tp: transform for %s returned non-string %S" + layer-name result)) + (tp-debug-log " Transform %s: %S -> %S" layer-name text result) + result)))) (defun tp--merge-embedded-props (embedded props) "Merge the EMBEDDED string props plist under PROPS; PROPS win. -Like `tp--merge-string-props-into-plist' but takes the embedded plist -directly instead of sampling position 0 of a string, so callers can -merge per property interval. Face-family values (see +Takes one property run's EMBEDDED plist, so callers preserve every +interval instead of treating position 0 as representative. +Face-family values (see `tp-face-properties') are merged with PROPS taking precedence; other conflicting keys keep the PROPS value; keys only in EMBEDDED are added." (let ((result (copy-sequence props))) (cl-loop for (key val) on embedded by #'cddr - do (let ((existing (plist-get result key))) + do (let ((present (plist-member result key)) + (existing (plist-get result key))) (setq result (plist-put result key - (if existing + (if present (if (memq key tp-face-properties) (tp--merge-face-values val existing) existing) @@ -90,13 +89,54 @@ holds a value `equal' to VAL for KEY the call is skipped, so an update that changes nothing does not flip the buffer-modified flag. OBJECT is a string, a buffer, or nil for the current buffer." (when (< start end) - (unless (and (equal (get-text-property start key object) val) + (unless (and (plist-member (text-properties-at start object) key) + (equal (get-text-property start key object) val) (>= (or (next-single-property-change start key object end) end) end)) (put-text-property start end key val object)))) -(defun tp--apply-reactive-text-props (source props offset &optional target) +(defun tp--value-after-add (key existing incoming) + "Return EXISTING after adding INCOMING for property KEY." + (cond + ((memq key tp-face-properties) + (tp--prepend-face incoming existing)) + ((and (listp incoming) (keywordp (car-safe incoming)) + (listp existing) (keywordp (car-safe existing))) + (tp--deep-merge-plist existing incoming)) + (t incoming))) + +(defun tp--props-after-add (existing incoming) + "Return EXISTING with INCOMING applied using `tp-add' semantics." + (let ((result (copy-sequence existing))) + (cl-loop + for (key val) on incoming by #'cddr + do (setq result + (plist-put + result key + (tp--value-after-add key (plist-get result key) val)))) + result)) + +(defun tp--apply-props-by-operation (start end props target operation) + "Apply PROPS to TARGET from START to END according to OPERATION." + (let ((pos start)) + (while (< pos end) + (let* ((next (or (next-property-change pos target end) end)) + (existing (text-properties-at pos target))) + (pcase operation + (:reset + (set-text-properties pos next props target)) + (:add + (set-text-properties + pos next (tp--props-after-add existing props) target)) + (_ + (cl-loop for (key val) on props by #'cddr + do (tp--put-text-property-unless-equal + pos next key val target)))) + (setq pos next))))) + +(defun tp--apply-reactive-text-props + (source props offset &optional target operation) "Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET. SOURCE is the (possibly propertized) replacement string; TARGET is a string, or nil for the current buffer. For every embedded-property @@ -104,37 +144,40 @@ interval of SOURCE the interval's props are merged under PROPS (see `tp--merge-embedded-props') and the result is applied to the corresponding span of TARGET shifted by OFFSET. This keeps per-interval styling of propertized reactive strings intact instead -of smearing position-0 props across the whole region. Spans that -already carry an `equal' value are left untouched, so an update that -changes nothing does not mark the buffer as modified." +of smearing position-0 props across the whole region. + +OPERATION is `:reset', `:add', or nil for ordinary set semantics. +Ordinary set spans that already carry an `equal' value are left +untouched, so an update that changes nothing does not mark the buffer +as modified." (tp--map-intervals source nil nil (lambda (istart iend str-props) (let ((merged (if str-props (tp--merge-embedded-props str-props props) props))) - (cl-loop for (key val) on merged by #'cddr - do (tp--put-text-property-unless-equal - (+ offset istart) (+ offset iend) key val target)))))) + (tp--apply-props-by-operation + (+ offset istart) (+ offset iend) merged target operation))))) -(defun tp--tp-text-replace (start end final-text result-props object preserve-props) +(defun tp--tp-text-replace + (start end final-text props object preserve-props operation) "Replace [START, END) of OBJECT with FINAL-TEXT, handling props. Implements the text replacement of `tp--handle-tp-text-property' and -returns its (PROPS NEW-END NEW-OBJECT) result. +returns its (PROPS NEW-END NEW-OBJECT PROPS-APPLIED) result. For a string OBJECT a NEW string is built as prefix + FINAL-TEXT + -suffix, so text outside the region survives. RESULT-PROPS (merged -per embedded interval of FINAL-TEXT) are applied to the replaced span -here, because callers can only apply props from index 0, which would -smear them over the preserved prefix; the returned NEW-END is 0 so -the caller's own application over [0, NEW-END) is a no-op. +suffix, so text outside the region survives. For strings and buffers, +PROPS are merged under every embedded property interval of FINAL-TEXT +and applied here through `tp--apply-reactive-text-props'. The final +non-nil return element tells callers not to flatten PROPS over the +whole replacement afterward. -For buffers the region text is replaced in place and the returned -NEW-END is the end of the inserted text; the caller applies -RESULT-PROPS itself. +For buffers the region text is replaced in place and NEW-END is the +end of the inserted text. When PRESERVE-PROPS is non-nil, properties present at START whose -keys RESULT-PROPS does not set are re-applied over the replacement." +keys PROPS does not set are re-applied over the replacement. +OPERATION selects ordinary set, `:reset', or `:add' semantics." (if (stringp object) (let* ((plain (substring-no-properties final-text)) ;; Splice: keep the string outside [start, end) intact. @@ -146,17 +189,21 @@ keys RESULT-PROPS does not set are re-applied over the replacement." (text-properties-at start object)))) ;; Preserve non-conflicting existing props of the replaced region (cl-loop for (key val) on existing-props by #'cddr - do (unless (plist-member result-props key) - (put-text-property start new-end key val new-string))) + when (or (eq operation :add) + (not (plist-member props key))) + do (put-text-property start new-end key val new-string)) ;; Apply the merged props per embedded interval of FINAL-TEXT - (tp--apply-reactive-text-props final-text result-props start new-string) - (list result-props 0 new-string)) + (tp--apply-reactive-text-props + final-text props start new-string operation) + (list props new-end new-string t)) ;; Buffer object (with-current-buffer (or object (current-buffer)) (let ((old-text (buffer-substring-no-properties start end))) (if (equal old-text (substring-no-properties final-text)) - ;; Same text content, no replacement needed - (list result-props end object) + (progn + (tp--apply-reactive-text-props + final-text props start object operation) + (list props end object t)) ;; Need to replace text (let ((existing-props (when preserve-props (text-properties-at start))) @@ -169,9 +216,12 @@ keys RESULT-PROPS does not set are re-applied over the replacement." (let ((new-end (+ start (length final-text)))) ;; Re-apply existing properties to new text region if preserving (cl-loop for (key val) on existing-props by #'cddr - do (unless (plist-member result-props key) - (put-text-property start new-end key val object))) - (list result-props new-end object)))))))) + when (or (eq operation :add) + (not (plist-member props key))) + do (put-text-property start new-end key val object)) + (tp--apply-reactive-text-props + final-text props start object operation) + (list props new-end object t)))))))) (defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode) "Handle tp-text property in PROPS for region from START to END in OBJECT. @@ -182,19 +232,22 @@ the reactive variable and the `tp-text' property - keeps the raw text. If tp-text is a string different from current text, replace the text. When PRESERVE-PROPS is non-nil, existing text properties are preserved on the replaced text (used by tp-set and tp-add). -MERGE-MODE is retained for backward compatibility but no longer -affects behavior. +MERGE-MODE selects `:reset', `:merge' (`tp-add'), or ordinary +`tp-set' behavior. All modes now preserve embedded text properties from tp-text, with props taking precedence over embedded props when there's a conflict. -Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props, -NEW-END is the new end position after any text replacement, and +Returns (PROPS NEW-END NEW-OBJECT PROPS-APPLIED), where PROPS is the +updated props, NEW-END is the new end position after replacement, and NEW-OBJECT is the new string object (only different for strings whose -text was replaced; see `tp--tp-text-replace' for the string-object -convention of a 0 NEW-END with pre-applied properties)." - (ignore merge-mode) - (if (not (plist-member props 'tp-text)) +text was replaced). PROPS-APPLIED is non-nil when replacement props +were already applied per embedded interval." + (let ((operation (pcase merge-mode + (:reset :reset) + (:merge :add) + (_ nil)))) + (if (not (plist-member props 'tp-text)) ;; tp-text not in props - return unchanged - (list props end object) + (list props end object nil) (let ((tp-text-val (plist-get props 'tp-text)) (layer-name (plist-get props 'tp-name))) (cond @@ -224,29 +277,21 @@ convention of a 0 NEW-END with pre-applied properties)." ;; render too, so the initial rendering matches later reactive ;; updates. The model value stays the raw text. (let ((display-text (tp--tp-text-transform layer-name current-text))) - (if (equal display-text current-text) - (list props end object) - (tp--tp-text-replace - start end display-text - (tp--merge-string-props-into-plist display-text props) - object preserve-props))))) + (tp--tp-text-replace + start end display-text props object preserve-props + operation)))) ;; tp-text has a string value - replace the text in the region ((stringp tp-text-val) ;; Apply transform if layer has one registered - (let* ((final-text (tp--tp-text-transform layer-name tp-text-val)) - ;; Embedded text properties from tp-text are preserved in all - ;; cases. The props passed to this function take precedence - ;; over embedded props when there's a conflict (e.g. both have - ;; a `face' property). - (result-props - (tp--merge-string-props-into-plist final-text props))) - (tp--tp-text-replace start end final-text result-props - object preserve-props))) + (let ((final-text (tp--tp-text-transform layer-name tp-text-val))) + (tp--tp-text-replace start end final-text props + object preserve-props operation))) ;; Other types - return unchanged - (t (list props end object)))))) + (t (list props end object nil))))))) -(defun tp--parse-args (start-or-string end-or-prop props-or-val rest) - "Parse flexible function arguments and return (OBJECT START END PROPS). +(defun tp--parse-args (start-or-string end-or-prop props-or-val rest + &optional operation) + "Parse flexible function arguments and return a canonical request. Supports multiple calling conventions: 1. Buffer region: (START END PROPS) 2. Buffer region with object: (START END PROPS OBJECT) @@ -314,7 +359,18 @@ Supports multiple calling conventions: ;; Resolve props: handles layer/group names and anonymous reactive plists (when props (setq props (or (tp--resolve-props props) props))) - (list object start finish props))) + (let ((range (tp--native-range-from-object object start finish))) + (tp--make-request + :operation operation + :range range + :props props + :mutation (if (and (stringp start-or-string) + (stringp (tp--native-range-object range))) + :copy + :in-place) + :public-return (if (stringp (tp--native-range-object range)) + :object + :range))))) (defun tp--ops-register-layer-buffer (props object) "Record OBJECT in the reactive buffer registry for PROPS's layer. @@ -407,37 +463,49 @@ For tp-text, props override embedded text properties. Returns: For buffers, (START . END) cons. For strings, the result string." ;; Determine if this is the "entire string" form (first arg is a string) (let ((entire-string-form (stringp start-or-string))) - (pcase-let ((`(,object ,start ,finish ,props) - (tp--parse-args start-or-string end-or-prop props-or-val rest))) + (let* ((request (tp--parse-args start-or-string end-or-prop + props-or-val rest :set)) + (range (tp--request-range request)) + (object (tp--native-range-object range)) + (start (tp--native-range-start range)) + (finish (tp--native-range-end range)) + (props (tp--request-props request))) ;; Handle tp-text property specially - :override means props override embedded props - (pcase-let ((`(,new-props ,new-finish ,new-object) + (pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied) (tp--handle-tp-text-property start finish props object t :override))) (setq props new-props finish new-finish object new-object) - (when (and (stringp object) (plist-member props 'tp-text)) - (setq start 0))) - (cond - ;; Entire string form: create a new propertized string (non-destructive) - ((and (stringp object) entire-string-form) - (tp--apply-props-to-string object start finish props nil)) - ;; Region form with string object: modify in-place - ((stringp object) - (let ((has-existing-props (text-properties-at start object))) - (if (and (not has-existing-props) - (= start (or (next-single-property-change start nil object finish) finish))) - (set-text-properties start finish props object) - (cl-loop for (key val) on props by #'cddr - do (put-text-property start finish key val object)))) - object) - ;; Buffer: modify in place - (t - (let ((has-existing-props (text-properties-at start object))) - (if (and (not has-existing-props) - (= start (or (next-single-property-change start nil object finish) finish))) - (set-text-properties start finish props object) - (cl-loop for (key val) on props by #'cddr - do (put-text-property start finish key val object)))) - (tp--ops-register-layer-buffer props object) - (cons start finish)))))) + (cond + (props-applied + (if (stringp object) + object + (tp--ops-register-layer-buffer props object) + (cons start finish))) + ;; Entire string form: create a new propertized string (non-destructive) + ((and (stringp object) entire-string-form) + (tp--apply-props-to-string object start finish props nil)) + ;; Region form with string object: modify in-place + ((stringp object) + (let ((has-existing-props (text-properties-at start object))) + (if (and (not has-existing-props) + (= start (or (next-single-property-change + start nil object finish) + finish))) + (set-text-properties start finish props object) + (cl-loop for (key val) on props by #'cddr + do (put-text-property start finish key val object)))) + object) + ;; Buffer: modify in place + (t + (let ((has-existing-props (text-properties-at start object))) + (if (and (not has-existing-props) + (= start (or (next-single-property-change + start nil object finish) + finish))) + (set-text-properties start finish props object) + (cl-loop for (key val) on props by #'cddr + do (put-text-property start finish key val object)))) + (tp--ops-register-layer-buffer props object) + (cons start finish))))))) (defun tp-reset (start-or-string &optional end-or-prop props-or-val &rest rest) "Completely replace all text properties with PROPS. @@ -465,27 +533,35 @@ if there's a conflict). Returns: For buffers, (START . END) cons. For strings, the result string." ;; Determine if this is the "entire string" form (first arg is a string) (let ((entire-string-form (stringp start-or-string))) - (pcase-let ((`(,object ,start ,finish ,props) - (tp--parse-args start-or-string end-or-prop props-or-val rest))) + (let* ((request (tp--parse-args start-or-string end-or-prop + props-or-val rest :reset)) + (range (tp--request-range request)) + (object (tp--native-range-object range)) + (start (tp--native-range-start range)) + (finish (tp--native-range-end range)) + (props (tp--request-props request))) ;; Handle tp-text property - :reset means only use props, ignore embedded props - (pcase-let ((`(,new-props ,new-finish ,new-object) + (pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied) (tp--handle-tp-text-property start finish props object nil :reset))) (setq props new-props finish new-finish object new-object) - (when (and (stringp object) (plist-member props 'tp-text)) - (setq start 0))) - (cond - ;; Entire string form: create a new propertized string (non-destructive) - ((and (stringp object) entire-string-form) - (tp--apply-props-to-string object start finish props :reset)) - ;; Region form with string object: modify in-place - ((stringp object) - (set-text-properties start finish props object) - object) - ;; Buffer: modify in place - (t - (set-text-properties start finish props object) - (tp--ops-register-layer-buffer props object) - (cons start finish)))))) + (cond + (props-applied + (if (stringp object) + object + (tp--ops-register-layer-buffer props object) + (cons start finish))) + ;; Entire string form: create a new propertized string (non-destructive) + ((and (stringp object) entire-string-form) + (tp--apply-props-to-string object start finish props :reset)) + ;; Region form with string object: modify in-place + ((stringp object) + (set-text-properties start finish props object) + object) + ;; Buffer: modify in place + (t + (set-text-properties start finish props object) + (tp--ops-register-layer-buffer props object) + (cons start finish))))))) (defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest) "Add or update text properties with deep merging. @@ -515,67 +591,64 @@ For tp-text, embedded text properties are merged with props. Returns: For buffers, (START . END) cons. For strings, the result string." ;; Determine if this is the "entire string" form (first arg is a string) (let ((entire-string-form (stringp start-or-string))) - (pcase-let ((`(,object ,start ,finish ,props) - (tp--parse-args start-or-string end-or-prop props-or-val rest))) + (let* ((request (tp--parse-args start-or-string end-or-prop + props-or-val rest :add)) + (range (tp--request-range request)) + (object (tp--native-range-object range)) + (start (tp--native-range-start range)) + (finish (tp--native-range-end range)) + (props (tp--request-props request))) ;; Handle tp-text property - :merge means embedded props are merged with props (let ((has-tp-text (plist-member props 'tp-text))) - (pcase-let ((`(,new-props ,new-finish ,new-object) + (pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied) (tp--handle-tp-text-property start finish props object t :merge))) (setq props new-props finish new-finish object new-object) - (when (and (stringp object) has-tp-text) - (setq start 0)))) - (cond - ;; Entire string form: create a new propertized string (non-destructive) - ((and (stringp object) entire-string-form) - (if (plist-member props 'tp-text) - ;; For tp-text: tp--handle-tp-text-property has already merged embedded - ;; properties with props (in :merge mode above). The new-object is a - ;; fresh string with tp-text content, and new-props contains all merged - ;; properties. We use :reset mode here to simply apply these final - ;; merged properties to the new string, without re-merging with any - ;; (non-existent) existing properties on the new string. - (tp--apply-props-to-string object start finish props :reset) - ;; Otherwise use :add mode for deep merging with any existing properties - (tp--apply-props-to-string object start finish props :add))) - ;; Region form with string object: modify in-place with deep merging - ((stringp object) - (let ((pos start)) - (while (< pos finish) - (let* ((current-props (text-properties-at pos object)) - (next-pos (or (next-property-change pos object finish) finish))) - (cl-loop - for (key val) on props by #'cddr - do (let* ((current-val (plist-get current-props key)) - (new-val (cond - ((memq key tp-face-properties) - (tp--prepend-face val current-val)) - ((and (listp val) (keywordp (car-safe val)) - (listp current-val) (keywordp (car-safe current-val))) - (tp--deep-merge-plist current-val val)) - (t val)))) - (put-text-property pos next-pos key new-val object))) - (setq pos next-pos)))) - object) - ;; Buffer: modify in place with deep merging - (t - (let ((pos start)) - (while (< pos finish) - (let* ((current-props (text-properties-at pos object)) - (next-pos (or (next-property-change pos object finish) finish))) - (cl-loop - for (key val) on props by #'cddr - do (let* ((current-val (plist-get current-props key)) - (new-val (cond - ((memq key tp-face-properties) - (tp--prepend-face val current-val)) - ((and (listp val) (keywordp (car-safe val)) - (listp current-val) (keywordp (car-safe current-val))) - (tp--deep-merge-plist current-val val)) - (t val)))) - (put-text-property pos next-pos key new-val object))) - (setq pos next-pos)))) - (tp--ops-register-layer-buffer props object) - (cons start finish)))))) + (cond + (props-applied + (if (stringp object) + object + (tp--ops-register-layer-buffer props object) + (cons start finish))) + ;; Entire string form: create a new propertized string (non-destructive) + ((and (stringp object) entire-string-form) + (if has-tp-text + (tp--apply-props-to-string object start finish props :reset) + (tp--apply-props-to-string object start finish props :add))) + ;; Region form with string object: modify in-place with deep merging + ((stringp object) + (let ((pos start)) + (while (< pos finish) + (let* ((current-props (text-properties-at pos object)) + (next-pos (or (next-property-change + pos object finish) + finish))) + (cl-loop + for (key val) on props by #'cddr + do (put-text-property + pos next-pos key + (tp--value-after-add + key (plist-get current-props key) val) + object)) + (setq pos next-pos)))) + object) + ;; Buffer: modify in place with deep merging + (t + (let ((pos start)) + (while (< pos finish) + (let* ((current-props (text-properties-at pos object)) + (next-pos (or (next-property-change + pos object finish) + finish))) + (cl-loop + for (key val) on props by #'cddr + do (put-text-property + pos next-pos key + (tp--value-after-add + key (plist-get current-props key) val) + object)) + (setq pos next-pos)))) + (tp--ops-register-layer-buffer props object) + (cons start finish)))))))) (defun tp-get (start-or-string &optional end-or-property &rest args) "Get text property value(s) with support for nested sub-properties. @@ -801,21 +874,18 @@ Examples: (when-let ((cell (plist-member plist property))) (list (car cell) (cadr cell))))) +(defun tp--value-after-sub-removal (value sub-property) + "Return VALUE after removing SUB-PROPERTY, or nil when empty." + (tp--remove-sub-from-face-value value sub-property)) + (defun tp--remove-sub (start end property sub-property &optional object) "Remove SUB-PROPERTY from PROPERTY between START and END in OBJECT." (let* ((pos start)) (while (< pos end) (let* ((current-value (get-text-property pos property object)) (next-pos (or (next-single-property-change pos property object end) end)) - (new-value - (cond - ;; Plist - remove the sub-property - ((and (listp current-value) (keywordp (car current-value))) - (let ((result (copy-sequence current-value))) - (cl-remf result sub-property) - (if result result nil))) - ;; Other types - leave unchanged - (t current-value)))) + (new-value (tp--value-after-sub-removal + current-value sub-property))) (if new-value (put-text-property pos next-pos property new-value object) (remove-text-properties pos next-pos (list property nil) object)) @@ -1058,15 +1128,17 @@ remaining properties." str start end (lambda (istart iend existing-props) (let* ((prop-value (plist-get existing-props property)) - ;; Use the helper to handle complex face values - (new-value (when prop-value - (tp--remove-sub-from-face-value prop-value sub-key))) + (new-value (tp--value-after-sub-removal prop-value sub-key)) (final-props (let ((res nil)) (cl-loop for (key val) on existing-props by #'cddr - do (setq res (plist-put res key - (if (eq key property) - new-value - val)))) + unless (and (eq key property) + (null new-value)) + do (setq res + (plist-put + res key + (if (eq key property) + new-value + val)))) res))) (set-text-properties istart iend final-props result)))) result)) diff --git a/tp-palette.el b/tp-palette.el index e30412d..4164b51 100644 --- a/tp-palette.el +++ b/tp-palette.el @@ -33,6 +33,46 @@ the library supports Emacs 28.1.") "Alist of (NAME . PLIST) palette definitions. This is the single source of truth for palette lookups.") +(defvar tp-theme-generation 0 + "Monotonic generation incremented after theme enable/disable events.") + +(defvar tp-theme-last-hook-source nil + "Most recent theme lifecycle function observed by tp.") + +(defvar tp-theme-last-refresh-mode nil + "Refresh strategy used for the most recent theme lifecycle event.") + +(defvar tp-theme-last-refreshed-ranges nil + "Managed ranges considered by the most recent theme refresh.") + +(defvar tp-theme-last-refresh-errors nil + "Structured failures from the most recent theme refresh.") + +(defvar tp-theme-change-hook nil + "Hook run after a theme lifecycle event. +Each function receives the source symbol, either `enable-theme' or +`disable-theme'. The palette module owns event detection only; +managed renderers may subscribe without creating a reverse dependency.") + +(defun tp--palette-note-theme-change (source) + "Record theme lifecycle SOURCE and notify `tp-theme-change-hook'." + (setq tp-theme-generation (1+ tp-theme-generation) + tp-theme-last-hook-source source) + (run-hook-with-args 'tp-theme-change-hook source)) + +(defun tp--palette-after-enable-theme (&rest _) + "Record an `enable-theme' lifecycle event." + (tp--palette-note-theme-change 'enable-theme)) + +(defun tp--palette-after-disable-theme (&rest _) + "Record a `disable-theme' lifecycle event." + (tp--palette-note-theme-change 'disable-theme)) + +(unless (advice-member-p #'tp--palette-after-enable-theme 'enable-theme) + (advice-add 'enable-theme :after #'tp--palette-after-enable-theme)) +(unless (advice-member-p #'tp--palette-after-disable-theme 'disable-theme) + (advice-add 'disable-theme :after #'tp--palette-after-disable-theme)) + (defmacro define-tp-palette (name &rest plist) "Register a color palette named NAME, defined by PLIST. PLIST maps the keys :fg, :bg and :border to colors in any format diff --git a/tp-query.el b/tp-query.el new file mode 100644 index 0000000..f567706 --- /dev/null +++ b/tp-query.el @@ -0,0 +1,179 @@ +;;; tp-query.el --- Native query and policy helpers for tp -*- lexical-binding: t -*- + +;; Copyright (C) 2024-2026 Geekinney + +;; Author: Geekinney (kinneyzhang666@gmail.com) + +;;; Commentary: + +;; Explicit native text-property query boundaries and mutation policy. + +;;; Code: + +(require 'cl-lib) +(require 'tp-core) + +(cl-defstruct (tp-lookup-result + (:constructor tp--make-lookup-result + (&key property value present-p source mode + object position overlay))) + "Normalized text or character property lookup result. +PRESENT-P distinguishes an explicit nil value from absence. SOURCE +identifies the winning text source or `:overlay'; OVERLAY is non-nil +only when that overlay supplied the winning character-property value." + property value present-p source mode object position overlay) + +(defun tp--lookup-direct (position property object mode) + "Return direct text lookup result at POSITION for PROPERTY in OBJECT." + (let* ((obj (or object (current-buffer))) + (cell (plist-member (text-properties-at position object) property))) + (tp--make-lookup-result + :property property :value (cadr cell) :present-p (and cell t) + :source (if cell :text-direct :absent) :mode mode + :object obj :position position))) + +(defun tp--lookup-effective (position property object mode) + "Return effective text lookup result at POSITION for PROPERTY in OBJECT." + (let* ((value (get-text-property position property object)) + (source-cell (tp--lookup-source-cell position property object)) + (present-p (nth 2 source-cell))) + (tp--make-lookup-result + :property property :value value :present-p present-p + :source (if present-p (car source-cell) :absent) :mode mode + :object (or object (current-buffer)) :position position))) + +(defun tp--lookup-char (position property object mode) + "Return overlay-aware lookup for PROPERTY at POSITION in OBJECT. +MODE is recorded in the returned `tp-lookup-result'." + (let* ((native (get-char-property-and-overlay position property object)) + (overlay (cdr native)) + (text-object (if (windowp object) (window-buffer object) object)) + (text-source (tp--lookup-source-cell + position property text-object)) + (present-p (or overlay (nth 2 text-source))) + (source (if overlay :overlay (car text-source)))) + (tp--make-lookup-result + :property property :value (car native) :present-p (and present-p t) + :source source :mode mode :object (or object (current-buffer)) + :position position :overlay overlay))) + +(defun tp--lookup-alias-cell (position property object) + "Return the first non-nil alias value for PROPERTY at POSITION." + (catch 'found + (dolist (alias (cdr (assq property char-property-alias-alist))) + (when-let ((value (get-text-property position alias object))) + (throw 'found (list alias value)))))) + +(defun tp--lookup-source-cell (position property object) + "Return (SOURCE VALUE PRESENT-P) for text-only source lookup." + (let* ((props (text-properties-at position object)) + (direct (plist-member props property)) + (category (plist-get props 'category)) + (cat-cell (and category (plist-member (symbol-plist category) property))) + (alias-cell (tp--lookup-alias-cell position property object)) + (default-cell (plist-member default-text-properties property))) + (cond + (direct (list :text-direct (cadr direct) t)) + (cat-cell (list :category (cadr cat-cell) t)) + (alias-cell (list :alias (cadr alias-cell) t)) + (default-cell (list :default (cadr default-cell) t)) + (t (list :absent nil nil))))) + +;;;###autoload +(cl-defun tp-lookup (position property &key object (mode :text-effective)) + "Look up PROPERTY at POSITION in OBJECT according to MODE. + +MODE is one of `:text-direct', `:text-effective', `:text-source', +`:char', or `:char-source'. Text modes ignore overlays. Character +modes delegate overlay precedence to `get-char-property-and-overlay'; +when an overlay supplies the winning value, the result records both +source `:overlay' and the winning overlay object. + +Always return a `tp-lookup-result'. Its `present-p' field separates +absence from a direct property whose value is nil." + (pcase mode + (:text-direct (tp--lookup-direct position property object mode)) + (:text-effective (tp--lookup-effective position property object mode)) + (:text-source + (pcase-let ((`(,source ,value ,present-p) + (tp--lookup-source-cell position property object))) + (tp--make-lookup-result + :property property :value value :present-p present-p + :source source :mode mode :object (or object (current-buffer)) + :position position))) + ((or :char :char-source) + (tp--lookup-char position property object mode)) + (_ (error "tp-lookup: unknown mode %S" mode)))) + +;;;###autoload +(cl-defun tp-property-change + (position &key property object limit (direction :next)) + "Return a native property change position from POSITION. +With PROPERTY, delegate to the single-property change primitives; +with nil PROPERTY, observe changes to any property. DIRECTION is +`:next' or `:previous'. OBJECT and LIMIT retain their native Emacs +meanings. Return the changed position or nil." + (pcase direction + (:next + (if property + (next-single-property-change position property object limit) + (next-property-change position object limit))) + (:previous + (if property + (previous-single-property-change position property object limit) + (previous-property-change position object limit))) + (_ (error "tp-property-change: unknown direction %S" direction)))) + +;;;###autoload +(defun tp-property-any (start end property value &optional object) + "Return first position in [START, END) where PROPERTY is VALUE. +This is the facade entry for `text-property-any'; OBJECT is a string, +a buffer, or nil for the current buffer." + (text-property-any start end property value object)) + +;;;###autoload +(defun tp-property-not-all (start end property value &optional object) + "Return first position in [START, END) where PROPERTY is not VALUE. +This delegates directly to `text-property-not-all'." + (text-property-not-all start end property value object)) + +(defun tp--mutation-policy-modes (policy) + "Return normalized (MODIFIED READ-ONLY) modes for POLICY." + (unless (and (proper-list-p policy) (cl-evenp (length policy))) + (error "tp-with-mutation-policy: POLICY must be a plist")) + (cl-loop for (key _value) on policy by #'cddr + unless (memq key '(:modified :read-only)) + do (error "tp-with-mutation-policy: unknown key %S" key)) + (let ((modified (if (plist-member policy :modified) + (plist-get policy :modified) + :ordinary)) + (read-only (if (plist-member policy :read-only) + (plist-get policy :read-only) + :respect))) + (unless (memq modified '(:ordinary :silent)) + (error "tp-with-mutation-policy: unknown :modified %S" modified)) + (unless (memq read-only '(:respect :inhibit)) + (error "tp-with-mutation-policy: unknown :read-only %S" read-only)) + (when (and (eq modified :silent) (eq read-only :respect)) + (error "tp-with-mutation-policy: :silent requires :read-only :inhibit")) + (list modified read-only))) + +;;;###autoload +(defmacro tp-with-mutation-policy (policy &rest body) + "Run BODY with explicit mutation POLICY. +POLICY accepts `:modified' (`:ordinary' or `:silent') and +`:read-only' (`:respect' or `:inhibit'). The supported combinations +are ordinary/respect, ordinary/inhibit, and silent/inhibit. +Silent/respect is rejected because native `with-silent-modifications' +itself inhibits read-only text." + (declare (indent 1) (debug (form body))) + `(pcase (tp--mutation-policy-modes ,policy) + ('(:ordinary :respect) ,@body) + ('(:ordinary :inhibit) + (let ((inhibit-read-only t)) ,@body)) + ('(:silent :inhibit) + (let ((inhibit-read-only t)) + (with-silent-modifications ,@body))))) + +(provide 'tp-query) +;;; tp-query.el ends here diff --git a/tp-reactive.el b/tp-reactive.el index 5fe542a..6666934 100644 --- a/tp-reactive.el +++ b/tp-reactive.el @@ -30,6 +30,12 @@ Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).") (defvar tp-layer-watchers nil "Alist of layer watchers: (LAYER-NAME . ((VAR-SYMBOL . CALLBACK) ...)).") +(defvar tp-reactive-observer-errors nil + "Structured observer failures, newest first. +Each entry is a plist containing `:kind', `:layer', `:symbol', +`:condition', `:new-value', and `:old-value'. Watcher failures are +recorded here and reported, but do not block the managed update.") + (defvar tp-layer-computed nil "Alist of computed properties: (LAYER-NAME . ((VAR-SYMBOL . COMPUTE-FN) ...)).") @@ -83,6 +89,12 @@ entry. Dead buffers and a nil LAYER-NAME are ignored. Installs the (unless (memq buffer bufs) (puthash layer-name (cons buffer bufs) tp--layer-buffers))))) +(defun tp-reactive--unregister-layer-buffer (layer-name buffer) + "Remove BUFFER from LAYER-NAME's registry entry when it is known." + (let ((buffers (gethash layer-name tp--layer-buffers 'unknown))) + (unless (eq buffers 'unknown) + (puthash layer-name (delq buffer buffers) tp--layer-buffers)))) + (defun tp-reactive-layer-buffers (layer-name) "Return the live buffers registered as showing layer LAYER-NAME. Return a list of live buffers - possibly empty, meaning \"known: no @@ -164,12 +176,6 @@ sync), the nested change still updates the variable, but its re-render is queued in `tp--batch-update-pending' and flushed after the outermost update completes instead of recursing.") -(defconst tp--compute-error (make-symbol "tp--compute-error") - "Sentinel distinguishing a failed compute from a legitimate nil result. -Compute functions may legitimately return nil (e.g. a boolean feeding -`invisible'), so error paths return this uninterned sentinel instead -of nil.") - (defun tp--queue-batch-update (layer-name symbol where tp-text-affected) "Queue a deferred re-render of LAYER-NAME in `tp--batch-update-pending'. SYMBOL is the changed variable, WHERE the buffer for buffer-local @@ -314,8 +320,16 @@ NEWVAL is the new value, OLDVAL is the old value." (tp-debug-log " Invoking watcher for %s on %s" watch-sym layer-name) (condition-case err (funcall callback newval oldval layer-name) - (error (message "tp: watcher error for %s watching %s: %s" - layer-name watch-sym err)))))))) + (error + (push (list :kind 'watcher + :layer layer-name + :symbol watch-sym + :condition err + :new-value newval + :old-value oldval) + tp-reactive-observer-errors) + (message "tp: watcher error for %s watching %s: %s" + layer-name watch-sym err)))))))) (defun tp--register-layer-watchers (layer-name watchers) "Register WATCHERS for LAYER-NAME. @@ -353,19 +367,13 @@ COMPUTED is a list of (VAR-SYMBOL COMPUTE-FN) pairs." "Apply initial computed values using COMPUTE definitions. COMPUTE is a list of (VAR-SYMBOL COMPUTE-FN) pairs. Sets the global variables to their computed values. -A compute function returning nil is a legitimate result and is -applied; only computes that signal an error are skipped (see -`tp--compute-error')." +A compute function returning nil is a legitimate result. Compute +errors propagate because a skipped value would leave stale state." (dolist (comp compute) (let* ((var-sym (car comp)) (compute-fn (cadr comp)) - (val (condition-case err - (funcall compute-fn) - (error - (message "tp: initial compute error for %s: %s" var-sym err) - tp--compute-error)))) - (unless (eq val tp--compute-error) - (set var-sym val))))) + (val (funcall compute-fn))) + (set var-sym val)))) (defun tp--data-var-symbol (data-entry) "Extract the variable symbol from DATA-ENTRY. @@ -435,6 +443,7 @@ it to allow re-definition to change initial values." ;; Clear all registries (setq tp-reactive-deps nil) (setq tp-layer-watchers nil) + (setq tp-reactive-observer-errors nil) (setq tp-layer-computed nil) (setq tp-layer-data nil) ;; Drop queued re-renders too: entries stranded by an error escaping diff --git a/tp-render-tests.el b/tp-render-tests.el index 210b3d6..50600f6 100644 --- a/tp-render-tests.el +++ b/tp-render-tests.el @@ -45,6 +45,12 @@ (defvar tp-rt-r3a-color nil) (defvar tp-rt-r3b-color nil) (defvar tp-rt-r3c-color nil) +(defvar tp-rt-a02-old-color nil) +(defvar tp-rt-a02-new-color nil) +(defvar tp-rt-a11-data nil) +(defvar tp-rt-a11-computed nil) +(defvar tp-rt-a11-watched nil) +(defvar tp-rt-a11-text nil) (defmacro tp-rt-with-cleanup (layers vars &rest body) "Run BODY, then undefine LAYERS and reset VARS to nil (teardown)." @@ -52,7 +58,8 @@ `(unwind-protect (progn ,@body) ,@(mapcar (lambda (l) `(tp-undefine-layer ',l)) layers) - ,@(mapcar (lambda (v) `(setq ,v nil)) vars))) + ,@(mapcar (lambda (v) `(setq ,v nil)) vars) + (setq tp-reactive-observer-errors nil))) ;;; B9: sub-region tp-text on a string must splice, not replace the whole string @@ -93,6 +100,168 @@ (should (equal (get-text-property 0 'face result) '(:background "green"))) (should (equal (get-text-property 0 'tp-text result) "6")))) +;;; TP-A01 / TP-A03: initial tp-text application uses per-run properties + +(ert-deftest tp-render-test-initial-tp-text-keeps-string-property-runs () + "Initial string tp-text application does not smear position-zero props." + (let* ((payload (concat (propertize "AB" 'face 'bold) + (propertize "CD" 'face 'italic))) + (result (tp-set "xxxx" 'tp-text payload))) + (should (eq (get-text-property 0 'face result) 'bold)) + (should (eq (get-text-property 2 'face result) 'italic)))) + +(ert-deftest tp-render-test-initial-tp-text-keeps-buffer-property-runs () + "Initial buffer tp-text application preserves every embedded prop run." + (let ((payload (concat (propertize "AB" 'face 'bold) + (propertize "CD" 'face 'italic)))) + (with-temp-buffer + (insert "xxxx") + (tp-set 1 5 (list 'tp-text payload)) + (should (eq (get-text-property 1 'face) 'bold)) + (should (eq (get-text-property 3 'face) 'italic))))) + +(ert-deftest tp-render-test-tp-text-explicit-nil-overrides-embedded-value () + "A caller-provided nil remains present and wins over embedded props." + (let* ((payload (propertize "X" 'custom 'embedded)) + (result (tp-set "x" 'tp-text payload 'custom nil))) + (should (equal (tp-member 0 'custom result) '(custom nil))) + (with-temp-buffer + (insert "x") + (tp-set 1 2 (list 'tp-text payload 'custom nil)) + (should (equal (tp-member 1 'custom) '(custom nil)))))) + +(ert-deftest tp-render-test-same-text-reset-removes-old-properties () + "A same-text tp-reset still replaces the complete property set." + (with-temp-buffer + (insert (propertize "AB" 'help-echo "old" 'face 'italic)) + (tp-reset 1 3 '(tp-text "AB" face bold)) + (should-not (plist-member (text-properties-at 1) 'help-echo)) + (should (eq (get-text-property 1 'face) 'bold))) + (let* ((source (propertize "AB" 'help-echo "old" 'face 'italic)) + (result (tp-reset source 'tp-text "AB" 'face 'bold))) + (should-not (plist-member (text-properties-at 0 result) 'help-echo)) + (should (eq (get-text-property 0 'face result) 'bold)))) + +(ert-deftest tp-render-test-same-text-add-merges-existing-face () + "A same-text tp-add keeps add semantics while applying per-run props." + (with-temp-buffer + (insert (propertize "AB" 'face 'italic)) + (tp-add 1 3 '(tp-text "AB" face bold)) + (should (equal (get-text-property 1 'face) '(bold italic)))) + (let* ((source (propertize "AB" 'face 'italic)) + (result (tp-add source 'tp-text "AB" 'face 'bold))) + (should (equal (get-text-property 0 'face result) '(bold italic)))) + (let* ((source (propertize "AB" 'face 'italic)) + (result (tp-add source 'tp-text nil 'face 'bold))) + (should (equal (get-text-property 0 'face result) '(bold italic))))) + +;;; TP-A02: layer redefinition refreshes with full old/new ownership + +(ert-deftest tp-render-test-static-redefinition-refreshes-managed-region () + "A simple static redefinition refreshes an already-mounted layer." + (tp-rt-with-cleanup (tp-rt-a02-static) () + (define-tp tp-rt-a02-static () '(face bold help-echo "old")) + (with-temp-buffer + (insert "Hello") + (tp-push-layer 1 6 'tp-rt-a02-static) + (define-tp tp-rt-a02-static () '(face italic)) + (should (eq (get-text-property 1 'face) 'italic)) + (should-not (plist-member (text-properties-at 1) 'help-echo))))) + +(ert-deftest tp-render-test-redefinition-preserves-external-value () + "A value changed after mounting is not deleted as stale layer output." + (tp-rt-with-cleanup (tp-rt-a02-external) () + (define-tp tp-rt-a02-external () '(face bold help-echo "owned")) + (with-temp-buffer + (insert "Hello") + (tp-push-layer 1 6 'tp-rt-a02-external) + (put-text-property 1 6 'help-echo "external") + (define-tp tp-rt-a02-external () '(face italic)) + (should (eq (get-text-property 1 'face) 'italic)) + (should (equal (get-text-property 1 'help-echo) "external"))))) + +(ert-deftest tp-render-test-reactive-redefinition-removes-old-owned-keys () + "Reactive redefinition removes keys and nested face data it no longer owns." + (tp-rt-with-cleanup + (tp-rt-a02-reactive) (tp-rt-a02-old-color tp-rt-a02-new-color) + (setq tp-rt-a02-old-color "red" + tp-rt-a02-new-color "blue") + (define-tp tp-rt-a02-reactive () + :props '(face (:foreground $tp-rt-a02-old-color) + help-echo "old")) + (with-temp-buffer + (insert "Hello") + (tp-push-layer 1 6 'tp-rt-a02-reactive) + (define-tp tp-rt-a02-reactive () + :props '(face (:background $tp-rt-a02-new-color))) + (let ((face (get-text-property 1 'face))) + (should (equal (plist-get face :background) "blue")) + (should-not (plist-member face :foreground))) + (should-not (plist-member (text-properties-at 1) 'help-echo))))) + +;;; TP-A11: business computations fail; observers are isolated and recorded + +(ert-deftest tp-render-test-transform-error-propagates () + "Transform failures and non-string results both propagate." + (tp-rt-with-cleanup + (tp-rt-a11-transform tp-rt-a11-nonstring) (tp-rt-a11-text) + (setq tp-rt-a11-text "raw") + (define-tp tp-rt-a11-transform () + :props '(tp-text $tp-rt-a11-text) + :transform (lambda (_text) (error "transform failed"))) + (should-error (tp-set "old" 'tp-rt-a11-transform) + :type 'error) + (define-tp tp-rt-a11-nonstring () + :props '(tp-text $tp-rt-a11-text) + :transform (lambda (_text) 42)) + (should-error (tp-set "old" 'tp-rt-a11-nonstring) + :type 'error))) + +(ert-deftest tp-render-test-compute-errors-propagate () + "Initial and update-time compute failures reach the caller." + (tp-rt-with-cleanup (tp-rt-a11-initial tp-rt-a11-update) + (tp-rt-a11-data tp-rt-a11-computed) + (should-error + (define-tp tp-rt-a11-initial () + :props '(help-echo $tp-rt-a11-computed) + :compute '((tp-rt-a11-computed + (lambda () (error "initial compute failed"))))) + :type 'error) + (setq tp-rt-a11-data "ok") + (define-tp tp-rt-a11-update () + :props '(help-echo $tp-rt-a11-computed) + :data '(tp-rt-a11-data) + :compute '((tp-rt-a11-computed + (lambda () + (if (equal tp-rt-a11-data "ok") + "ready" + (error "update compute failed")))))) + (should-error (setq tp-rt-a11-data "fail") + :type 'error))) + +(ert-deftest tp-render-test-watcher-error-is-recorded-and-update-continues () + "Watcher failures are isolated, queryable, and do not block rendering." + (tp-rt-with-cleanup (tp-rt-a11-watcher) (tp-rt-a11-watched) + (setq tp-rt-a11-watched "red") + (when (boundp 'tp-reactive-observer-errors) + (set 'tp-reactive-observer-errors nil)) + (define-tp tp-rt-a11-watcher () + :props '(face (:foreground $tp-rt-a11-watched)) + :watch '((tp-rt-a11-watched + (lambda (_new _old _layer) + (error "watcher failed"))))) + (with-temp-buffer + (insert "x") + (tp-push-layer 1 2 'tp-rt-a11-watcher) + (setq tp-rt-a11-watched "blue") + (should (equal (plist-get (tp-at 1 'face) :foreground) "blue")) + (should (boundp 'tp-reactive-observer-errors)) + (let ((failure (car (symbol-value 'tp-reactive-observer-errors)))) + (should (eq (plist-get failure :kind) 'watcher)) + (should (eq (plist-get failure :layer) 'tp-rt-a11-watcher)) + (should (eq (plist-get failure :symbol) 'tp-rt-a11-watched)) + (should (eq (car (plist-get failure :condition)) 'error)))))) + ;;; B10: computed-variable path must not clobber sibling static attributes (ert-deftest tp-render-test-computed-update-keeps-static-siblings () diff --git a/tp-render.el b/tp-render.el index 5aeeb1f..d3bbe56 100644 --- a/tp-render.el +++ b/tp-render.el @@ -61,48 +61,36 @@ usable definition." base (tp--resolve-reactive-symbols reactive override-alist)) base))))) +(defun tp--store-computed-value + (layer-name var-sym computed-val override-alist) + "Store LAYER-NAME's computed VAR-SYM and return updated OVERRIDE-ALIST." + (set var-sym computed-val) + (push (cons var-sym computed-val) override-alist) + (let ((current-props (cdr (assoc layer-name tp-layer-alist))) + (reactive-props (tp--layer-reactive-props layer-name))) + (when (and current-props reactive-props) + (let ((resolved + (tp--resolve-reactive-symbols reactive-props override-alist))) + (when resolved + (tp--set-layer-props + layer-name + (tp--deep-merge-plist current-props resolved)))))) + override-alist) + (defun tp--update-layer-computed (layer-name override-alist) - "Update computed reactive variables for LAYER-NAME with OVERRIDE-ALIST. -Evaluates compute functions and updates the reactive variable values. -A compute function returning nil is a legitimate result and is -propagated; only computes that signal an error are skipped (see -`tp--compute-error'). -Returns an updated override-alist with the new computed values." - (when-let ((computed (cdr (assoc layer-name tp-layer-computed)))) - (dolist (comp computed) - (let* ((var-sym (car comp)) - (compute-fn (cdr comp)) - ;; Temporarily bind variables to their new values from override-alist - ;; before calling the compute function - (computed-val - (condition-case err - (cl-progv - (mapcar #'car override-alist) - (mapcar #'cdr override-alist) - (funcall compute-fn)) - (error - (message "tp: compute error for %s.%s: %s" - layer-name var-sym err) - tp--compute-error)))) - (unless (eq computed-val tp--compute-error) - ;; Update the global variable - (set var-sym computed-val) - ;; Add to override-alist for property resolution - (push (cons var-sym computed-val) override-alist) - ;; Also update the layer properties if the computed var is used in props - (let ((current-props (cdr (assoc layer-name tp-layer-alist)))) - (when current-props - (when-let ((all-reactive-props (tp--layer-reactive-props layer-name))) - (let ((resolved-props (tp--resolve-reactive-symbols - all-reactive-props override-alist))) - (when resolved-props - ;; Deep-merge the resolved props into the current layer - ;; props so sibling static attributes nested in plists - ;; (e.g. a :background next to a reactive :foreground) - ;; survive the update. - (tp--set-layer-props - layer-name - (tp--deep-merge-plist current-props resolved-props))))))))))) + "Compute LAYER-NAME values and return an updated OVERRIDE-ALIST. +Compute errors propagate; returning nil remains a legitimate value." + (dolist (comp (cdr (assoc layer-name tp-layer-computed))) + (let* ((var-sym (car comp)) + (compute-fn (cdr comp)) + (computed-val + (cl-progv + (mapcar #'car override-alist) + (mapcar #'cdr override-alist) + (funcall compute-fn)))) + (setq override-alist + (tp--store-computed-value + layer-name var-sym computed-val override-alist)))) override-alist) (defun tp--render-visit-buffer (buffer fn) @@ -139,33 +127,158 @@ still picked up by the next update's full scan." (tp-reactive--register-layer-buffer layer-name buf)) (tp--render-visit-buffer buf fn))))))) -(defun tp--merge-props-into-stack-entry (entry props) - "Return stack-storage plist ENTRY with its keys updated from PROPS. -Every key of PROPS except `tp-name' and `tp-layers' replaces ENTRY's -value for that key (or extends ENTRY when the key is new), so ENTRY's -`tp-hidden' flag and identity survive the update. Returns a fresh -plist; ENTRY itself is not modified." - (let ((new-entry (copy-sequence entry))) - (cl-loop for (key val) on props by #'cddr - unless (memq key '(tp-name tp-layers)) - do (setq new-entry (plist-put new-entry key val))) - new-entry)) +(defun tp--reconcile-layer-props + (current old-props new-props &optional include-meta) + "Replace one layer's OLD-PROPS in CURRENT with NEW-PROPS. +Keys owned by OLD-PROPS are removed when CURRENT still carries the old +value, then NEW-PROPS are written in full. A differing current value +is preserved when the new definition no longer owns that key, because +it may be an explicit post-application edit. Stack metadata +`tp-layers' and `tp-hidden' is never owned by a layer definition. +`tp-meta' is rendered only when INCLUDE-META is non-nil. +Return a fresh plist." + (let ((result (copy-sequence current))) + (cl-loop for (key val) on old-props by #'cddr + unless (memq key '(tp-name tp-layers tp-hidden tp-meta)) + when (and (plist-member result key) + (equal (plist-get result key) val)) + do (cl-remf result key)) + (cl-loop for (key val) on new-props by #'cddr + unless (or (memq key '(tp-layers tp-hidden)) + (and (eq key 'tp-meta) (not include-meta))) + do (setq result (plist-put result key val))) + result)) -(defun tp--write-layer-through-stack-storage (layer-name props) +(defun tp--reconcile-layer-region (start end old-props new-props) + "Reconcile OLD-PROPS and NEW-PROPS on every property run in START..END." + (let ((pos start)) + (while (< pos end) + (let* ((next (or (next-property-change pos nil end) end)) + (current (text-properties-at pos)) + (updated (tp--reconcile-layer-props + current old-props new-props))) + (unless (equal updated current) + (set-text-properties pos next updated)) + (setq pos next))))) + +(defun tp--replace-stack-entry-props (entry old-props new-props) + "Return ENTRY with OLD-PROPS replaced by NEW-PROPS." + (tp--refresh-entry-meta-version + (tp--reconcile-layer-props entry old-props new-props t))) + +(defun tp--refresh-entry-meta-version (entry) + "Return ENTRY with refreshed metadata version fields when present." + (if-let ((meta (plist-get entry 'tp-meta)) + (name (plist-get entry 'tp-name))) + (let ((updated (copy-tree meta))) + (setq updated + (plist-put updated :definition-version + (tp--layer-definition-version name))) + (setq updated + (plist-put updated :entry-version + (1+ (or (plist-get meta :entry-version) 0)))) + (when (boundp 'tp-theme-generation) + (setq updated + (plist-put updated :palette-generation + tp-theme-generation))) + (plist-put entry 'tp-meta updated)) + entry)) + +(defun tp--entry-parameterized-refresh (entry layer-name) + "Return refreshed ENTRY for parameterized LAYER-NAME, or ENTRY." + (let ((meta (plist-get entry 'tp-meta))) + (if (and meta + (eq (plist-get entry 'tp-name) layer-name) + (not (plist-get meta :legacy-no-args)) + (plist-member meta :args) + (tp-layer-parameterized-p layer-name)) + (tp--entry-from-parameterized-meta entry layer-name meta) + entry))) + +(defun tp--entry-from-parameterized-meta (entry layer-name meta) + "Build a refreshed managed ENTRY for LAYER-NAME from META." + (let* ((args (plist-get meta :args)) + (props (tp-layer-props-with-args layer-name args t)) + (hidden (tp--stack-hidden-p entry)) + (updated (tp--refresh-entry-meta-version + (plist-put props 'tp-meta (copy-tree meta))))) + (if hidden + (plist-put updated 'tp-hidden t) + updated))) + +(defun tp--refresh-parameterized-stack (stack layer-name) + "Refresh parameterized LAYER-NAME entries in STACK." + (mapcar (lambda (entry) + (tp--entry-parameterized-refresh entry layer-name)) + stack)) + +(defun tp--refresh-parameterized-layer-regions (layer-name) + "Refresh mounted parameterized entries for LAYER-NAME in current buffer." + (let ((pos (point-min)) + (max (point-max))) + (while (< pos max) + (let* ((next (or (next-property-change pos nil max) max)) + (stack (tp--stack-props-to-list (text-properties-at pos))) + (new-stack (tp--refresh-parameterized-stack stack layer-name))) + (unless (equal new-stack stack) + (set-text-properties pos next + (tp--stack-build-props new-stack))) + (setq pos next))))) + +(defun tp--managed-stack-with-direct-edits (props stored) + "Return authoritative STORED after absorbing visible edits from PROPS. +In managed full-stack storage, direct properties are the render +projection of the first visible entry. A caller may legitimately +edit that projection with native text-property primitives. Preserve +those edits on the visible entry before refreshing definitions, while +keeping managed identity and metadata authoritative." + (let ((direct (copy-sequence props))) + (cl-remf direct 'tp-layers) + (let ((visible (seq-find (lambda (entry) + (not (tp--stack-hidden-p entry))) + stored))) + (cond + ((null visible) + (if direct + (signal 'tp-layer-conflict + (list "Properties appeared while all layers were hidden" + :actual direct)) + stored)) + ((not (equal (plist-get direct 'tp-name) + (plist-get visible 'tp-name))) + (signal 'tp-layer-conflict + (list "Managed render identity changed" + :actual direct :expected visible))) + (t + (let ((updated (copy-tree visible))) + (cl-loop for (key _value) + on (tp--entry-render-projection visible) by #'cddr + unless (or (eq key 'tp-name) + (plist-member direct key)) + do (cl-remf updated key)) + (cl-loop for (key value) on direct by #'cddr + unless (eq key 'tp-name) + do (setq updated (plist-put updated key value))) + (mapcar (lambda (entry) + (if (eq entry visible) updated entry)) + stored))))))) + +(defun tp--write-layer-through-stack-storage + (layer-name props &optional old-props) "Write PROPS through to LAYER-NAME's entries in `tp-layers' storage. A reactive re-render rewrites a layer's direct (rendered) properties, but the same layer can also sit inside the `tp-layers' stack-storage property of a run: buried below another layer, or hidden (see `tp-hide-layer'), in which case the direct properties are only a render cache and the stored entry is what the next stack operation -rebuilds from. For every run of the current buffer whose `tp-layers' -holds an entry whose `tp-name' equals LAYER-NAME, replace the layer's -own keys in that entry with their values from PROPS - preserving the -entry's `tp-hidden' flag and stack position - and rewrite the run via -`tp--stack-props-to-list' / `tp--stack-build-props', which also -refreshes the topmost-visible render cache in full-stack storage -mode. Runs already storing the current values are left untouched, so -an update that changes nothing does not mark the buffer as modified." +rebuilds from. OLD-PROPS, when non-nil, identifies definition-owned +keys that disappeared and must be removed. + +For every run of the current buffer whose `tp-layers' holds an entry +whose `tp-name' equals LAYER-NAME, reconcile the layer entry and +rewrite the run via `tp--stack-props-to-list' / +`tp--stack-build-props'. Runs already storing the current values are +left untouched." (let ((pos (point-min)) (max (point-max))) (while (< pos max) @@ -175,11 +288,16 @@ an update that changes nothing does not mark the buffer as modified." (cl-some (lambda (entry) (equal (plist-get entry 'tp-name) layer-name)) stored)) - (let* ((stack (tp--stack-props-to-list (text-properties-at pos))) + (let* ((raw (text-properties-at pos)) + (stack + (if (tp--entry-authoritative-storage-p stored) + (tp--managed-stack-with-direct-edits raw stored) + (tp--stack-props-to-list raw))) (new-stack (mapcar (lambda (entry) (if (equal (plist-get entry 'tp-name) layer-name) - (tp--merge-props-into-stack-entry entry props) + (tp--replace-stack-entry-props + entry old-props props) entry)) stack))) (unless (equal new-stack stack) @@ -187,49 +305,43 @@ an update that changes nothing does not mark the buffer as modified." (tp--stack-build-props new-stack))))) (setq pos next))))) -(defun tp--update-layer-regions (layer-name &optional where override-alist) +(defun tp--update-layer-regions + (layer-name &optional where override-alist old-props) "Update text regions that have LAYER-NAME applied. -Re-applies the layer's current properties to every region tagged with -the layer's `tp-name'. The layer's OWN property keys are replaced -with their current values (so refresh is idempotent: a face variable -changing from bold to italic yields italic, not (italic bold)), while -properties contributed by other sources are left untouched. +Reconcile the layer's current properties with OLD-PROPS, when given, +so redefinition removes keys and nested values the old definition +owned while preserving unrelated direct properties. -The update also writes through to `tp-layers' stack storage (see -`tp--write-layer-through-stack-storage'): copies of the layer that -are hidden or buried below another layer are refreshed in place, so a -later stack operation or `tp-show-layer' renders current values -instead of a stale snapshot. +The update also writes through to `tp-layers' stack storage: copies +of the layer that are hidden or buried below another layer are +refreshed in place, so a later stack operation or `tp-show-layer' +renders current values instead of a stale snapshot. WHERE specifies which buffers to update: - If WHERE is a buffer, only update that buffer (setq-local case). - - If WHERE is nil, update the buffers registered for the layer in - the reactive buffer registry, falling back to one full - `buffer-list' scan when the registry has no knowledge of the - layer (see `tp--map-layer-buffers'). + - If WHERE is nil, update the buffers registered for the layer, + falling back to a full scan when the registry has no knowledge. -OVERRIDE-ALIST maps reactive variables to their new values when the -watcher fires before the variables are set; layer props are -re-resolved against it in each target buffer, so buffer-local -variable values are honored." +OVERRIDE-ALIST maps reactive variables to their new values when a +watcher fires before those variables are set." (let ((update-buffer (lambda () (let ((props (tp--layer-render-props layer-name override-alist))) - (when props - (save-excursion - ;; Callback for tp-search-map: replaces the layer's own - ;; property keys on the matched region. Returns nil to - ;; prevent tp-search-map from replacing the text. - (tp-search-map - (lambda (_text start end) - (cl-loop for (key val) on props by #'cddr - do (put-text-property start end key val)) - nil) - 'tp-name layer-name) - ;; Write through to stack storage so hidden or buried - ;; copies of the layer do not go stale (HID-1). - (tp--write-layer-through-stack-storage layer-name - props))))))) + (save-excursion + (if props + (progn + ;; In hidden/full-stack mode storage is authoritative. + ;; Update it first so the render-cache conflict guard + ;; compares old cache with old storage. + (tp--write-layer-through-stack-storage + layer-name props old-props) + (tp-search-map + (lambda (_text start end) + (tp--reconcile-layer-region + start end old-props props) + nil) + 'tp-name layer-name)) + (tp--refresh-parameterized-layer-regions layer-name))))))) (tp--map-layer-buffers layer-name where update-buffer))) (defun tp--update-reactive-text (layer-name &optional where override-alist) diff --git a/tp-search-tests.el b/tp-search-tests.el index e0e8d89..62766f1 100644 --- a/tp-search-tests.el +++ b/tp-search-tests.el @@ -127,7 +127,7 @@ left unchanged." (let ((str (copy-sequence "hello world"))) (tp-set 6 11 '(marker t) str) (should-error (tp-forward-do (lambda (txt) (concat (upcase txt) "XYZ")) - 'marker nil str)) + 'marker tp-any-value str)) (should (equal (substring-no-properties str) "hello world")))) (ert-deftest tp-search-test-forward-do-longer-in-bounds-errors () @@ -136,7 +136,7 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"." (let ((str (copy-sequence "hello world"))) (tp-set 0 5 '(marker t) str) (should-error (tp-forward-do (lambda (txt) (concat txt txt)) - 'marker nil str)) + 'marker tp-any-value str)) (should (equal (substring-no-properties str) "hello world")))) (ert-deftest tp-search-test-backward-do-longer-replacement-errors () @@ -144,7 +144,7 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"." (let ((str (copy-sequence "hello world"))) (tp-set 6 11 '(marker t) str) (should-error (tp-backward-do (lambda (txt) (concat (upcase txt) "12345")) - 'marker nil str)) + 'marker tp-any-value str)) (should (equal (substring-no-properties str) "hello world")))) (ert-deftest tp-search-test-search-map-longer-replacement-errors () @@ -152,14 +152,15 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"." (let ((str (copy-sequence "hello world"))) (tp-set 6 11 '(marker t) str) (should-error (tp-search-map (lambda (txt) (concat (upcase txt) "!!!")) - 'marker nil str)) + 'marker tp-any-value str)) (should (equal (substring-no-properties str) "hello world")))) (ert-deftest tp-search-test-forward-do-shorter-replacement-errors () "A shorter replacement errors instead of leaving residue (\"ABllo\")." (let ((str (copy-sequence "hello world"))) (tp-set 0 5 '(marker t) str) - (should-error (tp-forward-do (lambda (_txt) "AB") 'marker nil str)) + (should-error + (tp-forward-do (lambda (_txt) "AB") 'marker tp-any-value str)) (should (equal (substring-no-properties str) "hello world")))) (ert-deftest tp-search-test-search-map-same-length-string-ok () @@ -167,7 +168,7 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"." (let ((str (copy-sequence "hello world hello"))) (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) - (should (= (tp-search-map #'upcase 'marker nil str) 2)) + (should (= (tp-search-map #'upcase 'marker tp-any-value str) 2)) (should (equal (substring-no-properties str) "HELLO world HELLO")))) ;;; B43: -do shortfall is all-or-nothing on strings and buffers alike @@ -177,7 +178,7 @@ Old code silently wrote 10 chars, yielding \"hellohellod\"." The count of available matches is still returned." (let ((str (copy-sequence "hello world"))) (tp-set 0 5 '(marker t) str) - (should (= (tp-forward-do #'upcase 'marker nil str 3) 1)) + (should (= (tp-forward-do #'upcase 'marker tp-any-value str 3) 1)) (should (equal (substring-no-properties str) "hello world")))) (ert-deftest tp-search-test-forward-do-shortfall-buffer () @@ -193,7 +194,7 @@ The count of available matches is still returned." "tp-backward-do shortfall applies nothing on strings." (let ((str (copy-sequence "hello world"))) (tp-set 6 11 '(marker t) str) - (should (= (tp-backward-do #'upcase 'marker nil str 2) 1)) + (should (= (tp-backward-do #'upcase 'marker tp-any-value str 2) 1)) (should (equal (substring-no-properties str) "hello world")))) (ert-deftest tp-search-test-forward-do-exact-count-applies () @@ -201,7 +202,7 @@ The count of available matches is still returned." (let ((str (copy-sequence "aaa bbb aaa"))) (tp-set 0 3 '(marker t) str) (tp-set 8 11 '(marker t) str) - (should (= (tp-forward-do #'upcase 'marker nil str 2) 2)) + (should (= (tp-forward-do #'upcase 'marker tp-any-value str 2) 2)) (should (equal (substring-no-properties str) "aaa bbb AAA")))) (ert-deftest tp-search-test-forward-do-buffer-longer-replacement-grows () @@ -227,7 +228,8 @@ with predicate t, where VALUE nil matches property-absent runs." (put-text-property 1 4 'marker t)) (with-temp-buffer (insert "current buffer text") - (let ((count (tp-search-map #'upcase 'marker nil target))) + (let ((count (tp-search-map + #'upcase 'marker tp-any-value target))) (should (= count 1))) ;; Current buffer untouched. (should (equal (buffer-string) "current buffer text"))) @@ -251,7 +253,7 @@ with predicate t, where VALUE nil matches property-absent runs." (insert "x") (let ((seen nil)) (tp--search-do (lambda (match _obj) (push match seen)) - 'marker nil target) + 'marker tp-any-value target) (should (equal seen '((9 12 t))))))) (kill-buffer target)))) @@ -264,7 +266,8 @@ with predicate t, where VALUE nil matches property-absent runs." (put-text-property 1 4 'marker t) (put-text-property 5 8 'marker t) (put-text-property 9 12 'marker t) - (let ((count (tp-search-map (lambda (_txt) "XXXXXX") 'marker nil nil))) + (let ((count (tp-search-map + (lambda (_txt) "XXXXXX") 'marker tp-any-value nil))) (should (= count 3)) (should (equal (buffer-substring-no-properties (point-min) (point-max)) "XXXXXX XXXXXX XXXXXX"))))) @@ -276,7 +279,7 @@ with predicate t, where VALUE nil matches property-absent runs." (put-text-property 1 4 'marker t) (put-text-property 5 8 'marker t) (put-text-property 9 12 'marker t) - (tp-search-map (lambda (_txt) "-") 'marker nil nil) + (tp-search-map (lambda (_txt) "-") 'marker tp-any-value nil) (should (equal (buffer-substring-no-properties (point-min) (point-max)) "- - -")))) @@ -291,7 +294,7 @@ with predicate t, where VALUE nil matches property-absent runs." (tp-search-map (lambda (txt _start _end idx) (push txt texts) (format "<%d>%s" idx txt)) - 'marker nil nil) + 'marker tp-any-value nil) ;; Each callback received the intact matched text, not garbage ;; from stale positions. (should (equal (nreverse texts) '("aaa" "bbb" "ccc"))) @@ -346,7 +349,7 @@ with predicate t, where VALUE nil matches property-absent runs." (let ((str (copy-sequence "hello world"))) (tp-set 0 5 '(marker t face bold) str) (tp-search-map (lambda (txt) (substring-no-properties txt)) - 'marker nil str) + 'marker tp-any-value str) (should (null (text-properties-at 0 str))) (should (equal (substring-no-properties str) "hello world")))) @@ -357,7 +360,7 @@ with predicate t, where VALUE nil matches property-absent runs." (tp-search-map (lambda (txt) (remove-text-properties 0 (length txt) '(face nil) txt) txt) - 'marker nil str) + 'marker tp-any-value str) (should (null (get-text-property 0 'face str))) (should (eq (get-text-property 0 'marker str) t)))) @@ -367,7 +370,8 @@ with predicate t, where VALUE nil matches property-absent runs." "A callback returning nil leaves text and properties untouched." (let ((str (copy-sequence "hello world"))) (tp-set 0 5 '(marker t face bold) str) - (let ((count (tp-search-map (lambda (_txt) nil) 'marker nil str))) + (let ((count (tp-search-map + (lambda (_txt) nil) 'marker tp-any-value str))) (should (= count 1)) (should (equal (substring-no-properties str) "hello world")) (should (eq (get-text-property 0 'face str) 'bold))))) @@ -490,7 +494,7 @@ with predicate t, where VALUE nil matches property-absent runs." "A function PREDICATE selects buffer matches by property value." (tp-search-tests--with-lvl-buffer (goto-char (point-min)) - (let ((m (tp-forward 'lvl nil nil 1 + (let ((m (tp-forward 'lvl tp-any-value nil 1 (lambda (_ v) (and (numberp v) (> v 1)))))) (should m) (should (equal (list (prop-match-beginning m) @@ -504,7 +508,7 @@ with predicate t, where VALUE nil matches property-absent runs." (tp-set 0 3 '(lvl 1) s) (tp-set 3 6 '(lvl 2) s) (tp-set 6 9 '(lvl 3) s) - (should (equal (tp-forward 'lvl nil s 2 + (should (equal (tp-forward 'lvl tp-any-value s 2 (lambda (_ v) (and (numberp v) (> v 1)))) '((3 6 2) (6 9 3)))))) @@ -512,7 +516,7 @@ with predicate t, where VALUE nil matches property-absent runs." "tp-backward accepts the same function PREDICATE as tp-forward." (tp-search-tests--with-lvl-buffer (goto-char (point-max)) - (let ((m (tp-backward 'lvl nil nil 1 + (let ((m (tp-backward 'lvl tp-any-value nil 1 (lambda (_ v) (and (numberp v) (< v 3)))))) (should m) (should (equal (list (prop-match-beginning m) @@ -526,7 +530,7 @@ with predicate t, where VALUE nil matches property-absent runs." (tp-set 0 3 '(lvl 1) s) (tp-set 3 6 '(lvl 2) s) (tp-set 6 9 '(lvl 3) s) - (should (equal (tp-backward 'lvl nil s 2 + (should (equal (tp-backward 'lvl tp-any-value s 2 (lambda (_ v) (and (numberp v) (> v 1)))) '((6 9 3) (3 6 2)))))) @@ -577,7 +581,8 @@ value changes when a non-nil predicate is given." (let ((s (copy-sequence "abcdef"))) (tp-set 0 3 '(lvl 1) s) (tp-set 3 6 '(lvl 2) s) - (should (equal (tp-forward 'lvl nil s 5 (lambda (_ v) (numberp v))) + (should (equal (tp-forward 'lvl tp-any-value s 5 + (lambda (_ v) (numberp v))) '((0 3 1) (3 6 2)))))) (ert-deftest tp-search-test-forward-do-predicate () @@ -585,7 +590,7 @@ value changes when a non-nil predicate is given." (let ((s (copy-sequence "abc def"))) (tp-set 0 3 '(lvl 1) s) (tp-set 4 7 '(lvl 2) s) - (should (= (tp-forward-do #'upcase 'lvl nil s 1 nil nil + (should (= (tp-forward-do #'upcase 'lvl tp-any-value s 1 nil nil (lambda (_ v) (eq v 2))) 1)) (should (equal (substring-no-properties s) "abc DEF")))) @@ -596,7 +601,8 @@ value changes when a non-nil predicate is given." (insert "abc def") (put-text-property 1 4 'lvl 1) (put-text-property 5 8 'lvl 2) - (should (= (tp-backward-do #'upcase 'lvl nil (current-buffer) 1 nil nil + (should (= (tp-backward-do + #'upcase 'lvl tp-any-value (current-buffer) 1 nil nil (lambda (_ v) (eq v 1))) 1)) (should (equal (buffer-substring-no-properties (point-min) (point-max)) @@ -785,5 +791,64 @@ the nil-PREDICATE default keeps the primitive's not-`equal' matching." ;; Fewer matches than N: return what exists, not nil. (should (equal (tp-forward 'k 'v s 5) '((0 2 v) (4 6 v)))))) +;;; Stage 2 canonical match storage + +(ert-deftest tp-search-test-internal-matches-are-canonical () + "The shared scanner returns canonical matches in native coordinates." + (let ((str (copy-sequence "abcde"))) + (put-text-property 1 3 'state nil str) + (put-text-property 3 5 'state 'ready str) + (let ((matches (tp--property-matches + str 0 5 'state tp-any-value nil))) + (should (= (length matches) 2)) + (should (seq-every-p #'tp--match-p matches)) + (should (equal (mapcar #'tp--match-to-list matches) + '((1 3 nil) (3 5 ready))))))) + +(ert-deftest tp-search-test-public-search-adapts-canonical-matches () + "Public search retains list returns while its scanner stays canonical." + (let ((str (copy-sequence "abcde"))) + (put-text-property 0 2 'state 1 str) + (put-text-property 3 5 'state 2 str) + (should (equal (tp-search str 'state) + '((0 2 1) (3 5 2)))) + (should (equal (tp-forward 'state tp-any-value str 2) + '((0 2 1) (3 5 2)))))) + +;;; TP-A04: omitted values and explicit nil are distinct + +(ert-deftest tp-search-test-explicit-nil-is-presence-aware-for-strings () + "Explicit nil matches only a present nil property, never a non-nil run." + (let ((s (copy-sequence "abc"))) + (put-text-property 0 1 'p 'x s) + (put-text-property 2 3 'p nil s) + (should (equal (tp-forward 'p nil s) '((2 3 nil)))))) + +(ert-deftest tp-search-test-omitted-value-matches-present-values () + "Omitting VALUE matches any present direct value, including nil." + (let ((s (copy-sequence "abc"))) + (put-text-property 0 1 'p 'x s) + (put-text-property 2 3 'p nil s) + (should (equal (tp-search s 'p) + '((0 1 x) (2 3 nil)))))) + +(ert-deftest tp-search-test-explicit-nil-string-buffer-parity () + "String and buffer paths both match the present nil-valued run." + (let ((s (copy-sequence "abc"))) + (put-text-property 0 1 'p 'x s) + (put-text-property 2 3 'p nil s) + (should (equal (tp-forward 'p nil s) '((2 3 nil)))) + (with-temp-buffer + (insert "abc") + (put-text-property 1 2 'p 'x) + (put-text-property 3 4 'p nil) + (goto-char (point-min)) + (let ((match (tp-forward 'p nil))) + (should match) + (should (equal (list (prop-match-beginning match) + (prop-match-end match) + (prop-match-value match)) + '(3 4 nil))))))) + (provide 'tp-search-tests) ;;; tp-search-tests.el ends here diff --git a/tp-search.el b/tp-search.el index 1614de9..e11a670 100644 --- a/tp-search.el +++ b/tp-search.el @@ -24,6 +24,13 @@ (require 'tp-layer) (require 'tp-ops) +(defconst tp-any-value (make-symbol "tp-any-value") + "Unique wildcard used by tp property-search APIs. +Omitting VALUE selects this sentinel automatically. Pass the variable +`tp-any-value' explicitly when a later positional argument is needed +and any present direct value should match. An explicit nil VALUE is +therefore available for exact, presence-aware nil matching.") + (defun tp--search-register-layer-buffer (props object) "Record OBJECT in the reactive buffer registry for PROPS's layers. When OBJECT is a buffer or nil (the current buffer) and the applied @@ -451,88 +458,126 @@ PREDICATE follows the convention tp uses for `text-property-search-forward': nil and t both mean the values must be `equal' (tp's 0.2.0 symmetric matching contract); a function is called with VALUE and PROP-VALUE and matches when it returns -non-nil." +non-nil. `tp-any-value' matches every PROP-VALUE." (if (functionp predicate) (funcall predicate value prop-value) - (equal value prop-value))) + (or (eq value tp-any-value) + (equal value prop-value)))) -(defun tp--string-property-matches (string property value predicate) - "Collect PROPERTY runs of STRING matching VALUE under PREDICATE. -Returns a list of (START END VALUE) lists with 0-based positions. A -run is a maximal stretch with one `eq' PROPERTY value, and it matches -when `tp--property-match-p' accepts that value. Adjacent matching -runs with different values stay separate entries, mirroring how -`text-property-search-forward' ends a match where the property value -changes when a non-nil predicate is given." - (let ((results nil)) - (tp--map-intervals - string 0 (length string) - (lambda (beg end val) - (when (tp--property-match-p value val predicate) - (push (list beg end val) results)) - nil) - property) +(defun tp--property-matches (object start end property value predicate) + "Return matching direct PROPERTY runs in OBJECT between START and END. +Each result is a canonical `tp--match'. A run is eligible only when +PROPERTY is present in `text-properties-at', so an explicit nil value +is distinct from absence. Boundaries caused only by unrelated +properties are joined back into one PROPERTY run." + (let ((obj (or object (current-buffer))) + (pos start) + (results nil)) + (while (< pos end) + (let* ((next (or (next-property-change pos object end) end)) + (presence (tp--presence-at pos property object)) + (prop-value (tp--presence-value presence))) + (when (and (tp--presence-present-p presence) + (tp--property-match-p value prop-value predicate)) + (let ((previous (car results))) + (if (and previous + (= (tp--native-range-end + (tp--match-range previous)) + pos) + (equal (tp--match-value previous) prop-value)) + (setf (tp--native-range-end + (tp--match-range previous)) + next) + (push (tp--make-match + (tp--make-native-range + obj (tp--object-kind obj) pos next) + property prop-value) + results)))) + (setq pos next))) (nreverse results))) (defun tp--property-search-backward (property value &optional predicate not-current) "Search backward for the previous region where PROPERTY matches VALUE. - -This is the backward mirror of (text-property-search-forward PROPERTY -VALUE t): by default a region matches when its PROPERTY value is -`equal' to VALUE. It deliberately does not call -`text-property-search-backward' with predicate t, because that -primitive's non-default-predicate branch skips every other property -run when non-matching runs intervene (observed through Emacs 30.2), -silently missing valid matches. - -PREDICATE follows `tp--property-match-p': nil and t both mean `equal' -matching (the 0.2.0 contract); a function is called with VALUE and -the region's PROPERTY value. When NOT-CURRENT is non-nil, the -matching region containing point (or ending exactly at point) is -skipped, mirroring the primitive's NOT-CURRENT argument. - -If a matching region is found, move point to its beginning and -return a `prop-match' object whose end is clipped to the starting -point (matching the primitive's behavior when point starts inside a -matching region). Otherwise return nil and leave point alone." - (if (bobp) - nil - (let ((origin (point)) - (found nil)) - ;; Walk PROPERTY runs before point; remember the last matching one. - ;; tp--map-intervals clips the run containing ORIGIN to end there. - (tp--map-intervals - (current-buffer) (point-min) origin - (lambda (ibeg iend val) - (when (and (tp--property-match-p value val predicate) - ;; With NOT-CURRENT, the run point is inside (or - ;; just after) is not a candidate. - (not (and not-current (= iend origin)))) - (setq found (list ibeg iend val))) - nil) - property) +Only direct PROPERTY runs are candidates. VALUE and PREDICATE follow +`tp--property-match-p'. NOT-CURRENT skips the run containing point." + (unless (bobp) + (let* ((origin (point)) + (matches (nreverse + (tp--property-matches + (current-buffer) (point-min) (point-max) + property value predicate))) + (found + (seq-find + (lambda (match) + (and (< (tp--native-range-start (tp--match-range match)) + origin) + (not (and not-current + (<= (tp--native-range-start + (tp--match-range match)) + origin) + (>= (tp--native-range-end + (tp--match-range match)) + origin))))) + matches))) (when found - (goto-char (car found)) - (make-prop-match :beginning (car found) - :end (cadr found) - :value (caddr found)))))) + (let ((range (tp--match-range found))) + (goto-char (tp--native-range-start range)) + (setf (tp--native-range-end range) + (min origin (tp--native-range-end range))) + (tp--match-to-prop-match found)))))) -(defun tp-forward (property &optional value object n predicate not-current) +(defun tp--property-search-forward (property value predicate not-current) + "Search forward once for a direct PROPERTY run from point." + (let* ((origin (point)) + (found + (seq-find + (lambda (match) + (and (> (tp--native-range-end (tp--match-range match)) + origin) + (not (and not-current + (<= (tp--native-range-start + (tp--match-range match)) + origin) + (< origin + (tp--native-range-end + (tp--match-range match))))))) + (tp--property-matches + (current-buffer) (point-min) (point-max) + property value predicate)))) + (when found + (let ((range (tp--match-range found))) + (goto-char (tp--native-range-end range)) + (setf (tp--native-range-start range) + (max origin (tp--native-range-start range))) + (tp--match-to-prop-match found))))) + +(defun tp--search-result-value (object start end property value) + "Return public search matches for OBJECT between START and END." + (let* ((range (tp--native-range-from-object object start end)) + (request (tp--make-request + :operation :search :range range :property property + :value value :public-return :matches)) + (matches (tp--property-matches + (tp--native-range-object range) + (tp--native-range-start range) + (tp--native-range-end range) + property value nil))) + (tp--result-public-value + (tp--make-result :request request :matches matches)))) + +(cl-defun tp-forward + (property &optional (value tp-any-value) object n predicate not-current) "Search forward N times for text with PROPERTY. -VALUE is the optional value to match; N is the number of searches, -defaulting to 1. +Omitted VALUE matches any present direct value; explicit nil matches a +present nil value. Pass `tp-any-value' when later positional +arguments are needed with wildcard matching. N is the number of +searches, defaulting to 1. OBJECT can be a buffer or string; nil defaults to current buffer. PREDICATE customizes matching: nil (the default) and t both keep the -0.2.0 contract where a region matches when its PROPERTY value is -`equal' to VALUE; a function is called with VALUE and the region's -PROPERTY value and matches when it returns non-nil. For buffers it -is passed to `text-property-search-forward'. -NOT-CURRENT is passed to `text-property-search-forward' and, when -non-nil, makes the search skip a matching region containing point. -It only applies to the buffer path; strings have no point, so it is -ignored there. +`equal' contract; a function is called with VALUE and the run value. +NOT-CURRENT skips a matching buffer run containing point. For buffers, each search starts from point and each successful one moves point to the end of its matched region; the return value is @@ -546,30 +591,30 @@ the N-th match alone. Fewer than N matches return however many exist." (let ((count (or n 1))) (cond - ;; String object - use tp-search (or the predicate-aware matcher) ((stringp object) - (let ((matches (if (functionp predicate) - (tp--string-property-matches object property - value predicate) - (tp-search object property value)))) - (seq-take matches count))) - ;; Buffer or nil + (let ((matches (tp--property-matches + object 0 (length object) property value predicate))) + (mapcar #'tp--match-to-list (seq-take matches count)))) (t (let ((result nil) (buf (or object (current-buffer)))) (tp-with-current-buffer buf - (dotimes (_ count) - (setq result (text-property-search-forward - property value - (if (functionp predicate) predicate t) - not-current)))) + (catch 'done + (dotimes (_ count) + (setq result (tp--property-search-forward + property value predicate not-current)) + (unless result + (throw 'done nil))))) result))))) -(defun tp-backward (property &optional value object n predicate not-current) +(cl-defun tp-backward + (property &optional (value tp-any-value) object n predicate not-current) "Search backward N times for text with PROPERTY. N is the number of searches, defaulting to 1. -VALUE is the optional value to match. +Omitted VALUE matches any present direct value; explicit nil matches a +present nil value. Pass `tp-any-value' when later positional +arguments are needed with wildcard matching. OBJECT can be a buffer or string; nil defaults to current buffer. PREDICATE customizes matching: nil (the default) and t both keep the 0.2.0 contract where a region matches when its PROPERTY value is @@ -584,40 +629,37 @@ For buffers, returns the prop-match object from the last successful search. For strings, returns a list of (START END VALUE) for the last N matches in reverse order (from end to start). -Uses `tp--property-search-backward' for buffers and `tp-search' (or -the predicate-aware matcher) for strings." +Uses the same presence-aware run scanner for strings and buffers." (let ((count (or n 1))) (cond - ;; String object - use tp-search and reverse ((stringp object) - (let ((matches (nreverse (if (functionp predicate) - (tp--string-property-matches - object property value predicate) - (tp-search object property value))))) - (seq-take matches count))) - ;; Buffer or nil + (let ((matches + (nreverse + (tp--property-matches + object 0 (length object) property value predicate)))) + (mapcar #'tp--match-to-list (seq-take matches count)))) (t (let ((result nil) (buf (or object (current-buffer)))) (tp-with-current-buffer buf - (dotimes (_ count) - ;; `equal' matching by default, mirroring the predicate t - ;; that `tp-forward' passes. The previous code used the - ;; default nil predicate, which matches values NOT `equal' - ;; to VALUE and so inverted the match when VALUE was - ;; non-nil. - (setq result (tp--property-search-backward - property value predicate not-current)))) + (catch 'done + (dotimes (_ count) + (setq result (tp--property-search-backward + property value predicate not-current)) + (unless result + (throw 'done nil))))) result))))) -(defun tp--forward-do (function property &optional value object times - start end predicate not-current) +(cl-defun tp--forward-do + (function property &optional (value tp-any-value) object times + start end predicate not-current) "Internal: search forward TIMES for PROPERTY, call FUNCTION on last match. FUNCTION receives two arguments: the prop-match object (or list for strings) and OBJECT. TIMES is the number of searches, defaulting to 1. -VALUE is the optional value to match. +Omitted VALUE matches any present value; explicit nil matches a +present nil value. OBJECT can be a buffer or string; nil defaults to current buffer. START and END define the search range; defaults are object start and end. PREDICATE and NOT-CURRENT are passed to each underlying search (see @@ -632,15 +674,10 @@ Returns the number of matches found (at most TIMES)." ((stringp object) (let* ((start-pos (or start 0)) (end-pos (or end (length object))) - (all-matches (if (functionp predicate) - (tp--string-property-matches object property - value predicate) - (tp-search object property value))) - (filtered-matches (seq-filter (lambda (m) - (and (>= (car m) start-pos) - (<= (cadr m) end-pos))) - all-matches)) - (matches (seq-take filtered-matches count))) + (all-matches (tp--property-matches + object start-pos end-pos + property value predicate)) + (matches (seq-take all-matches count))) ;; All-or-nothing, mirroring the buffer path: FUNCTION targets ;; the TIMES-th match specifically, so when fewer matches exist ;; acting on a different one would hit the wrong target. @@ -657,10 +694,8 @@ Returns the number of matches found (at most TIMES)." (save-excursion (goto-char search-start) (dotimes (i count) - (when-let ((match (text-property-search-forward - property value - (if (functionp predicate) predicate t) - not-current))) + (when-let ((match (tp--property-search-forward + property value predicate not-current))) (when (<= (prop-match-end match) search-end) (when (= i (1- count)) (funcall function match buf)) @@ -677,16 +712,20 @@ prop-match struct (buffer matches). ARITY is the precomputed FUNCTION accepts a 4th argument - (TEXT START END IDX). If FUNCTION returns a string, it replaces the matched text: -- For string OBJ the replacement happens in place; since strings have - fixed length, a longer replacement is truncated to the match length - and a shorter one only replaces that portion. The replacement's - text properties (including their absence) are copied onto the - replaced portion. +- For string OBJ the replacement happens in place and must have the + same length as the match. A different length signals an error. + The replacement's text properties (including their absence) are + copied onto the replaced portion. - For buffer OBJ the match is replaced via `delete-region' + `insert' \(the buffer may grow or shrink). Any non-string return value leaves OBJ untouched." - (let* ((m-start (if (listp match) (car match) (prop-match-beginning match))) - (m-end (if (listp match) (cadr match) (prop-match-end match))) + (let* ((range (when (tp--match-p match) (tp--match-range match))) + (m-start (cond (range (tp--native-range-start range)) + ((listp match) (car match)) + (t (prop-match-beginning match)))) + (m-end (cond (range (tp--native-range-end range)) + ((listp match) (cadr match)) + (t (prop-match-end match)))) (text (if (stringp obj) (substring obj m-start m-end) (buffer-substring m-start m-end))) @@ -735,8 +774,9 @@ length-changing replacements" new-text (length new-text) len)) (goto-char m-start) (insert new-text))))))) -(defun tp-forward-do (function property &optional value object times - start end predicate not-current) +(cl-defun tp-forward-do + (function property &optional (value tp-any-value) object times + start end predicate not-current) "Search forward TIMES times for PROPERTY; apply FUNCTION at the Nth match. Despite the -do suffix this is NOT a for-each: the search advances @@ -748,9 +788,10 @@ FUNCTION receives (TEXT &optional START END) where TEXT is the matched text, START and END are the positions of the match. The return value of FUNCTION replaces the matched text in the string or buffer. -PROPERTY is the text property to search for. -VALUE is the optional value to match; nil means search for PROPERTY without -matching value. +PROPERTY is the text property to search for. Omitted VALUE matches any +present value; explicit nil matches a present nil value. Pass +`tp-any-value' when later positional arguments are needed with +wildcard matching. OBJECT can be a buffer or string; nil defaults to current buffer. TIMES is the number of searches, defaulting to 1. The function searches TIMES times but only applies FUNCTION to the last (Nth) match found. @@ -765,39 +806,41 @@ path (strings have no point). Returns the number of successful matches. -Note: For string objects, the replacement text must have the same length -as the original matched text, since strings have fixed length in Emacs. -If the replacement is shorter, only that portion will be replaced. -If the replacement is longer, it will be truncated. +Note: For string objects, the replacement text must have the same +length as the original matched text, since strings have fixed length +in Emacs; a different length signals an error. Buffer replacements +may grow or shrink. Example: ;; Upcase only the last (2nd) match (setq my-string (copy-sequence \"hello world hello\")) (tp-set 0 5 \\='(marker t) my-string) (tp-set 12 17 \\='(marker t) my-string) - (tp-forward-do #\\='upcase \\='marker nil my-string 2) + (tp-forward-do #\\='upcase \\='marker tp-any-value my-string 2) ;; => \"hello world HELLO\" - only the 2nd match is upcased ;; Use start and end positions in function (tp-forward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt)) - \\='marker nil my-string 2) + \\='marker tp-any-value my-string 2) ;; Search within a range - (tp-forward-do #\\='upcase \\='marker nil my-string 1 0 10)" + (tp-forward-do #\\='upcase \\='marker tp-any-value my-string 1 0 10)" (let ((arity (func-arity function))) (tp--forward-do (lambda (match obj) (tp--replace-match-text function arity match obj)) property value object times start end predicate not-current))) -(defun tp--backward-do (function property &optional value object times - start end predicate not-current) +(cl-defun tp--backward-do + (function property &optional (value tp-any-value) object times + start end predicate not-current) "Internal: search backward TIMES for PROPERTY, call FUNCTION on last match. FUNCTION receives two arguments: the prop-match object (or list for strings) and OBJECT. TIMES is the number of searches, defaulting to 1. -VALUE is the optional value to match. +Omitted VALUE matches any present value; explicit nil matches a +present nil value. OBJECT can be a buffer or string; nil defaults to current buffer. START and END define the search range; defaults are object start and end. PREDICATE and NOT-CURRENT are passed to each underlying search (see @@ -812,16 +855,10 @@ Returns the number of matches found (at most TIMES)." ((stringp object) (let* ((start-pos (or start 0)) (end-pos (or end (length object))) - (all-matches (if (functionp predicate) - (tp--string-property-matches object property - value predicate) - (tp-search object property value))) - (filtered-matches - (seq-filter (lambda (m) - (and (>= (car m) start-pos) - (<= (cadr m) end-pos))) - all-matches)) - (matches (seq-take (nreverse filtered-matches) count))) + (all-matches (tp--property-matches + object start-pos end-pos + property value predicate)) + (matches (seq-take (nreverse all-matches) count))) ;; All-or-nothing; see tp--forward-do. (when (= (length matches) count) (funcall function (car (last matches)) object)) @@ -846,8 +883,9 @@ Returns the number of matches found (at most TIMES)." (cl-incf matches))))))) matches))))) -(defun tp-backward-do (function property &optional value object times - start end predicate not-current) +(cl-defun tp-backward-do + (function property &optional (value tp-any-value) object times + start end predicate not-current) "Search backward TIMES times for PROPERTY; apply FUNCTION at the Nth match. Despite the -do suffix this is NOT a for-each: the search walks back @@ -859,9 +897,10 @@ FUNCTION receives (TEXT &optional START END) where TEXT is the matched text, START and END are the positions of the match. The return value of FUNCTION replaces the matched text in the string or buffer. -PROPERTY is the text property to search for. -VALUE is the optional value to match; nil means search for PROPERTY without -matching value. +PROPERTY is the text property to search for. Omitted VALUE matches any +present value; explicit nil matches a present nil value. Pass +`tp-any-value' when later positional arguments are needed with +wildcard matching. OBJECT can be a buffer or string; nil defaults to current buffer. TIMES is the number of searches, defaulting to 1. The function searches TIMES times but only applies FUNCTION to the last (Nth) match found. @@ -876,33 +915,37 @@ on each underlying search; it only applies to the buffer path Returns the number of successful matches. -Note: For string objects, the replacement text must have the same length -as the original matched text, since strings have fixed length in Emacs. -If the replacement is shorter, only that portion will be replaced. -If the replacement is longer, it will be truncated. +Note: For string objects, the replacement text must have the same +length as the original matched text, since strings have fixed length +in Emacs; a different length signals an error. Buffer replacements +may grow or shrink. Example: ;; Upcase only the last (2nd) match (setq my-string (copy-sequence \"hello world hello\")) (tp-set 0 5 \\='(marker t) my-string) (tp-set 12 17 \\='(marker t) my-string) - (tp-backward-do #\\='upcase \\='marker nil my-string 2) + (tp-backward-do #\\='upcase \\='marker tp-any-value my-string 2) ;; => \"HELLO world hello\" - only the 2nd (last) match is upcased ;; Use start and end positions in function (tp-backward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt)) - \\='marker nil my-string 2) + \\='marker tp-any-value my-string 2) ;; Search within a range - (tp-backward-do #\\='upcase \\='marker nil my-string 1 0 10)" + (tp-backward-do #\\='upcase \\='marker tp-any-value my-string 1 0 10)" (let ((arity (func-arity function))) (tp--backward-do (lambda (match obj) (tp--replace-match-text function arity match obj)) property value object times start end predicate not-current))) -(defun tp-search (start-or-string - &optional end-or-property property-or-value value object) +(cl-defun tp-search + (start-or-string + &optional end-or-property + (property-or-value tp-any-value property-value-supplied-p) + (value tp-any-value value-supplied-p) + object) "Search for all text with PROPERTY in a buffer/string range or entire string. This function supports two calling conventions: @@ -913,94 +956,34 @@ This function supports two calling conventions: 2. Entire string: (tp-search STRING PROPERTY &optional VALUE) +When VALUE is omitted, match every run where PROPERTY is directly +present. An explicit nil matches only directly present nil values. +Use `tp-any-value' explicitly when OBJECT must also be supplied. + Returns a list of (START END VALUE) lists for all matching regions. Each element contains the start position, end position, and property value." (cond - ;; Entire string form: (tp-search string property &optional value) ((stringp start-or-string) - (let* ((str start-or-string) - (property end-or-property) - (value property-or-value) - (results nil) - (pos 0) - (len (length str))) - (while (< pos len) - (let* ((props (text-properties-at pos str)) - (has-prop (plist-member props property)) - (prop-val (plist-get props property))) - (if (and has-prop - (or (null value) - (equal prop-val value))) - ;; Find the extent of this property - (let ((next-change - (or (next-single-property-change - pos property str len) - len))) - (push (list pos next-change prop-val) results) - (setq pos next-change)) - ;; No match, move to next change - (setq pos (or (next-single-property-change - pos property str len) - len))))) - (nreverse results))) - ;; Buffer/string region form: (tp-search start end property &optional value object) + (tp--search-result-value + start-or-string 0 (length start-or-string) end-or-property + (if property-value-supplied-p property-or-value tp-any-value))) ((numberp start-or-string) - (let* ((start start-or-string) - (end end-or-property) - (property property-or-value) - (value value) - (obj (or object (current-buffer))) - (results nil) - (pos start)) - (if (stringp obj) - ;; String object - (while (< pos end) - (let* ((props (text-properties-at pos obj)) - (has-prop (plist-member props property)) - (prop-val (plist-get props property))) - (if (and has-prop - (or (null value) - (equal prop-val value))) - (let ((next-change - (or (next-single-property-change - pos property obj end) - end))) - (push (list pos next-change prop-val) results) - (setq pos next-change)) - (setq pos (or (next-single-property-change - pos property obj end) - end))))) - ;; Buffer object - (tp-with-current-buffer obj - (while (< pos end) - (let* ((props (text-properties-at pos)) - (has-prop (plist-member props property)) - (prop-val (plist-get props property))) - (if (and has-prop - (or (null value) - (equal prop-val value))) - (let ((next-change - (or (next-single-property-change - pos property nil end) - end))) - (push (list pos next-change prop-val) results) - (setq pos next-change)) - (setq pos (or (next-single-property-change - pos property nil end) - end))))))) - (nreverse results))) + (tp--search-result-value + (or object (current-buffer)) start-or-string end-or-property + property-or-value + (if value-supplied-p value tp-any-value))) (t (error "Invalid first argument: %S" start-or-string)))) -(defun tp--search-do (function property &optional value object start end) +(cl-defun tp--search-do + (function property &optional (value tp-any-value) object start end) "Internal: Execute FUNCTION on all matches of PROPERTY. Signature: (tp--search-do FUNCTION PROPERTY &optional VALUE OBJECT START END) FUNCTION receives two arguments: the match, as a (START END VALUE) list, and OBJECT. -PROPERTY is the text property to search for. -VALUE is the optional value to match; nil means search for PROPERTY -without matching value. +PROPERTY is the text property to search for. Omitted VALUE matches any +present value; explicit nil matches a present nil value. OBJECT can be a buffer or string; nil defaults to current buffer. START and END define the search range; defaults are object start and end. @@ -1012,31 +995,32 @@ FUNCTION may safely change the length of earlier matches (e.g. replace their text): later matches still receive their up-to-date positions." (let ((obj (or object (current-buffer)))) (if (stringp obj) - (let* ((all-matches (tp-search obj property value)) - (s (or start 0)) + (let* ((s (or start 0)) (e (or end (length obj))) - (filtered-matches - (seq-filter (lambda (m) - (and (>= (car m) s) - (<= (cadr m) e))) - all-matches))) - (dolist (match filtered-matches) - (funcall function match obj)) - (length filtered-matches)) + (matches (tp--property-matches + obj s e property value nil))) + (dolist (match matches) + (funcall function (tp--match-to-list match) obj)) + (length matches)) ;; Buffer: do all the work with OBJ current, and track match ;; positions with markers so length-changing edits made by ;; FUNCTION on earlier matches don't invalidate later positions. (tp-with-current-buffer obj (let* ((s (or start (point-min))) (e (or end (point-max))) - (matches (tp-search s e property value obj)) + (matches (tp--property-matches + obj s e property value nil)) (marked (mapcar (lambda (m) ;; Begin markers advance on insertion at ;; their position so adjacent runs stay ;; correct after a replacement. - (list (copy-marker (car m) t) - (copy-marker (cadr m)) - (caddr m))) + (let ((range (tp--match-range m))) + (list (copy-marker + (tp--native-range-start range) + t) + (copy-marker + (tp--native-range-end range)) + (tp--match-value m)))) matches))) (unwind-protect (dolist (m marked) @@ -1050,7 +1034,8 @@ their text): later matches still receive their up-to-date positions." (set-marker (cadr m) nil))) (length marked)))))) -(defun tp-search-map (function property &optional value object start end) +(cl-defun tp-search-map + (function property &optional (value tp-any-value) object start end) "Apply FUNCTION to all matches of PROPERTY in OBJECT. Signature: (tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END) @@ -1065,33 +1050,35 @@ FUNCTION can either: - Modify the text properties of the argument and return it - Return nil to skip replacement -PROPERTY is the text property to search for. -VALUE is the optional value to match; nil means search for PROPERTY without -matching value. +PROPERTY is the text property to search for. Omitted VALUE matches any +present value; explicit nil matches a present nil value. Pass +`tp-any-value' when later positional arguments are needed with +wildcard matching. OBJECT can be a buffer or string; nil defaults to current buffer. START and END define the search range; defaults are object start and end. Returns the number of matches processed. Note: For string objects, replacement text must have the same length -as the original matched text, since strings have fixed length in Emacs. -If the replacement is shorter, only that portion will be replaced. -If the replacement is longer, it will be truncated. +as the original matched text, since strings have fixed length in +Emacs; a different length signals an error. Buffer replacements may +grow or shrink. Example: ;; Upcase all matched text - (tp-search-map #\\='upcase \\='marker nil my-string) + (tp-search-map #\\='upcase \\='marker tp-any-value my-string) ;; Add properties to matched text - (tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold)) \\='marker nil str) + (tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold)) + \\='marker tp-any-value str) ;; Use start, end, and index (tp-search-map (lambda (txt start end idx) (format \"[%d:%d-%d]%s\" idx start end txt)) - \\='marker nil str) + \\='marker tp-any-value str) ;; Search within a range - (tp-search-map #\\='upcase \\='marker nil my-string 0 10)" + (tp-search-map #\\='upcase \\='marker tp-any-value my-string 0 10)" (let ((idx 0) (arity (func-arity function))) (tp--search-do diff --git a/tp-stack-tests.el b/tp-stack-tests.el index 8e11f3d..2d96719 100644 --- a/tp-stack-tests.el +++ b/tp-stack-tests.el @@ -102,19 +102,19 @@ definitions cannot leak between tests." (should (null (get-text-property 8 'tp-name))))) (ert-deftest tp-stack-test-put-layer-same-result-with-or-without-distant-props () - "Distant unrelated properties do not change what put-layer writes." + "Distant properties do not change the public managed stack." (tp-stack-tests--with-env (define-tp layer1 () '(face bold)) (let (props-bare props-distant) (with-temp-buffer (insert "abcdefghij") (tp-push-layer 1 4 'layer1) - (setq props-bare (text-properties-at 1))) + (setq props-bare (tp-layer-stack-at 1))) (with-temp-buffer (insert "abcdefghij") (put-text-property 8 10 'help-echo "far") (tp-push-layer 1 4 'layer1) - (setq props-distant (text-properties-at 1))) + (setq props-distant (tp-layer-stack-at 1))) (should (equal props-bare props-distant))))) ;;; B30: inline plists with ordinary (non-keyword) properties @@ -267,19 +267,21 @@ definitions cannot leak between tests." (should (equal (get-text-property 1 'help-echo) "low")) (should (eq (get-text-property 1 'tp-name) 'flat)))) -;;; B35: no garbage (tp-layers nil) on single-layer stacks +;;; B35: a single managed layer has non-nil authoritative storage -(ert-deftest tp-stack-test-single-layer-no-tp-layers-prop () - "Pushing one layer does not leave a (tp-layers nil) property behind." +(ert-deftest tp-stack-test-single-layer-has-authoritative-storage () + "Pushing one layer stores one metadata entry, never tp-layers nil." (tp-stack-tests--with-env (insert "abcdef") (define-tp layer1 () '(face bold)) (tp-push-layer 1 6 'layer1) - (should-not (tp-stack-tests--has-prop-p 1 'tp-layers)) + (should (= (length (get-text-property 1 'tp-layers)) 1)) + (should (plist-get (car (get-text-property 1 'tp-layers)) 'tp-meta)) + (should-not (plist-member (tp-layer-stack-at 1) 'tp-meta)) (should (eq (get-text-property 1 'face) 'bold)))) -(ert-deftest tp-stack-test-delete-to-single-layer-no-tp-layers-prop () - "Deleting down to one layer drops the tp-layers property entirely." +(ert-deftest tp-stack-test-delete-to-single-layer-keeps-metadata-storage () + "Deleting down to one layer keeps one authoritative metadata entry." (tp-stack-tests--with-env (insert "abcdef") (define-tp layer1 () '(face bold)) @@ -289,11 +291,11 @@ definitions cannot leak between tests." ;; With two layers the below-stack is a real, non-nil list. (should (get-text-property 1 'tp-layers)) (tp-delete-layer 1 6 'layer2) - (should-not (tp-stack-tests--has-prop-p 1 'tp-layers)) + (should (= (length (get-text-property 1 'tp-layers)) 1)) (should (eq (get-text-property 1 'tp-name) 'layer1)))) -(ert-deftest tp-stack-test-pop-to-single-layer-no-tp-layers-prop () - "Popping down to one layer drops the tp-layers property entirely." +(ert-deftest tp-stack-test-pop-to-single-layer-keeps-metadata-storage () + "Popping down to one layer keeps one authoritative metadata entry." (tp-stack-tests--with-env (let ((str (copy-sequence "abcdef"))) (define-tp layer1 () '(face bold)) @@ -301,7 +303,7 @@ definitions cannot leak between tests." (tp-push-layer str 'layer1) (tp-push-layer str 'layer2) (tp-pop-layer str) - (should-not (plist-member (text-properties-at 0 str) 'tp-layers)) + (should (= (length (get-text-property 0 'tp-layers str)) 1)) (should (eq (get-text-property 0 'tp-name str) 'layer1))))) (ert-deftest tp-stack-test-absent-tp-layers-tolerated-by-stack-ops () @@ -513,7 +515,7 @@ definitions cannot leak between tests." (should (eq (get-text-property 1 'face) 'bold)))) (ert-deftest tp-stack-test-hide-show-roundtrip-restores-storage () - "A hide/show roundtrip restores the exact original properties." + "A hide/show roundtrip restores the exact metadata-backed storage." (tp-stack-tests--with-env (insert "abcdef") (define-tp layer1 () '(face bold)) @@ -524,7 +526,21 @@ definitions cannot leak between tests." (should (null (get-text-property 1 'tp-name))) (tp-show-layer 1 6 'layer1) (should (equal (text-properties-at 1) before)) - (should-not (tp-stack-tests--has-prop-p 1 'tp-layers))))) + (should (= (length (get-text-property 1 'tp-layers)) 1))))) + +(ert-deftest tp-stack-test-hidden-direct-edit-signals-before-stack-write () + "A hidden-range direct edit raises a conflict instead of being discarded." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp tp-st-a10-layer () '(face bold)) + (tp-push-layer 1 6 'tp-st-a10-layer) + (tp-hide-layer 1 6 'tp-st-a10-layer) + (put-text-property 1 6 'help-echo "external") + (let ((before (text-properties-at 1))) + (should-error (tp-show-layer 1 6 'tp-st-a10-layer) + :type 'tp-layer-conflict) + (should (equal (text-properties-at 1) before)) + (should (equal (get-text-property 1 'help-echo) "external"))))) (ert-deftest tp-stack-test-flatten-drops-tp-hidden-flag () "Flattening a stack with a hidden layer never leaks the tp-hidden flag. @@ -974,6 +990,17 @@ selects the legacy order." (should (null (tp-push-layer 1 6 'undefined-x nil t))) (should (null (text-properties-at 1))))) +(ert-deftest tp-stack-test-noerror-does-not-catch-layer-body-errors () + "NOERROR suppresses unresolved names, not errors from a resolved body." + (tp-stack-tests--with-env + (insert "abcdef") + (define-tp tp-st-a06-boom (_value) + (error "tp-a06 body failure")) + (should-error + (tp-push-layer 1 6 '(tp-st-a06-boom 1) nil t) + :type 'error) + (should-not (text-properties-at 1)))) + ;;; Multi-argument parameterized specs through tp-put-layer (ert-deftest tp-stack-test-put-layer-multiarg-layer-flat () @@ -1260,5 +1287,18 @@ liveness depends on this)." (kill-buffer buf)))) (tp-layer-reset))) +;;; Stage 2 canonical layer-operation ranges + +(ert-deftest tp-stack-test-parser-resolves-canonical-native-object () + "Layer argument parsing resolves nil to a concrete buffer object." + (with-temp-buffer + (insert "hello") + (pcase-let ((`(,start ,end ,object ,layer) + (tp--parse-layer-args 2 (list 5 'example nil) 1))) + (should (= start 2)) + (should (= end 5)) + (should (eq object (current-buffer))) + (should (eq layer 'example))))) + (provide 'tp-stack-tests) ;;; tp-stack-tests.el ends here diff --git a/tp-stack.el b/tp-stack.el index 0475f22..974310f 100644 --- a/tp-stack.el +++ b/tp-stack.el @@ -43,11 +43,21 @@ OBJECT's native coordinates (0-based for strings, 1-based for buffers)." (cond ((stringp start-or-string) - (append (list 0 (length start-or-string) start-or-string) - (seq-take rest n))) + (let ((range (tp--native-range-from-object + start-or-string 0 (length start-or-string)))) + (append (list (tp--native-range-start range) + (tp--native-range-end range) + (tp--native-range-object range)) + (seq-take rest n)))) ((numberp start-or-string) - (append (list start-or-string (car rest) (nth (1+ n) rest)) - (seq-take (cdr rest) n))) + (let* ((operation-args (seq-take (cdr rest) n)) + (object (nth (1+ n) rest)) + (range (tp--native-range-from-object + object start-or-string (car rest)))) + (append (list (tp--native-range-start range) + (tp--native-range-end range) + (tp--native-range-object range)) + operation-args))) (t (error "Invalid layer arguments: %S" (cons start-or-string rest))))) (defun tp--plist-remove (plist key) @@ -56,6 +66,68 @@ Comparison uses `eq'. PLIST itself is not modified." (cl-loop for (k v) on plist by #'cddr unless (eq k key) append (list k v))) +(define-error 'tp-layer-transaction-error "tp layer transaction failed") + +(defvar tp--managed-operation-counter 0 + "Monotonic counter for managed lifecycle operation ids.") + +(defun tp--managed-next-operation-id () + "Return a fresh managed lifecycle operation id." + (setq tp--managed-operation-counter (1+ tp--managed-operation-counter)) + (intern (format "tp-managed-op-%d" tp--managed-operation-counter))) + +(defun tp--plist-remove-keys (plist keys) + "Return a copy of PLIST without any key in KEYS." + (cl-loop for (k v) on plist by #'cddr + unless (memq k keys) append (list k v))) + +(defun tp--managed-render-props (layer) + "Return LAYER without lifecycle-only storage properties." + (tp--entry-render-projection layer)) + +(defun tp--managed-public-layer-props (layer) + "Return LAYER's public stack query properties." + (tp--plist-remove-keys layer '(tp-name tp-meta))) + +(defun tp--managed-spec-arglist (name) + "Return NAME's parameter arglist when available." + (cond + ((and (fboundp 'tp-layer-parameterized-p) + (tp-layer-parameterized-p name)) + (tp-layer-arglist name)) + ((and (fboundp 'tp-group-parameterized-p) + (tp-group-parameterized-p name)) + (tp--group-arglist name)))) + +(defun tp--managed-meta-for-spec (spec layer) + "Build managed metadata for SPEC mounted as LAYER." + (let* ((name (plist-get layer 'tp-name)) + (spec-name (if (consp spec) (car spec) spec)) + (group-p (and (symbolp spec-name) + (assoc spec-name tp-layer-groups))) + (parameterized-p (and (symbolp spec-name) + (tp--managed-spec-arglist spec-name))) + (args (when (and (consp spec) (or group-p parameterized-p)) + (copy-tree (cdr spec)))) + (origin (cond + (group-p 'group) + (args 'parameterized) + ((assoc name tp-layer-alist) 'defined) + (name 'inline) + (t 'anonymous)))) + (tp--managed-entry-meta + name origin spec args (tp--managed-spec-arglist spec-name)))) + +(defun tp--managed-add-meta-to-layers (spec layers) + "Return LAYERS with managed metadata derived from SPEC." + (mapcar (lambda (layer) + (if (plist-member layer 'tp-meta) + layer + (append layer + (list 'tp-meta + (tp--managed-meta-for-spec spec layer))))) + layers)) + (defun tp--stack-map-region (start end object function) "Call FUNCTION over each property run of [START, END) in OBJECT. @@ -112,7 +184,8 @@ for buffers) and clipped to the requested region." (equal layer-name (plist-get props 'tp-name))) stack))) - (list abs-start abs-end props))))) + (list abs-start abs-end + (tp--plist-remove props 'tp-meta)))))) (defun tp-layer-list (start end &optional object) "Return list of all layer names in region from START to END." @@ -173,9 +246,345 @@ strings, 1-based for buffers). OBJECT is a string, a buffer, or nil for the current buffer." (mapcar (lambda (layer) (cons (plist-get layer 'tp-name) - (tp--plist-remove layer 'tp-name))) + (tp--managed-public-layer-props layer))) (tp--stack-props-to-list (text-properties-at pos object)))) +;;; Managed lifecycle APIs + +(defun tp--managed-layer-names-in-stack (stack) + "Return named managed layers from STACK in stack order." + (let (names) + (dolist (layer stack) + (when-let ((name (plist-get layer 'tp-name))) + (cl-pushnew name names :test #'equal))) + (nreverse names))) + +(defun tp--managed-legacy-meta (layer) + "Return safe legacy metadata for LAYER." + (plist-put + (tp--managed-meta-for-spec (plist-get layer 'tp-name) layer) + :legacy-no-args t)) + +(defun tp--managed-normalize-stack (stack) + "Return STACK with safe legacy managed entries migrated." + (mapcar (lambda (layer) + (if (or (not (plist-get layer 'tp-name)) + (plist-member layer 'tp-meta)) + layer + (append layer (list 'tp-meta + (tp--managed-legacy-meta layer))))) + stack)) + +;;;###autoload +(defun tp-attach-managed-layers (start end &optional object) + "Attach managed layer identity in START..END of OBJECT. +The scan is limited to the requested range. Return discovered layer +names in range order." + (let ((found nil)) + (tp--stack-map-region + start end object + (lambda (abs-start abs-end stack) + (let ((new-stack (tp--managed-normalize-stack stack))) + (unless (equal new-stack stack) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + object)) + (dolist (name (tp--managed-layer-names-in-stack new-stack)) + (cl-pushnew name found :test #'equal))))) + (dolist (name (nreverse found)) + (when (or (null object) (bufferp object)) + (tp-reactive--register-layer-buffer + name (or object (current-buffer))))) + (nreverse found))) + +(defun tp--managed-detached-props (stack keep-rendered) + "Return raw properties for detaching STACK. +When KEEP-RENDERED is non-nil, preserve the current visible + projection without managed storage properties." + (when keep-rendered + (tp--plist-remove + (tp--managed-render-props + (seq-find (lambda (layer) + (not (tp--stack-hidden-p layer))) + stack)) + 'tp-name))) + +;;;###autoload +(defun tp-detach-managed-layers (start end &optional object keep-rendered) + "Detach managed layer storage in START..END of OBJECT. +When KEEP-RENDERED is non-nil, preserve currently visible text +properties after removing lifecycle storage. Return detached layer +names in range order." + (let ((found nil)) + (tp--stack-map-region + start end object + (lambda (abs-start abs-end stack) + (when stack + (dolist (name (tp--managed-layer-names-in-stack stack)) + (cl-pushnew name found :test #'equal)) + (set-text-properties abs-start abs-end + (tp--managed-detached-props + stack keep-rendered) + object)))) + (let ((result (nreverse found))) + (when (or (null object) (bufferp object)) + (let* ((buffer (or object (current-buffer))) + (remaining (tp-reactive--buffer-layer-names buffer))) + (dolist (name result) + (unless (member name remaining) + (tp-reactive--unregister-layer-buffer name buffer))))) + result))) + +(defun tp--managed-layer-entry (start end layer) + "Return a diagnostics entry for LAYER covering START..END." + (let ((meta (plist-get layer 'tp-meta))) + (list :range (cons start end) + :name (plist-get layer 'tp-name) + :entry-id (plist-get meta :entry-id) + :origin (plist-get meta :origin) + :spec (copy-tree (plist-get meta :spec)) + :args (copy-tree (plist-get meta :args)) + :arglist (copy-tree (plist-get meta :arglist)) + :definition-version (plist-get meta :definition-version) + :entry-version (plist-get meta :entry-version) + :hidden (tp--stack-hidden-p layer) + :palette-deps (copy-tree (plist-get meta :palette-deps)) + :palette-generation (plist-get meta :palette-generation) + :legacy-no-args (plist-get meta :legacy-no-args)))) + +(defun tp--managed-buffer-diagnostic-data (buffer layer-filter) + "Collect managed diagnostics in BUFFER for LAYER-FILTER or all layers." + (let ((layers nil) + (entries nil) + (errors nil)) + (when (buffer-live-p buffer) + (tp--map-intervals + buffer nil nil + (lambda (start end props) + (condition-case err + (dolist (layer (tp--stack-props-to-list props)) + (let ((name (plist-get layer 'tp-name))) + (when (and name + (or (null layer-filter) + (equal name layer-filter))) + (cl-pushnew name layers :test #'equal) + (push (tp--managed-layer-entry start end layer) + entries)))) + (error + (push (list :range (cons start end) + :condition err) + errors)))))) + (list :buffer buffer + :layers (nreverse layers) + :entries (nreverse entries) + :observer-errors (copy-tree tp-reactive-observer-errors) + :errors (nreverse errors)))) + +;;;###autoload +(defun tp-managed-layer-diagnostics (layer-name) + "Return read-only managed diagnostics for LAYER-NAME." + (let ((entries nil) + (buffers nil) + (errors nil) + (registered (tp-reactive-layer-buffers layer-name))) + (dolist (buffer (if (eq registered 'unknown) + (buffer-list) + registered)) + (when (buffer-live-p buffer) + (let ((diag (tp--managed-buffer-diagnostic-data + buffer layer-name))) + (when (plist-get diag :entries) + (push buffer buffers) + (setq entries (append entries + (plist-get diag :entries)))) + (setq errors (append errors (plist-get diag :errors)))))) + (list :layer layer-name + :definition-version (tp--layer-definition-version layer-name) + :entries entries + :args (mapcar (lambda (entry) + (plist-get entry :args)) + entries) + :registry registered + :buffers (nreverse buffers) + :observer-errors + (cl-remove-if-not + (lambda (entry) (equal (plist-get entry :layer) layer-name)) + (copy-tree tp-reactive-observer-errors)) + :errors errors))) + +;;;###autoload +(defun tp-managed-buffer-diagnostics (&optional buffer) + "Return read-only managed diagnostics for BUFFER." + (tp--managed-buffer-diagnostic-data + (or buffer (current-buffer)) nil)) + +(defun tp--managed-theme-diagnostics () + "Return read-only managed theme diagnostics." + (list :generation (if (boundp 'tp-theme-generation) + tp-theme-generation 0) + :last-hook-source (and (boundp 'tp-theme-last-hook-source) + tp-theme-last-hook-source) + :refresh-mode (if (boundp 'tp-theme-last-refresh-mode) + tp-theme-last-refresh-mode :conservative) + :refreshed-ranges + (and (boundp 'tp-theme-last-refreshed-ranges) + tp-theme-last-refreshed-ranges) + :errors (and (boundp 'tp-theme-last-refresh-errors) + tp-theme-last-refresh-errors))) + +;;;###autoload +(defun tp-managed-diagnostics () + "Return read-only global managed lifecycle diagnostics." + (let ((layers nil) + (buffers nil) + (entries nil) + (errors nil)) + (dolist (buffer (buffer-list)) + (when (buffer-live-p buffer) + (let ((diag (tp--managed-buffer-diagnostic-data buffer nil))) + (when (plist-get diag :entries) + (push buffer buffers) + (setq layers (append layers (plist-get diag :layers))) + (setq entries (append entries + (plist-get diag :entries)))) + (setq errors (append errors (plist-get diag :errors)))))) + (list :layers (delete-dups layers) + :buffers (nreverse buffers) + :entries entries + :args (mapcar (lambda (entry) + (plist-get entry :args)) + entries) + :registry (copy-hash-table tp--layer-buffers) + :observer-errors (copy-tree tp-reactive-observer-errors) + :errors errors + :theme (tp--managed-theme-diagnostics)))) + +(defun tp--transaction-snapshot (start end object) + "Snapshot exact text and properties in START..END of OBJECT." + (if (stringp object) + (substring object start end) + (let ((buf (or object (current-buffer)))) + (with-current-buffer buf + (buffer-substring start end))))) + +(defun tp--transaction-restore (start end object snapshot) + "Restore SNAPSHOT over START..END of OBJECT." + (if (stringp object) + (progn + (unless (= (- end start) (length snapshot)) + (error "Cannot restore a resized string transaction")) + (store-substring object start (substring-no-properties snapshot)) + (set-text-properties start end nil object) + (tp--map-intervals + snapshot 0 (length snapshot) + (lambda (from to props) + (set-text-properties (+ start from) (+ start to) props object)))) + (let ((buf (or object (current-buffer)))) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (delete-region start end) + (goto-char start) + (insert snapshot)))))) + +(defun tp--transaction-runs (start end object) + "Return exact property intervals for START..END of OBJECT." + (tp-intervals start end object t)) + +(defun tp--transaction-changed-ranges (before after) + "Return ranges whose text/property intervals differ between BEFORE and AFTER." + (let (ranges) + (cl-loop for b in before + for a in after + unless (equal b a) + do (push (cons (nth 0 (or a b)) + (nth 1 (or a b))) + ranges)) + (when (/= (length before) (length after)) + (dolist (entry (nthcdr (min (length before) (length after)) + (append before after))) + (push (cons (nth 0 entry) (nth 1 entry)) ranges))) + (nreverse ranges))) + +(defun tp--transaction-live-bounds (from to markers) + "Return the live transaction bounds for FROM, TO, and MARKERS." + (if markers + (cons (marker-position (car markers)) + (marker-position (cdr markers))) + (cons from to))) + +(defun tp--transaction-result + (status operation-id stage start end object result condition rollback changed) + "Build a structured transaction result plist." + (list :status status + :ok (eq status 'ok) + :result result + :operation-id operation-id + :stage stage + :object object + :range (cons start end) + :current-run (car (tp--transaction-runs start end object)) + :layer nil + :entry-id nil + :expected-version nil + :actual-version nil + :expected-properties nil + :actual-properties nil + :original-condition condition + :rollback-applied rollback + :changed-ranges changed)) + +;;;###autoload +(defun tp-layer-transaction (start end object function &optional noerror) + "Run FUNCTION as a managed layer transaction over START..END of OBJECT. +On success, return a structured plist whose `:result' is FUNCTION's +value. On failure, restore the exact pre-transaction text/property +state. Signal `tp-layer-transaction-error' unless NOERROR is non-nil, +in which case return the structured failure plist." + (let* ((range (tp--native-range-from-object object start end)) + (obj (tp--native-range-object range)) + (from (tp--native-range-start range)) + (to (tp--native-range-end range)) + (operation-id (tp--managed-next-operation-id)) + (snapshot (tp--transaction-snapshot from to obj)) + (before (tp--transaction-runs from to obj)) + (markers (unless (stringp obj) + (cons (copy-marker from nil) + (copy-marker to nil))))) + (unwind-protect + (condition-case err + (let* ((result (funcall function)) + (live (tp--transaction-live-bounds from to markers))) + (tp--transaction-result + 'ok operation-id 'commit from to obj result nil nil + (tp--transaction-changed-ranges + before (tp--transaction-runs + (car live) (cdr live) obj)))) + (error + (let* ((live (tp--transaction-live-bounds from to markers)) + (rollback-applied nil) + rollback-condition) + (condition-case rollback-err + (progn + (tp--transaction-restore + (car live) (cdr live) obj snapshot) + (setq rollback-applied t)) + (error (setq rollback-condition rollback-err))) + (let ((result (tp--transaction-result + 'error operation-id 'body from to obj nil err + rollback-applied + (tp--transaction-changed-ranges + before (tp--transaction-runs from to obj))))) + (when rollback-condition + (setq result + (plist-put result :rollback-condition + rollback-condition))) + (if noerror + result + (signal 'tp-layer-transaction-error (list result))))))) + (when markers + (set-marker (car markers) nil) + (set-marker (cdr markers) nil))))) + ;;; Layer spec normalization for tp-put-layer (defun tp--put-layer-specs (layer-spec) @@ -323,9 +732,11 @@ string forms), otherwise the cons (START . END)." (if noerr (condition-case nil (tp--put-layer-specs layer-spec) - (error 'tp--unresolved)) + (tp-unresolved-layer 'tp--unresolved)) (tp--put-layer-specs layer-spec)))) (unless (eq layers-to-add 'tp--unresolved) + (setq layers-to-add + (tp--managed-add-meta-to-layers layer-spec layers-to-add)) (tp--stack-map-region start end obj (lambda (abs-start abs-end stack) diff --git a/tp-tests.el b/tp-tests.el index f4c84ba..4d7bb78 100644 --- a/tp-tests.el +++ b/tp-tests.el @@ -676,14 +676,15 @@ leak between tests regardless of how BODY exits." (goto-char 1) (let ((match (tp-forward 'face))) (should match) - (should (= (prop-match-end match) 7))))) + (should (= (prop-match-beginning match) 7)) + (should (= (prop-match-end match) 12))))) (ert-deftest tp-test-forward-on-string () "Test tp-forward works on string objects." (let ((str (copy-sequence "Hello World Hello"))) (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) - (let ((matches (tp-forward 'marker nil str 2))) + (let ((matches (tp-forward 'marker tp-any-value str 2))) (should (= (length matches) 2)) (should (equal (car matches) '(0 5 t))) (should (equal (cadr matches) '(12 17 t)))))) @@ -697,7 +698,7 @@ leak between tests regardless of how BODY exits." (tp-set 13 17 '(face bold)) (goto-char 1) ;; Search twice should find third match - (let ((match (tp-forward 'face nil nil 2))) + (let ((match (tp-forward 'face tp-any-value nil 2))) (should match)))) (ert-deftest tp-test-backward () @@ -710,19 +711,19 @@ leak between tests regardless of how BODY exits." (let ((match (tp-backward 'face 'bold))) (should match) (should (= (prop-match-beginning match) 1))) - ;; VALUE nil equal-matches the property-absent region, mirroring - ;; tp-forward (see tp-test-forward). + ;; Omitting VALUE matches any directly present property value. (goto-char 12) (let ((match (tp-backward 'face))) (should match) - (should (= (prop-match-beginning match) 6))))) + (should (= (prop-match-beginning match) 1)) + (should (= (prop-match-end match) 6))))) (ert-deftest tp-test-backward-on-string () "Test tp-backward works on string objects." (let ((str (copy-sequence "Hello World Hello"))) (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) - (let ((matches (tp-backward 'marker nil str 2))) + (let ((matches (tp-backward 'marker tp-any-value str 2))) (should (= (length matches) 2)) ;; Backward returns matches in reverse order (should (equal (car matches) '(12 17 t))) @@ -736,7 +737,7 @@ leak between tests regardless of how BODY exits." (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) ;; Search 2 times, function only applied to the last match - (let ((count (tp-forward-do #'upcase 'marker nil str 2))) + (let ((count (tp-forward-do #'upcase 'marker tp-any-value str 2))) (should (= count 2)) ;; First match should NOT be upcased (should (equal (substring str 0 5) "hello")) @@ -752,7 +753,8 @@ the buffer path) and returns the available count." (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) ;; Search only in range 6-17 (after first match) - (let ((count (tp-forward-do #'upcase 'marker nil str 2 6 17))) + (let ((count + (tp-forward-do #'upcase 'marker tp-any-value str 2 6 17))) (should (= count 1)) ; Only one match in range 6-17 ;; First match should NOT be upcased (should (equal (substring str 0 5) "hello")) @@ -769,9 +771,9 @@ the buffer path) and returns the available count." ;; Function accepts text, start, end (let ((count (tp-forward-do (lambda (txt start end) (push start starts) - (push end ends) - (upcase txt)) - 'marker nil str 2))) + (push end ends) + (upcase txt)) + 'marker tp-any-value str 2))) (should (= count 2)) ;; Only the last match positions were passed to function (should (equal starts '(12))) @@ -786,7 +788,7 @@ the buffer path) and returns the available count." (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) ;; Use #'upcase which only takes one argument - (tp-forward-do #'upcase 'marker nil str 2) + (tp-forward-do #'upcase 'marker tp-any-value str 2) ;; Only the last match should be upcased (should (equal (substring str 0 5) "hello")) (should (equal (substring str 12 17) "HELLO")))) @@ -797,7 +799,8 @@ the buffer path) and returns the available count." (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) ;; Search backward 2 times, function only applied to the last match - (let ((count (tp-backward-do #'upcase 'marker nil str 2))) + (let ((count (tp-backward-do + #'upcase 'marker tp-any-value str 2))) (should (= count 2)) ;; Only the last (2nd) match should be upcased (first in order) (should (equal (substring str 0 5) "HELLO")) @@ -812,7 +815,8 @@ nothing and returns the available count." (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) ;; Search only in range 0-10 (before second match) - (let ((count (tp-backward-do #'upcase 'marker nil str 2 0 10))) + (let ((count + (tp-backward-do #'upcase 'marker tp-any-value str 2 0 10))) (should (= count 1)) ; Only one match in range 0-10 ;; The requested 2nd match does not exist: nothing is applied (should (equal (substring str 0 5) "hello")) @@ -830,7 +834,7 @@ nothing and returns the available count." (push start starts) (push end ends) (upcase txt)) - 'marker nil str 2))) + 'marker tp-any-value str 2))) (should (= count 2)) ;; Only the last match positions were passed to function (should (equal starts '(0))) @@ -845,7 +849,7 @@ nothing and returns the available count." (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) ;; Use #'upcase which only takes one argument - (tp-backward-do #'upcase 'marker nil str 2) + (tp-backward-do #'upcase 'marker tp-any-value str 2) ;; Only the last match should be upcased (should (equal (substring str 0 5) "HELLO")) (should (equal (substring str 12 17) "hello")))) @@ -891,7 +895,7 @@ nothing and returns the available count." (tp--search-do (lambda (match _obj) (push (car match) result)) - 'marker nil str) + 'marker tp-any-value str) (should (= (length result) 2)) (should (member 0 result)) (should (member 12 result))))) @@ -906,7 +910,7 @@ nothing and returns the available count." (tp--search-do (lambda (match _obj) (push (car match) result)) - 'marker nil nil 1 18) + 'marker tp-any-value nil 1 18) (should (= (length result) 2)) (should (member 1 result)) (should (member 13 result))))) @@ -916,7 +920,7 @@ nothing and returns the available count." (let ((str (copy-sequence "hello World hello"))) (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) - (let ((count (tp-search-map #'upcase 'marker nil str))) + (let ((count (tp-search-map #'upcase 'marker tp-any-value str))) (should (= count 2)) ;; Check that text was upcased (should (equal (substring str 0 5) "HELLO")) @@ -928,7 +932,8 @@ nothing and returns the available count." (insert "hello World hello") (tp-set 1 6 '(marker t)) (tp-set 13 18 '(marker t)) - (let ((count (tp-search-map #'upcase 'marker nil nil 1 18))) + (let ((count + (tp-search-map #'upcase 'marker tp-any-value nil 1 18))) (should (= count 2)) ;; Check that text was upcased (should (equal (buffer-substring 1 6) "HELLO")) @@ -940,11 +945,11 @@ nothing and returns the available count." (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) ;; First upcase the text - (tp-search-map #'upcase 'marker nil str) + (tp-search-map #'upcase 'marker tp-any-value str) ;; Then add face property (tp-search-map (lambda (txt) (tp-add txt 'face '(:background "orange"))) - 'marker nil str) + 'marker tp-any-value str) ;; Check text was upcased (should (equal (substring str 0 5) "HELLO")) (should (equal (substring str 12 17) "HELLO")) @@ -965,7 +970,7 @@ nothing and returns the available count." (tp-search-map (lambda (txt start end idx) (push (list start end idx) positions) (upcase txt)) - 'marker nil str) + 'marker tp-any-value str) ;; Check positions and indices were passed in order (reversed due to push) (should (equal (reverse positions) '((0 3 0) (4 7 1) (8 11 2)))) ;; Check text was transformed (uppercased) @@ -984,7 +989,7 @@ nothing and returns the available count." (tp-search-map (lambda (_txt start end idx) (push (list start end idx) positions) (format "[%d]" idx)) - 'marker nil nil 1 12) + 'marker tp-any-value nil 1 12) ;; Check positions and indices were passed in order (should (equal (reverse positions) '((1 4 0) (5 8 1) (9 12 2)))) ;; Check text was replaced with index markers @@ -997,7 +1002,7 @@ nothing and returns the available count." (let ((str (copy-sequence "hello world"))) (tp-set 0 5 '(marker t) str) ;; Use #'upcase which only takes one argument - (tp-search-map #'upcase 'marker nil str) + (tp-search-map #'upcase 'marker tp-any-value str) (should (equal (substring str 0 5) "HELLO")))) (ert-deftest tp-test-search-map-with-range () @@ -1006,7 +1011,8 @@ nothing and returns the available count." (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) ;; Only search in range 0-10 (first match only) - (let ((count (tp-search-map #'upcase 'marker nil str 0 10))) + (let ((count + (tp-search-map #'upcase 'marker tp-any-value str 0 10))) (should (= count 1)) ;; First match should be upcased (should (equal (substring str 0 5) "HELLO")) diff --git a/tp.el b/tp.el index 9678396..0a343f5 100644 --- a/tp.el +++ b/tp.el @@ -33,6 +33,7 @@ ;; tp-render.el Reactive re-rendering engine (installs itself into ;; tp-reactive and tp-ops). ;; tp-stack.el Layer stack operations: push/pop/move/merge/... +;; tp-query.el Native lookup/change wrappers and mutation policy. ;; tp-palette.el Color palette data (light/dark aware). ;; tp-builtins.el Built-in layers (tp-fg, tp-link, tp-action, ...) ;; and display helpers. @@ -55,6 +56,7 @@ (require 'tp-search) (require 'tp-render) (require 'tp-stack) +(require 'tp-query) (require 'tp-palette) (require 'tp-builtins)