diff --git a/tp-search-tests.el b/tp-search-tests.el index 14855a7..1b5ad20 100644 --- a/tp-search-tests.el +++ b/tp-search-tests.el @@ -610,5 +610,79 @@ value changes when a non-nil predicate is given." (should (= (tp-forward-do #'upcase 'lvl 2 s) 1)) (should (equal (substring-no-properties s) "abc DEF")))) +;;; REG-1: pattern-apply paths must register buffers in the reactive registry + +(defvar tp-search-reg1-color nil) +(defvar tp-search-reg1b-color nil) + +(ert-deftest tp-search-test-regexp-add-registers-reactive-buffer () + "tp-regexp-add in a second buffer keeps reactive updates flowing there. +The deep-merge apply path stamps `tp-name' but never registered the +buffer, so once the layer was known from a `tp-set' elsewhere the +regexp-applied buffer went permanently stale (REG-1)." + (setq tp-search-reg1-color "red") + (unwind-protect + (progn + (tp-layer-reset) + (define-tp tp-search-reg1-layer () + :props '(face (:foreground $tp-search-reg1-color))) + (let ((a (generate-new-buffer " *tp-sreg1-a*")) + (b (generate-new-buffer " *tp-sreg1-b*"))) + (unwind-protect + (progn + (with-current-buffer a (insert "foo bar")) + (with-current-buffer b (insert "foo bar")) + (tp-set 1 4 'tp-search-reg1-layer a) ; registers A + (tp-regexp-add "foo" 'tp-search-reg1-layer b) + (let ((bufs (tp-reactive-layer-buffers + 'tp-search-reg1-layer))) + (should (memq a bufs)) + (should (memq b bufs))) + (setq tp-search-reg1-color "blue") + (should (equal (with-current-buffer a + (get-text-property 1 'face)) + '(:foreground "blue"))) + (should (equal (with-current-buffer b + (get-text-property 1 'face)) + '(:foreground "blue")))) + (kill-buffer a) + (kill-buffer b)))) + (tp-layer-reset) + (setq tp-search-reg1-color nil))) + +(ert-deftest tp-search-test-match-reset-registers-reactive-buffer () + "tp-match-reset in a second buffer keeps reactive updates flowing there. +The reset-apply path stamps `tp-name' via `set-text-properties' but +never registered the buffer (REG-1)." + (setq tp-search-reg1b-color "red") + (unwind-protect + (progn + (tp-layer-reset) + (define-tp tp-search-reg1b-layer () + :props '(face (:foreground $tp-search-reg1b-color))) + (let ((a (generate-new-buffer " *tp-sreg1b-a*")) + (b (generate-new-buffer " *tp-sreg1b-b*"))) + (unwind-protect + (progn + (with-current-buffer a (insert "foo bar")) + (with-current-buffer b (insert "foo bar")) + (tp-set 1 4 'tp-search-reg1b-layer a) + (tp-match-reset "foo" 'tp-search-reg1b-layer b) + (let ((bufs (tp-reactive-layer-buffers + 'tp-search-reg1b-layer))) + (should (memq a bufs)) + (should (memq b bufs))) + (setq tp-search-reg1b-color "blue") + (should (equal (with-current-buffer a + (get-text-property 1 'face)) + '(:foreground "blue"))) + (should (equal (with-current-buffer b + (get-text-property 1 'face)) + '(:foreground "blue")))) + (kill-buffer a) + (kill-buffer b)))) + (tp-layer-reset) + (setq tp-search-reg1b-color nil))) + (provide 'tp-search-tests) ;;; tp-search-tests.el ends here diff --git a/tp-search.el b/tp-search.el index 4c8a29e..a5872d7 100644 --- a/tp-search.el +++ b/tp-search.el @@ -20,9 +20,27 @@ (require 'cl-lib) (require 'text-property-search) (require 'tp-core) +(require 'tp-reactive) (require 'tp-layer) (require 'tp-ops) +(defun tp--search-register-layer-buffer (props object) + "Record OBJECT in the reactive buffer registry for PROPS's layers. +When OBJECT is a buffer or nil (the current buffer) and the applied +PROPS carry a `tp-name' - directly, or inside a `tp-layers' entry +from a group application - register that buffer under each layer name +via `tp-reactive--register-layer-buffer', so reactive updates keep +visiting buffers written through the pattern-apply paths. String +OBJECTs are not registered; see `tp-reactive-layer-buffers' for that +gap." + (when (or (null object) (bufferp object)) + (let ((buf (or object (current-buffer)))) + (when-let ((name (plist-get props 'tp-name))) + (tp-reactive--register-layer-buffer name buf)) + (dolist (layer (plist-get props 'tp-layers)) + (when-let ((name (plist-get layer 'tp-name))) + (tp-reactive--register-layer-buffer name buf)))))) + (defun tp--pattern-apply-single (pattern properties apply-fn object literal &optional start end subexp) "Apply APPLY-FN to matches of single PATTERN in OBJECT. @@ -190,7 +208,10 @@ For buffers, modifies in-place." (if (stringp obj) ;; For strings: create a new propertized string using tp--apply-props-to-string with :add mode (tp--apply-props-to-string obj start end props :add) - ;; For buffers: modify in-place + ;; For buffers: modify in-place. This path stamps `tp-name' for + ;; resolved layer applications, so the buffer must be registered + ;; in the reactive registry or later updates would skip it (REG-1). + (tp--search-register-layer-buffer props obj) (let ((pos start)) (while (< pos end) (let* ((current-props (text-properties-at pos obj)) @@ -265,6 +286,9 @@ For buffers, modifies in-place." (if (stringp obj) (tp--apply-props-to-string obj start end props :reset) (set-text-properties start end props obj) + ;; A resolved layer application stamps `tp-name': register the + ;; buffer so reactive updates keep visiting it (REG-1). + (tp--search-register-layer-buffer props obj) obj)) (defun tp-match-add (pattern plist &optional object start end) diff --git a/tp-stack-tests.el b/tp-stack-tests.el index be6a209..fbaa850 100644 --- a/tp-stack-tests.el +++ b/tp-stack-tests.el @@ -862,5 +862,91 @@ not just the first." (should (null (tp-at 1 'face))) (should (equal (tp-at 1 'help-echo) "tip")))) +;;; REG-1: every stack write must register its buffer in the reactive registry + +(defvar tp-st-reg1-color nil) + +(ert-deftest tp-stack-test-push-layer-registers-reactive-buffer () + "tp-push-layer in a second buffer keeps reactive updates flowing there. +Once the registry knows a layer from a `tp-set' in one buffer, a +stack-path application in another buffer must register too; before +the REG-1 fix the second buffer was silently and permanently skipped +by every later update." + (setq tp-st-reg1-color "red") + (unwind-protect + (progn + (tp-layer-reset) + (define-tp tp-st-reg1-layer () + :props '(face (:foreground $tp-st-reg1-color))) + (let ((a (generate-new-buffer " *tp-reg1-a*")) + (b (generate-new-buffer " *tp-reg1-b*"))) + (unwind-protect + (progn + (with-current-buffer a (insert "hello")) + (with-current-buffer b (insert "hello")) + (tp-set 1 6 'tp-st-reg1-layer a) ; registers A + (with-current-buffer b + (tp-push-layer 1 6 'tp-st-reg1-layer)) + ;; The registry must know BOTH buffers. + (let ((bufs (tp-reactive-layer-buffers 'tp-st-reg1-layer))) + (should (memq a bufs)) + (should (memq b bufs))) + (setq tp-st-reg1-color "blue") + (should (equal (with-current-buffer a + (get-text-property 1 'face)) + '(:foreground "blue"))) + (should (equal (with-current-buffer b + (get-text-property 1 'face)) + '(:foreground "blue"))) + ;; And the registration is permanent, not a one-shot fluke. + (setq tp-st-reg1-color "green") + (should (equal (with-current-buffer b + (get-text-property 1 'face)) + '(:foreground "green")))) + (kill-buffer a) + (kill-buffer b)))) + (tp-layer-reset) + (setq tp-st-reg1-color nil))) + +(ert-deftest tp-stack-test-stack-write-registers-buried-and-hidden-layers () + "Stack writes register every named layer of the new stack, not just the top. +A buried layer (under a fresh push) and a hidden layer arrive in the +buffer via string insertion - a path that never registers - and the +next stack write on the region must register them (REG-1; GC-1's +liveness depends on this)." + (unwind-protect + (progn + (tp-layer-reset) + (define-tp tp-st-reg1-buried () '(face bold)) + (define-tp tp-st-reg1-top () '(face italic)) + (define-tp tp-st-reg1-hidden () '(face underline)) + (let ((buf (generate-new-buffer " *tp-reg1-c*"))) + (unwind-protect + (with-current-buffer buf + ;; Propertized string insertion bypasses registration. + (insert (let ((s (copy-sequence "hello"))) + (tp-push-layer s 'tp-st-reg1-buried) + s)) + (insert (let ((s (copy-sequence " world"))) + (tp-push-layer s 'tp-st-reg1-hidden) + s)) + (should (eq (tp-reactive-layer-buffers 'tp-st-reg1-buried) + 'unknown)) + ;; Pushing a new top rewrites the stack: the buried + ;; layer below it must be registered as well. + (tp-push-layer 1 6 'tp-st-reg1-top) + (should (memq buf (tp-reactive-layer-buffers + 'tp-st-reg1-buried))) + (should (memq buf (tp-reactive-layer-buffers + 'tp-st-reg1-top))) + ;; Hiding rewrites the stack: the now-hidden layer must + ;; stay registered even though it loses its direct + ;; tp-name. + (tp-hide-layer 7 12 'tp-st-reg1-hidden) + (should (memq buf (tp-reactive-layer-buffers + 'tp-st-reg1-hidden)))) + (kill-buffer buf)))) + (tp-layer-reset))) + (provide 'tp-stack-tests) ;;; tp-stack-tests.el ends here diff --git a/tp-stack.el b/tp-stack.el index 783b1c5..d5e8984 100644 --- a/tp-stack.el +++ b/tp-stack.el @@ -20,6 +20,7 @@ (require 'cl-lib) (require 'dash) (require 'tp-core) +(require 'tp-reactive) (require 'tp-layer) (require 'tp-ops) @@ -133,6 +134,23 @@ layer properties at all when every layer is hidden) and the (t (append (car layer-list) (list 'tp-layers (cdr layer-list)))))) +(defun tp--stack-register-layers (stack object) + "Register OBJECT in the reactive buffer registry for every layer in STACK. +STACK is a list of layer plists as stored by the stack operations. +When OBJECT is a buffer or nil (the current buffer), every plist +carrying a `tp-name' - buried and hidden layers included - registers +that buffer via `tp-reactive--register-layer-buffer', so reactive +updates and the anonymous-layer GC keep seeing buffers whose layers +were written by stack mutators rather than by `tp-set'. String +OBJECTs are not registered; see `tp-reactive-layer-buffers' for that +gap. Registration is idempotent, so calling this once per rewritten +run is cheap." + (when (or (null object) (bufferp object)) + (let ((buf (or object (current-buffer)))) + (dolist (layer stack) + (when-let ((name (plist-get layer 'tp-name))) + (tp-reactive--register-layer-buffer name buf)))))) + ;;; Queries (defun tp-region-layer-props (start end layer-name &optional object) @@ -369,7 +387,8 @@ string forms), otherwise the cons (START . END)." (seq-drop stack actual-idx)))) (set-text-properties abs-start abs-end (tp--stack-build-props new-stack) - obj)))) + obj) + (tp--stack-register-layers new-stack obj)))) (or obj (cons start end)))))) (defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object noerror) @@ -425,10 +444,11 @@ alone and a return value of 0 means nothing matched at all." start end obj (lambda (abs-start abs-end stack) (when-let ((found (tp--get-layer-by-idx-or-name stack layer-id))) - (set-text-properties - abs-start abs-end - (tp--stack-build-props (-remove-at (car found) stack)) - obj) + (let ((new-stack (-remove-at (car found) stack))) + (set-text-properties abs-start abs-end + (tp--stack-build-props new-stack) + obj) + (tp--stack-register-layers new-stack obj)) (setq count (1+ count))))) count))) @@ -547,6 +567,7 @@ return value of 0 means nothing matched at all." (set-text-properties abs-start abs-end (tp--stack-build-props new-stack) obj) + (tp--stack-register-layers new-stack obj) (setq count (1+ count))))) count))) @@ -583,6 +604,7 @@ alone and a return value of 0 means nothing matched at all." (set-text-properties abs-start abs-end (tp--stack-build-props new-stack) obj) + (tp--stack-register-layers new-stack obj) (setq count (1+ count))))) count))) @@ -662,6 +684,7 @@ region had layers to rotate (or COUNT was below 1)." (set-text-properties abs-start abs-end (tp--stack-build-props new-stack) obj) + (tp--stack-register-layers new-stack obj) (setq applied (1+ applied))))))) applied))) @@ -713,6 +736,7 @@ left alone and a return value of 0 means nothing matched at all." (set-text-properties abs-start abs-end (tp--stack-build-props new-stack) obj) + (tp--stack-register-layers new-stack obj) (setq count (1+ count))))) count))) @@ -765,6 +789,7 @@ alone as well, so a return value of 0 means nothing changed." (set-text-properties abs-start abs-end (tp--stack-build-props new-stack) obj) + (tp--stack-register-layers new-stack obj) (setq count (1+ count))))))) count))) @@ -807,6 +832,7 @@ as well, so a return value of 0 means nothing changed." (set-text-properties abs-start abs-end (tp--stack-build-props new-stack) obj) + (tp--stack-register-layers new-stack obj) (setq count (1+ count))))))) count))) @@ -867,7 +893,8 @@ to nil in a higher-precedence layer stays nil in the merged layer." (setq new-stack (cons merged-props new-stack)) (set-text-properties abs-start abs-end (tp--stack-build-props new-stack) - obj)))))) + obj) + (tp--stack-register-layers new-stack obj)))))) nil)) (defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object) @@ -896,7 +923,8 @@ flattened result." for i from 0 collect (cons i layer)) (when name (list 'tp-name name))))) - (set-text-properties abs-start abs-end merged-props obj))))) + (set-text-properties abs-start abs-end merged-props obj) + (tp--stack-register-layers (list merged-props) obj))))) nil)) (defun tp-add-to-layers (idx-or-layer-name-list start-or-string &optional end-or-plist plist-or-object &rest rest) @@ -961,7 +989,8 @@ Returns the modified object (string) or nil for buffer operations." (when stack (set-text-properties abs-start abs-end (tp--stack-build-props modified-stack) - obj))))) + obj) + (tp--stack-register-layers modified-stack obj))))) (if (stringp obj) obj nil))) (defun tp-add-to-all-layers (start-or-string &optional end-or-plist plist-or-object &rest rest)