From 0a820bd0cb9cf227f08c3776f9cbe1d4c302d196 Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Wed, 9 Sep 2026 22:25:09 +0800 Subject: [PATCH] fix: preserve native interaction properties in incremental publication Preserve keymap ownership and hover grouping while applying minimal text patches. Reduce retained publication allocations without weakening policy comparisons or transactional rollback. Validation: 451 ERT tests, README doctests, strict byte compilation and checkdoc passed. --- tests/tp-core-tests.el | 43 +++ tests/tp-style-tests.el | 40 +++ tests/tp-surface-tests.el | 572 ++++++++++++++++++++++++++++++++++++++ tp-core.el | 32 ++- tp-style.el | 41 ++- tp-surface.el | 474 +++++++++++++++++++++++++++---- 6 files changed, 1143 insertions(+), 59 deletions(-) diff --git a/tests/tp-core-tests.el b/tests/tp-core-tests.el index 7e59681..c32ec87 100644 --- a/tests/tp-core-tests.el +++ b/tests/tp-core-tests.el @@ -161,6 +161,49 @@ (should (equal (nth 0 copy) "value")) (should (equal (nth 1 copy) ["nested"]))))) +(ert-deftest tp-core-test-property-value-copy-isolates-full-keymaps () + "Full keymaps, parent maps and self-references retain an isolated graph." + (let* ((map (make-keymap)) + (parent (make-keymap)) + (callback (lambda () "callback"))) + (define-key map (kbd "RET") callback) + (define-key parent (kbd "x") #'ignore) + (define-key map [prefix] map) + (set-keymap-parent map parent) + (let ((copy (tp-property-value-copy map))) + (should-not (eq copy map)) + (should-not (eq (keymap-parent copy) parent)) + (should (eq (lookup-key copy [prefix]) copy)) + (should (eq (lookup-key copy (kbd "RET")) callback)) + (define-key map (kbd "RET") #'forward-char) + (define-key parent (kbd "x") #'backward-char) + (should (eq (lookup-key copy (kbd "RET")) callback)) + (should (eq (lookup-key copy (kbd "x")) #'ignore))))) + +(ert-deftest tp-core-test-property-value-copy-preserves-character-table-structure () + "Local ranges, defaults, parents, extra slots and cycles are copied faithfully." + (let ((purpose (make-symbol "tp-copy-table"))) + (put purpose 'char-table-extra-slots 1) + (let* ((parent (make-char-table purpose)) + (table (make-char-table purpose)) + (value (list 'value))) + (set-char-table-range parent ?p value) + (set-char-table-range table ?x value) + (set-char-table-range table ?s table) + (set-char-table-extra-slot table 0 value) + (set-char-table-parent table parent) + (let ((copy (tp-property-value-copy table))) + (should (eq (char-table-range copy ?s) copy)) + (should (eq (char-table-range copy ?x) (char-table-extra-slot copy 0))) + (should (eq (char-table-range copy ?x) + (char-table-range (char-table-parent copy) ?p))) + (set-char-table-range (char-table-parent copy) ?p 'new) + (should (eq (char-table-range copy ?p) 'new)) + (set-char-table-range copy nil 'default) + (should (eq (char-table-range copy ?z) 'default)) + (setcar value 'mutated) + (should (equal (char-table-range copy ?x) '(value))))))) + (ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque () "Property copies keep list-shaped function values opaque." (let ((function-value '(lambda () 1))) diff --git a/tests/tp-style-tests.el b/tests/tp-style-tests.el index b1c079d..eabbcd1 100644 --- a/tests/tp-style-tests.el +++ b/tests/tp-style-tests.el @@ -14,6 +14,46 @@ (require 'tp-style) (require 'tp-layer) +(ert-deftest tp-style-test-native-keymaps-preserve-all-binding-facts () + "Snapshots compare by prompts, menu order, parents and literal commands." + (let* ((factory (eval '(lambda () + (let ((n 0)) + (lambda () (setq n (1+ n))))) t)) + (first (funcall factory)) (second (funcall factory)) + (map (make-keymap "Root")) + (prefix (make-sparse-keymap "Prefix")) + (parent (make-sparse-keymap "Parent"))) + (define-key map (kbd "RET") first) + (define-key map [t] #'ignore) + (define-key prefix [self] prefix) + (define-key prefix [one] '(menu-item "One" ignore)) + (define-key prefix [two] '(menu-item "Two" forward-char)) + (define-key map [prefix] prefix) + (define-key parent [inherited] #'backward-char) + (set-keymap-parent map parent) + (should (equal first second)) + (should (tp--native-property-value-equal-p map (tp-property-value-copy map))) + (dolist (kind '(root-prompt prefix-prompt parent-prompt menu-order + callback default inherited)) + (let ((copy (tp-property-value-copy map))) + (pcase kind + ((or 'root-prompt 'prefix-prompt 'parent-prompt) + (let* ((target (pcase kind + ('root-prompt copy) + ('prefix-prompt (lookup-key copy [prefix])) + ('parent-prompt (keymap-parent copy)))) + (cell (memq (keymap-prompt target) target))) + (setcar cell "Changed"))) + ('menu-order + (let* ((target (lookup-key copy [prefix])) + (one (lookup-key target [one]))) + (define-key target [one] nil t) + (define-key target [one] one))) + ('callback (define-key copy (kbd "RET") second)) + ('default (define-key copy [t] #'forward-char)) + ('inherited (define-key (keymap-parent copy) [inherited] #'ignore))) + (should-not (tp--native-property-value-equal-p map copy)))))) + (defmacro tp-style-test--isolated (&rest body) "Run BODY with isolated TP property and named-style registries." (declare (indent 0) (debug t)) diff --git a/tests/tp-surface-tests.el b/tests/tp-surface-tests.el index 6eeea1d..8b3ccb6 100644 --- a/tests/tp-surface-tests.el +++ b/tests/tp-surface-tests.el @@ -24,6 +24,189 @@ (tp-surface-plan-create :key key :kind 'text :text text :props props :capability 'content)) +(ert-deftest tp-surface-test-native-callback-replacement-preserves-identity () + "Different equal-shaped callbacks publish through text and contribution paths." + (dolist (as-text '(nil t)) + (tp-surface-test--with-buffer + (let* ((factory (eval '(lambda () + (let ((n 0)) + (lambda (_w _o _p) (setq n (1+ n))))) t)) + (first (funcall factory)) (second (funcall factory)) + (plan (lambda (callback) + (tp-surface-test--leaf + 'root (if as-text (propertize "text" 'help-echo callback) + "text") + (unless as-text (list 'help-echo callback))))) + (surface (tp-surface-mount (current-buffer) (funcall plan first) + '(:capability content)))) + (should (equal first second)) + (should-not (eq first second)) + (tp-surface-update surface (funcall plan second)) + (should (= (tp-surface-revision surface) 2)) + (should (eq (get-text-property (point-min) 'help-echo) second)) + (should (= (funcall first nil nil nil) 1)) + (should (= (funcall second nil nil nil) 1)))))) + +(ert-deftest tp-surface-test-native-keymap-prompts-publish-and-respect-scope () + "Copied maps allow local publication; changed nested prompts stay in scope." + (dolist (as-text '(nil t)) + (dolist (nested '(nil t)) + (tp-surface-test--with-buffer + (let ((prompt "Before") (middle "B") middle-object) + (let* ((make-map + (lambda () + (let ((map (make-sparse-keymap prompt))) + (define-key map (kbd "RET") #'ignore) + (if nested + (let ((outer (make-sparse-keymap "Outer"))) + (define-key outer [prefix] map) + outer) + map)))) + (producer + (lambda (context) + (let ((root (tp-object-ensure context nil 'root 'group))) + (setq middle-object + (tp-object-ensure context root 'middle 'text)) + (tp-object-ensure context root 'right 'text)) + (let ((map (funcall make-map))) + (tp-surface-plan-create + :key 'root :kind 'group :capability 'content + :children + (list (tp-surface-test--leaf 'middle middle) + (tp-surface-test--leaf + 'right (if as-text (propertize "C" 'keymap map) "C") + (unless as-text (list 'keymap map)))))))) + (surface (tp-surface-mount buffer producer '(:capability content)))) + (setq middle "M") + (tp-surface-update-scoped surface (list middle-object) producer) + (should (equal (buffer-substring-no-properties 1 3) "MC")) + (setq prompt "After" middle "N") + (should-error + (tp-surface-update-scoped surface (list middle-object) producer) + :type 'tp-scope-mismatch) + (should (= (tp-surface-revision surface) 2)) + (should (equal (buffer-substring-no-properties 1 3) "MC")) + (tp-surface-update surface producer) + (let* ((map (get-text-property 2 'keymap)) + (target (if nested (lookup-key map [prefix]) map))) + (should (equal (keymap-prompt target) "After"))))))))) + +(ert-deftest tp-surface-test-native-hover-group-survives-local-publication () + "Scoped text and property edits preserve groups without merging equal faces." + (dolist (scoped '(nil t)) + (tp-surface-test--with-buffer + (let ((middle "b") (help "old") logical) + (let* ((producer + (lambda (context) + (let* ((root (tp-object-ensure context nil 'root 'text)) + (hover (list :background "blue")) + (text (concat (propertize (concat "a" middle "c") + 'mouse-face hover) + (propertize "z" 'mouse-face (copy-sequence hover))))) + (setq logical (tp-object-ensure context root 'logical 'item)) + (tp-object-attach-content-range context logical root + 1 (1+ (length middle))) + (put-text-property 1 (1+ (length middle)) 'help-echo help text) + (tp-surface-test--leaf 'root text)))) + (surface (tp-surface-mount buffer producer '(:capability content)))) + (dolist (operation '(property text rollback)) + (let ((before (buffer-string)) + (revision (tp-surface-revision surface))) + (setq help (symbol-name operation)) + (when (eq operation 'text) (setq middle "longer")) + (cl-labels ((update () + (if scoped + (tp-surface-update-scoped surface (list logical) producer) + (tp-surface-update surface producer)))) + (if (eq operation 'rollback) + (let ((tp--surface-publication-step-function + (lambda (step _surface) + (when (eq step 'property) (error "Reject hover"))))) + (should-error (update)) + (should (= revision (tp-surface-revision surface))) + (dotimes (position (length before)) + (should (eq (get-text-property position 'mouse-face before) + (get-text-property (1+ position) 'mouse-face))))) + (update)))) + (let ((hover (get-text-property 1 'mouse-face)) + (last (+ 2 (length middle)))) + (cl-loop for position from 1 to last do + (should (eq hover (get-text-property position 'mouse-face)))) + (should (equal hover (get-text-property (1+ last) 'mouse-face))) + (should-not (eq hover (get-text-property (1+ last) 'mouse-face)))))))))) + +(ert-deftest tp-surface-test-scoped-hover-cannot-regroup-outside-groups () + "Equal paint does not authorize merging or splitting groups outside scope." + (dolist (initial '(nil t)) + (tp-surface-test--with-buffer + (let ((unify initial) logical) + (let* ((producer + (lambda (context) + (let* ((root (tp-object-ensure context nil 'root 'text)) + (hover (list :background "blue")) + (text (concat (propertize "ab" 'mouse-face hover) + (propertize "c" 'mouse-face + (if unify hover (copy-sequence hover)))))) + (setq logical (tp-object-ensure context root 'logical 'item)) + (tp-object-attach-content-range context logical root 1 2) + (put-text-property 1 2 'help-echo (if unify "new" "old") text) + (tp-surface-test--leaf 'root text)))) + (surface (tp-surface-mount buffer producer '(:capability content))) + (left (get-text-property 1 'mouse-face)) + (right (get-text-property 3 'mouse-face))) + (setq unify (not initial)) + (should-error (tp-surface-update-scoped surface (list logical) producer) + :type 'tp-scope-mismatch) + (should (= (tp-surface-revision surface) 1)) + (should (eq left (get-text-property 1 'mouse-face))) + (should (eq right (get-text-property 3 'mouse-face)))))))) + +(ert-deftest tp-surface-test-scoped-hover-checks-entire-outside-gap () + "A remote same-paint group change is outside scope even with fresh snapshots." + (dolist (initial '(nil t)) + (tp-surface-test--with-buffer + (let ((unify initial) logical) + (let* ((producer + (lambda (context) + (let* ((root (tp-object-ensure context nil 'root 'text)) + (hover (list :background "blue")) + (text (concat "abc" (propertize "d" 'mouse-face hover) + (propertize "e" 'mouse-face + (if unify hover (copy-sequence hover)))))) + (setq logical (tp-object-ensure context root 'logical 'item)) + (tp-object-attach-content-range context logical root 1 2) + (put-text-property 1 2 'help-echo (if unify "new" "old") text) + (tp-surface-test--leaf 'root text)))) + (surface (tp-surface-mount buffer producer '(:capability content)))) + (setq unify (not initial)) + (should-error (tp-surface-update-scoped surface (list logical) producer) + :type 'tp-scope-mismatch) + (should (= (tp-surface-revision surface) 1))))))) + +(ert-deftest tp-surface-test-scoped-hover-does-not-join-separated-outside-gaps () + "A scope with no hover separates equal outside faces regardless of identity." + (tp-surface-test--with-buffer + (let (separate logical) + (let* ((producer + (lambda (context) + (let* ((root (tp-object-ensure context nil 'root 'text)) + (hover (list :background "blue")) + (text (concat (propertize "a" 'mouse-face hover) + (propertize "b" 'help-echo (if separate "new" "old")) + (propertize "c" 'mouse-face + (if separate (copy-sequence hover) hover))))) + (setq logical (tp-object-ensure context root 'logical 'item)) + (tp-object-attach-content-range context logical root 1 2) + (tp-surface-test--leaf 'root text)))) + (surface (tp-surface-mount buffer producer '(:capability content)))) + (setq separate t) + (tp-surface-update-scoped surface (list logical) producer) + (should (= (tp-surface-revision surface) 2)) + (should (equal (get-text-property 2 'help-echo) "new")) + (should-not (get-text-property 2 'mouse-face)) + (should (equal (get-text-property 1 'mouse-face) + (get-text-property 3 'mouse-face))))))) + (defun tp-surface-test--producer (signal) "Return a retained content producer reading SIGNAL." (lambda (context) @@ -521,6 +704,395 @@ the batch instead of retaining their unchanged coordinates." (eq (cadr entry) 'commit))) tp--last-transaction-diagnostics))))) +(ert-deftest tp-surface-test-retained-batch-avoids-full-plan-and-output-replay () + "Revision-bearing batches bypass duplicate plan walks, even for no-op text." + (dolist (replacement '("X" "b" nil)) + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount buffer (tp-surface-test--leaf 'root "abc") + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (batch (if replacement + (tp-surface-test--replacement-batch surface replacement) + (tp-commit-batch-create + :base-revision 1 :target-revision 2 + :base-extent 3 :target-extent 3)))) + (cl-letf (((symbol-function 'tp--plan-equal-p) + (lambda (&rest _) (ert-fail "Retained plan was traversed"))) + ((symbol-function 'tp--shadow-apply-commit-batch-to-string) + (lambda (&rest _) (ert-fail "Full output was rebuilt")))) + (tp-surface-test--commit-batch-update + surface root batch '(:owned next) + (lambda (entry _prepared) + (should + (tp--shadow-batch-output-p + (plist-get + (plist-get (tp-publication-target-entry-shadow-expected entry) + :commit) + :output)))))) + (should (= (tp-surface-revision surface) 2)) + (should (equal (buffer-string) (if (equal replacement "X") "aXc" "abc"))) + (should (plist-get tp--last-shadow-proof :equivalent)))))) + +(ert-deftest tp-surface-test-batch-writes-only-changed-characters () + "Direct and retained batches retain anchors and write only the changed digit." + (dolist (retained '(nil t)) + (tp-surface-test--with-buffer + (let* ((text (propertize "prefix 00 suffix" 'help-echo "old")) + (surface + (tp-surface-mount buffer (tp-surface-test--leaf 'root text) + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (prefix-anchor (copy-marker 4)) + (suffix-anchor (copy-marker 14)) + changes) + (unwind-protect + (progn + (goto-char 4) + (add-hook 'before-change-functions + (lambda (start end) (push (- end start) changes)) nil t) + (let ((batch + (tp-commit-batch-create + :base-revision 1 :target-revision 2 + :base-extent 16 :target-extent 16 + :patches + (list (list :old-start 0 :old-end 16 :new-start 0 :new-end 16 + :replacement + (propertize "prefix 01 suffix" 'help-echo "new")))))) + (if retained + (tp-surface-test--commit-batch-update surface root batch nil #'ignore) + (tp-surface-commit-batch surface batch))) + (should (= (point) 4)) + (should (= (marker-position prefix-anchor) 4)) + (should (= (marker-position suffix-anchor) 14)) + (should (= (apply #'+ changes) 1)) + (should (= (plist-get (tp-surface-report surface) :text-operations) 1)) + (should (> (plist-get (tp-surface-report surface) :property-operations) 0)) + (should (equal (buffer-string) "prefix 01 suffix")) + (dotimes (position 16) + (should (equal (get-text-property (1+ position) 'help-echo) "new")))) + (set-marker prefix-anchor nil) + (set-marker suffix-anchor nil)))))) + +(ert-deftest tp-surface-test-batch-property-only-final-accept-rolls-back () + "Property-only batches journal unchanged characters for both public paths." + (dolist (retained '(nil t)) + (tp-surface-test--with-buffer + (let* ((first (lambda (&rest _) "first")) + (second (lambda (&rest _) "second")) + (surface + (tp-surface-mount + buffer (tp-surface-test--leaf 'root (propertize "abc" 'help-echo first)) + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (batch (tp-surface-test--replacement-batch + surface (propertize "b" 'help-echo second)))) + (goto-char 2) + (cl-letf (((symbol-function 'accept-change-group) + (lambda (_group) (error "Reject property batch")))) + (should-error + (if retained + (tp-surface-test--commit-batch-update surface root batch nil #'ignore) + (tp-surface-commit-batch surface batch)))) + (should (= (point) 2)) + (should (eq first (get-text-property 2 'help-echo))) + (should (= (tp-surface-revision surface) 1)) + (dolist (expected-property-operations '(1 0)) + (let ((next (tp-surface-test--replacement-batch + surface (propertize "b" 'help-echo second)))) + (if retained + (tp-surface-test--commit-batch-update surface root next nil #'ignore) + (tp-surface-commit-batch surface next))) + (should (= (plist-get (tp-surface-report surface) :text-operations) 0)) + (should (= (plist-get (tp-surface-report surface) :property-operations) + expected-property-operations))) + (should (= (tp-surface-revision surface) 3)))))) + +(ert-deftest tp-surface-test-retained-batch-shadow-detects-unrecorded-outside-writes () + "Outside writes remain diagnosed with undo and change hooks disabled." + (dolist (side '(1 3)) + (dolist (fault '(text property callback keymap)) + (tp-surface-test--with-buffer + (let* ((factory (eval '(lambda () + (let ((n 0)) + (lambda (&rest _) (setq n (1+ n))))) t)) + (first (funcall factory)) (second (funcall factory)) + (map (make-sparse-keymap "Before")) + (_binding (define-key map [return] first)) + (surface + (tp-surface-mount + buffer (tp-surface-test--leaf + 'root (propertize "abc" 'help-echo first 'keymap map)) + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (batch (tp-surface-test--replacement-batch + surface (propertize "X" 'help-echo first 'keymap map))) + (tp--surface-publication-step-function + (lambda (step _surface) + (when (eq step 'client-state) + (let ((inhibit-modification-hooks t) + (buffer-undo-list t)) + (pcase fault + ('text (subst-char-in-region side (1+ side) + (char-after side) ?Z)) + ('property (put-text-property side (1+ side) 'alien t)) + ('callback + (put-text-property side (1+ side) 'help-echo second)) + ('keymap + (let ((other (make-sparse-keymap "After"))) + (define-key other [return] second) + (put-text-property side (1+ side) 'keymap other))))))))) + (should (equal first second)) + (should-not (eq first second)) + (tp-surface-test--commit-batch-update surface root batch nil #'ignore) + (should (= (tp-surface-revision surface) 2)) + (should-not (plist-get tp--last-shadow-proof :equivalent))))))) + +(ert-deftest tp-surface-test-retained-shadow-patch-evidence-is-detached () + "Staged string and native map mutations cannot rewrite expected evidence." + (dolist (fault '(character callback keymap)) + (tp-surface-test--with-buffer + (let* ((callback (lambda (&rest _) "first")) + (replacement-map (make-sparse-keymap "Before")) + (_binding (define-key replacement-map [return] callback)) + (surface + (tp-surface-mount buffer (tp-surface-test--leaf 'root "abc") + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (batch (tp-surface-test--replacement-batch + surface (propertize (copy-sequence "X") + 'help-echo callback 'keymap replacement-map)))) + (tp-surface-test--commit-batch-update + surface root batch nil + (lambda (_entry _prepared) + (let ((replacement (plist-get (car (tp-commit-batch-patches batch)) + :replacement))) + (pcase fault + ('character (aset replacement 0 ?Z)) + ('callback (put-text-property 0 1 'help-echo #'ignore replacement)) + ('keymap (define-key (get-text-property 0 'keymap replacement) + [return] #'ignore)))))) + (should-not (plist-get tp--last-shadow-proof :equivalent)))))) + +(ert-deftest tp-surface-test-retained-shadow-detects-same-paint-regrouping () + "Retained proof rejects outside group changes without relying on undo hooks." + (dolist (phase '(client-state cleanup)) + (dolist (tamper '(nil gap seam)) + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount + buffer (tp-surface-test--leaf + 'root (propertize "abcde" 'mouse-face (list :background "blue"))) + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (hover (get-text-property 1 'mouse-face)) + (batch + (tp-commit-batch-create + :base-revision 1 :target-revision 2 :base-extent 5 :target-extent 5 + :patches (list (list :old-start 1 :old-end 2 :new-start 1 :new-end 2 + :replacement (propertize "X" 'mouse-face hover))))) + (mutate + (lambda (step _state) + (when (and tamper (eq step phase)) + (let ((inhibit-modification-hooks t) (buffer-undo-list t) + (start (if (eq tamper 'gap) 4 2))) + (put-text-property start (1+ start) 'mouse-face + (copy-sequence hover)))))) + (tp--surface-publication-step-function mutate) + (tp--surface-precommit-step-function mutate)) + (if tamper + (progn + (should-error + (tp-surface-test--commit-batch-update surface root batch nil #'ignore) + :type 'tp-scope-mismatch) + (should (= (tp-surface-revision surface) 1)) + (should (equal (buffer-string) "abcde")) + (dotimes (offset 5) + (should (eq hover (get-text-property (1+ offset) 'mouse-face)))) + (should (eq (plist-get tp--last-shadow-proof :phase) 'rollback))) + (tp-surface-test--commit-batch-update surface root batch nil #'ignore) + (should (= (tp-surface-revision surface) 2))) + (should (plist-get tp--last-shadow-proof :equivalent))))))) + +(ert-deftest tp-surface-test-retained-batch-final-accept-restores-native-properties () + "Final-accept error and quit restore native identity and retained side state." + (dolist (injected '((error "Retained accept failure") (quit))) + (tp-surface-test--with-buffer + (let* ((first (lambda (&rest _) "first")) + (second (lambda (&rest _) "second")) + (map (make-sparse-keymap "Before")) + (_binding (define-key map [return] #'ignore)) + (surface + (tp-surface-mount + buffer (tp-surface-test--leaf + 'root (propertize "abc" 'help-echo first 'keymap map)) + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (mounts (tp--surface-mounts surface)) + (index (tp--surface-mount-index surface)) + (output (buffer-string)) + (batch (tp-surface-test--replacement-batch + surface (propertize "X" 'help-echo second 'keymap map))) + failure) + (cl-letf (((symbol-function 'accept-change-group) + (lambda (_group) (signal (car injected) (cdr injected))))) + (setq failure + (tp-surface-test--capture-condition + (lambda () + (tp-surface-test--commit-batch-update + surface root batch '(:owned next) #'ignore))))) + (should (equal failure injected)) + (should (tp--text-property-semantic-equal-p output (buffer-string))) + (should (eq first (get-text-property 2 'help-echo))) + (should (eq mounts (tp--surface-mounts surface))) + (should (eq index (tp--surface-mount-index surface))) + (should (= (tp-surface-revision surface) 1)) + (should-not (tp-surface-client-state surface)) + (should (eq (plist-get tp--last-shadow-proof :phase) 'rollback)) + (should (plist-get tp--last-shadow-proof :equivalent)) + (tp-surface-test--commit-batch-update + surface root batch '(:owned next) #'ignore) + (should (eq second (get-text-property 2 'help-echo))) + (should (= (tp-surface-revision surface) 2)) + (should (plist-get tp--last-shadow-proof :equivalent)))))) + +(ert-deftest tp-surface-test-retained-shadow-range-proof-matches-full-replay () + "Patch evidence covers all gaps, insertions, removals, and property boundaries." + (dolist (specs '(((0 0 "α") (1 3 "XY") (6 6 "尾")) + ((0 6 "") (6 6 "新值")) + ((1 2 "") (2 2 "二") (4 5 "四五六")) + ((2 2 "一") (2 2 "二")) nil)) + (let ((base (concat (propertize "abc" 'face '(bold)) + (propertize "def" 'face '(italic)))) + (old-position 0) (new-position 0) patches) + (dolist (spec specs) + (pcase-let* ((`(,start ,end ,text) spec) + (new-start (+ new-position (- start old-position))) + (new-end (+ new-start (length text)))) + (push (list :old-start start :old-end end + :new-start new-start :new-end new-end + :replacement (propertize text 'face '(underline))) patches) + (setq old-position end new-position new-end))) + (setq patches (nreverse patches)) + (let* ((extent (+ new-position (- (length base) old-position))) + (batch (tp-commit-batch-create + :base-revision 0 :target-revision 1 :base-extent 6 + :target-extent extent :patches patches + :coordinate-patches + (mapcar (lambda (patch) + (list :old-start (plist-get patch :old-start) + :old-end (plist-get patch :old-end) + :new-start (plist-get patch :new-start) + :new-end (plist-get patch :new-end))) + patches))) + (expected (tp--shadow-batch-output-create base batch)) + (actual (tp-surface-test--shadow-apply-commit-batch-oracle base batch))) + (should (tp--shadow-batch-output-equal-p expected actual)) + (with-temp-buffer + (insert "prefix" actual "suffix") + (should (tp--shadow-batch-output-equal-p + expected (current-buffer) 7 (+ 7 extent)))) + (dotimes (position extent) + (let ((changed (copy-sequence actual))) + (put-text-property position (1+ position) 'alien t changed) + (should-not (tp--shadow-batch-output-equal-p expected changed)) + (with-temp-buffer + (insert "prefix" changed "suffix") + (should-not (tp--shadow-batch-output-equal-p + expected (current-buffer) 7 (+ 7 extent)))))) + (should-not (tp--shadow-batch-output-equal-p expected (concat actual "!"))))))) + +(ert-deftest tp-surface-test-retained-shadow-reuses-only-verified-output () + "Verified evidence avoids copying output; opaque mismatches retain diagnostics." + (tp-surface-test--with-buffer + (let* ((factory (eval '(lambda () (let ((n 0)) + (lambda (&rest _) (setq n (1+ n))))) t)) + (first (funcall factory)) (second (funcall factory)) + (surface (tp-surface-mount + buffer (tp-surface-test--leaf 'root (propertize "abc" 'help-echo first)) + '(:capability content :coordinate-mounts t))) + (expected (tp--shadow-batch-output-create + (buffer-string) + (tp-commit-batch-create :base-revision 1 :target-revision 2 + :base-extent 3 :target-extent 3)))) + (cl-letf (((symbol-function 'tp--shadow-surface-output) + (lambda (_) (ert-fail "Verified output was copied again")))) + (should (eq expected (plist-get (tp--shadow-current-artifact surface expected) + :output)))) + (should (equal first second)) + (should-not (eq first second)) + (let ((inhibit-modification-hooks t) (buffer-undo-list t)) + (put-text-property 3 4 'help-echo second)) + (let* ((actual (tp--shadow-current-artifact surface expected)) + (target (plist-put (copy-sequence actual) :output expected))) + (should (stringp (plist-get actual :output))) + (should (eq second (get-text-property 2 'help-echo (plist-get actual :output)))) + (should-not (tp--shadow-artifact-equal-p target actual)))))) + +(ert-deftest tp-surface-test-retained-shadow-verifies-custom-policy-and-buffer-tick () + "Custom policy equality is honored without reusing evidence across its writes." + (tp-surface-test--with-buffer + (let* ((property (make-symbol "shadow-custom-policy")) + mutate + (_policy (tp-define-property-policy + (tp-text-property-id property) :equality + (lambda (a b) + (when mutate + (let ((inhibit-modification-hooks t) (buffer-undo-list t)) + (put-text-property 1 2 'alien t buffer))) + (equal (downcase a) (downcase b))))) + (surface (tp-surface-mount + buffer (tp-surface-test--leaf 'root (propertize "abc" property "OLD")) + '(:capability content :coordinate-mounts t))) + (expected (tp--shadow-batch-output-create + (buffer-string) + (tp-commit-batch-create :base-revision 1 :target-revision 2 + :base-extent 3 :target-extent 3)))) + (let ((inhibit-modification-hooks t)) + (put-text-property 1 4 property "old")) + (let* ((actual (tp--shadow-current-artifact surface expected)) + (target (plist-put (copy-sequence actual) :output expected))) + (should (stringp (plist-get actual :output))) + (should (tp--shadow-artifact-equal-p target actual))) + (setq mutate t) + (let* ((actual (tp--shadow-current-artifact surface expected)) + (target (plist-put (copy-sequence actual) :output expected))) + (should (stringp (plist-get actual :output))) + (should (get-text-property 0 'alien (plist-get actual :output))) + (should-not (tp--shadow-artifact-equal-p target actual)))))) + +(ert-deftest tp-surface-test-retained-shadow-isolates-custom-policy-evidence () + "A custom policy cannot alias actual evidence by retaining its expected value." + (dolist (when-to-mutate '(during after)) + (tp-surface-test--with-buffer + (let* ((property (make-symbol "shadow-retained-evidence")) + captured + (_policy (tp-define-property-policy + (tp-text-property-id property) :equality + (lambda (a b) + (prog1 (equal (downcase a) (downcase b)) + (setq captured a) + (when (eq when-to-mutate 'during) (aset a 0 ?X)))))) + (surface (tp-surface-mount + buffer (tp-surface-test--leaf + 'root (propertize "abc" property (copy-sequence "OLD"))) + '(:capability content :coordinate-mounts t))) + (expected (tp--shadow-batch-output-create + (buffer-string) + (tp-commit-batch-create :base-revision 1 :target-revision 2 + :base-extent 3 :target-extent 3)))) + (let ((inhibit-modification-hooks t)) (put-text-property 1 4 property "old")) + (let* ((tick (buffer-modified-tick)) + (actual (tp--shadow-current-artifact surface expected))) + (should (stringp (plist-get actual :output))) + (should captured) + (when (eq when-to-mutate 'after) (aset captured 0 ?X)) + (should (= tick (buffer-modified-tick))) + (should (equal (get-text-property 0 property (plist-get actual :output)) "old")) + (should-not + (tp--shadow-artifact-equal-p + (plist-put (copy-sequence actual) :output expected) actual))))))) + (ert-deftest tp-surface-test-shadow-batch-replay-preserves-exact-properties () "Shadow replay preserves Unicode, properties, order, and input ownership." (let* ((opaque (make-symbol "owner")) diff --git a/tp-core.el b/tp-core.el index 7b9d260..fe4ce9f 100644 --- a/tp-core.el +++ b/tp-core.el @@ -279,6 +279,7 @@ Otherwise, START-OR-STRING and END define the range." (and (not (functionp value)) (or (consp value) (stringp value) + (char-table-p value) (and (vectorp value) (not (recordp value)))))) (defun tp--copy-cons-spine (value cache) @@ -309,6 +310,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology." (if (and (not (functionp item)) (or (consp item) (stringp item) + (char-table-p item) (and (vectorp item) (not (recordp item))))) (tp--copy-property-value item cache) item))) @@ -344,6 +346,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply." (when (and (not (functionp item)) (or (consp item) (stringp item) + (char-table-p item) (and (vectorp item) (not (recordp item))))) (setcar target (tp--copy-property-value item cache)))) (setq source (cdr source) @@ -406,7 +409,8 @@ values are recursively isolated." (defun tp--copy-property-value (value &optional cache) "Return a defensive copy of mutable containers in property VALUE. Optional CACHE preserves sharing and cycles across recursive copies. -Cons cells, strings, and vectors are copied recursively. Functions, records, +Cons cells, strings, vectors and character tables are copied recursively. +Functions, records, and other opaque objects keep their identity; functions are never executed." (if (not (tp--copy-mutable-property-value-p value)) value @@ -420,6 +424,29 @@ and other opaque objects keep their identity; functions are never executed." (tp--copy-proper-cons-list value cache) (tp--copy-cons-spine value cache))) ((stringp value) (tp--copy-string-with-properties value cache)) + ((char-table-p value) + (let ((copy (copy-sequence value)) + (default (char-table-range value nil)) + entries) + (puthash value copy cache) + ;; Enumerate only local assignments, without inherited/default + ;; ranges becoming explicit assignments in the copied table. + (set-char-table-parent copy nil) + (set-char-table-range copy nil nil) + (map-char-table (lambda (range item) (push (cons range item) entries)) + copy) + (dolist (entry entries) + (set-char-table-range + copy (car entry) (tp--copy-property-value (cdr entry) cache))) + (set-char-table-range copy nil (tp--copy-property-value default cache)) + (set-char-table-parent + copy (tp--copy-property-value (char-table-parent value) cache)) + (dotimes (index (or (get (char-table-subtype value) + 'char-table-extra-slots) 0)) + (set-char-table-extra-slot + copy index (tp--copy-property-value + (char-table-extra-slot value index) cache))) + copy)) ((vectorp value) (let ((copy (copy-sequence value))) (puthash value copy cache) @@ -431,7 +458,8 @@ and other opaque objects keep their identity; functions are never executed." (defun tp-property-value-copy (value) "Return a defensive copy of mutable text-property VALUE. Functions, records, and other opaque identities are retained; mutable cons, -string, and non-record vector graphs are copied with sharing and cycles intact." +string, character-table and non-record vector graphs are copied with sharing +and cycles intact." (tp--copy-property-value value (make-hash-table :test #'eq))) (defun tp--deep-merge-plist (base new) diff --git a/tp-style.el b/tp-style.el index f180370..9720ab5 100644 --- a/tp-style.el +++ b/tp-style.el @@ -205,12 +205,51 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector." #'tp--merge-face-values (lambda (_old new) new))) +(defun tp--native-keymap-equal-p (left right) + "Compare native snapshots LEFT and RIGHT, retaining commands and menu order." + (let ((seen (make-hash-table :test #'eq))) + (cl-labels + ((bindings (map) + (let ((local (copy-sequence (if (symbolp map) + (indirect-function map) map))) + entries) + (set-keymap-parent local nil) + (map-keymap (lambda (key value) (push (cons key value) entries)) local) + entries)) + (same (old new) + (cond + ((eq old new) t) + ((memq new (gethash old seen)) t) + ((and (keymapp old) (keymapp new)) + (puthash old (cons new (gethash old seen)) seen) + (and (equal-including-properties (keymap-prompt old) + (keymap-prompt new)) + (same (bindings old) (bindings new)) + (same (keymap-parent old) (keymap-parent new)))) + ((or (functionp old) (functionp new)) nil) + ((and (consp old) (consp new)) + (puthash old (cons new (gethash old seen)) seen) + (and (same (car old) (car new)) (same (cdr old) (cdr new)))) + ((and (vectorp old) (vectorp new) (= (length old) (length new))) + (puthash old (cons new (gethash old seen)) seen) + (cl-loop for index below (length old) + always (same (aref old index) (aref new index)))) + (t (equal old new))))) + (same left right)))) + +(defun tp--native-property-value-equal-p (left right) + "Compare native values LEFT and RIGHT while preserving callable identity." + (cond + ((and (keymapp left) (keymapp right)) (tp--native-keymap-equal-p left right)) + ((or (functionp left) (functionp right)) (eq left right)) + (t (equal left right)))) + (defun tp-register-text-property (property) "Register and return a direct policy for Emacs PROPERTY." (let ((id (tp-text-property-id property))) (or (tp-property-policy id) (tp-define-property-policy - id :equality #'equal + id :equality #'tp--native-property-value-equal-p :merge (tp--text-property-merge-function property) :projector (lambda (value) (list property value)))))) diff --git a/tp-surface.el b/tp-surface.el index 0d34439..28e12b2 100644 --- a/tp-surface.el +++ b/tp-surface.el @@ -383,7 +383,7 @@ Each contribution contains `:start', `:end', and direct `:props'." (let ((a (tp-surface-plan-text left)) (b (tp-surface-plan-text right))) (if (and (stringp a) (stringp b)) - (equal-including-properties a b) + (tp--text-property-semantic-equal-p a b) (equal a b))) (tp--plan-props-equal-p (tp-surface-plan-props left) (tp-surface-plan-props right)) @@ -1244,15 +1244,21 @@ When RELATIVE is non-nil, return offsets from the surface start." (when (= (caar new-ranges) (cdar new-ranges)) (pop new-ranges)))) (nreverse pairs))) -(defun tp--text-properties-canonical-at (text position) - "Return TEXT properties at POSITION in deterministic key order." - (sort - (cl-loop for (property value) on (text-properties-at position text) - by #'cddr - collect (cons property value)) - (lambda (left right) - (string< (symbol-name (car left)) - (symbol-name (car right)))))) +(defun tp--mouse-face-groups-equal-p + (left left-start left-end right right-start right-end) + "Compare native hover boundaries in LEFT and RIGHT without comparing identities. +LEFT-START..LEFT-END and RIGHT-START..RIGHT-END delimit equal-length ranges. +Each snapshot may own different face objects, but its contiguous grouping +must agree. Native interval traversal requires no property-value copies." + (let ((match t)) + (while (and match (< left-start left-end)) + (let ((left-next (next-single-property-change + left-start 'mouse-face left left-end)) + (right-next (next-single-property-change + right-start 'mouse-face right right-end))) + (setq match (= (- left-next left-start) (- right-next right-start)) + left-start left-next right-start right-next))) + (and match (= left-start left-end) (= right-start right-end)))) (defun tp--text-property-semantic-equal-p (left right) "Return non-nil when propertized strings LEFT and RIGHT are policy-equal." @@ -1264,14 +1270,16 @@ When RELATIVE is non-nil, return offsets from the surface start." ;; on every scoped update. (and (equal (substring-no-properties left) (substring-no-properties right)) + (tp--mouse-face-groups-equal-p left 0 (length left) + right 0 (length right)) (let ((position 0) (limit (length left)) equal-p) (setq equal-p t) (while (and equal-p (< position limit)) - (unless (equal-including-properties - (tp--text-properties-canonical-at left position) - (tp--text-properties-canonical-at right position)) + (unless (tp--plan-props-equal-p + (text-properties-at position left) + (text-properties-at position right)) (setq equal-p nil)) (setq position (min (or (next-property-change position left limit) limit) @@ -1316,14 +1324,35 @@ outside change." "Compare OLD-RANGES and NEW-RANGES from OLD to NEW. Return scoped replacement metadata, or nil on mismatch." (let* ((old-outside (tp--complement-ranges (length old) old-ranges)) - (new-outside (tp--complement-ranges (length new) new-ranges))) - (let ((old-gap (tp--substring-ranges old old-outside)) - (new-gap (tp--substring-ranges new new-outside))) - (when (or (tp--text-property-semantic-equal-p old-gap new-gap) - (tp--scope-outside-separator-equivalent-p old-gap new-gap)) - (list :patches - (tp--scope-patches-between-anchors - old new (tp--pair-outside-ranges old-outside new-outside))))))) + (new-outside (tp--complement-ranges (length new) new-ranges)) + (anchors (tp--pair-outside-ranges old-outside new-outside)) + previous) + (when + (or + (and (= (cl-loop for (start . end) in old-outside sum (- end start)) + (cl-loop for (start . end) in new-outside sum (- end start))) + (cl-every + (lambda (anchor) + (pcase-let ((`(,old-start ,old-end ,new-start ,new-end) anchor)) + (prog1 + (and + ;; Only real adjacent intervals have a shared hover + ;; boundary. A removed scope must not create one. + (or (null previous) + (/= (nth 1 previous) old-start) + (/= (nth 3 previous) new-start) + (eq (eq (get-text-property (1- old-start) 'mouse-face old) + (get-text-property old-start 'mouse-face old)) + (eq (get-text-property (1- new-start) 'mouse-face new) + (get-text-property new-start 'mouse-face new)))) + (tp--shadow-text-range-equal-p + old old-start old-end new new-start new-end)) + (setq previous anchor)))) + anchors)) + (tp--scope-outside-separator-equivalent-p + (tp--substring-ranges old old-outside) + (tp--substring-ranges new new-outside))) + (list :patches (tp--scope-patches-between-anchors old new anchors))))) (defun tp--prepare-content-scope (surface rendered mount-specs objects options) @@ -1803,11 +1832,6 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'." (let ((cell (plist-member (text-properties-at position buffer) property))) (cons (and cell t) (and cell (cadr cell)))))) -(defun tp--property-state-equal-p (left right) - "Return non-nil when property states LEFT and RIGHT are equal." - (and (eq (car left) (car right)) - (equal (cdr left) (cdr right)))) - (defun tp--property-state-policy-equal-p (property left right) "Return non-nil when PROPERTY states LEFT and RIGHT are policy-equal." (and (eq (car left) (car right)) @@ -2086,9 +2110,13 @@ to the committed projection, as with `tp-object-reuse-subtree'." :reuse-mount-projection-p (and reuse-mount-projection t))) (defun tp--commit-batch-apply-patches (surface batch) - "Apply BATCH's already validated patches to SURFACE." + "Apply BATCH's validated patches to SURFACE, retaining unchanged characters. +The prefix/suffix proof preserves cursor and window anchors in unchanged +text. Properties are still projected over each complete declared patch. +Return the actual (TEXT-OPERATIONS . PROPERTY-OPERATIONS) counts." (let ((buffer (tp--surface-buffer surface)) - (base (marker-position (tp--surface-start surface)))) + (base (marker-position (tp--surface-start surface))) + (text-operations 0) (property-operations 0)) (with-current-buffer buffer (save-restriction (widen) @@ -2096,15 +2124,39 @@ to the committed projection, as with `tp-object-reuse-subtree'." (plist-get (tp--surface-options surface) :inhibit-read-only))) (dolist (patch (reverse (tp-commit-batch-patches batch))) - (let ((start (+ base (plist-get patch :old-start))) - (end (+ base (plist-get patch :old-end))) - (replacement (plist-get patch :replacement))) - (delete-region start end) - (goto-char start) - (insert replacement)))))) + (let* ((start (+ base (plist-get patch :old-start))) + (end (+ base (plist-get patch :old-end))) + (replacement (plist-get patch :replacement)) + (old (buffer-substring-no-properties start end)) + (prefix (tp--common-prefix-length old replacement)) + (suffix (tp--common-suffix-length old replacement prefix))) + (unless (and (= prefix (length old)) + (= prefix (length replacement))) + (delete-region (+ start prefix) (- end suffix)) + (goto-char (+ start prefix)) + (let ((inserted (substring replacement prefix + (- (length replacement) suffix)))) + (insert inserted) + (cl-incf text-operations) + (unless (tp--validate-published-content-range + buffer (+ start prefix) inserted) + (signal 'tp-publication-mismatch + (list :commit-patch patch))))) + ;; Keep undo recording for the standalone public batch API as + ;; well as transaction publication. Host property hooks are + ;; inhibited just as in the ordinary content-property writer. + (let ((inhibit-modification-hooks t)) + (dolist (operation + (tp--content-property-operations-in-range + buffer start replacement 0 (length replacement))) + (set-text-properties (plist-get operation :start) + (plist-get operation :end) + (plist-get operation :props)) + (cl-incf property-operations)))))))) (set-marker (tp--surface-start surface) base buffer) (set-marker (tp--surface-end surface) - (+ base (tp-commit-batch-target-extent batch)) buffer))) + (+ base (tp-commit-batch-target-extent batch)) buffer) + (cons text-operations property-operations))) (defun tp--commit-batch-validate-buffer (surface batch) "Validate BATCH's published extent and changed spans on SURFACE." @@ -2119,7 +2171,7 @@ to the committed projection, as with `tp-object-reuse-subtree'." (let ((start (+ base (plist-get patch :new-start))) (end (+ base (plist-get patch :new-end))) (replacement (plist-get patch :replacement))) - (unless (equal-including-properties + (unless (tp--text-property-semantic-equal-p (with-current-buffer buffer (buffer-substring start end)) replacement) (signal 'tp-publication-mismatch @@ -2153,12 +2205,23 @@ to the committed projection, as with `tp-object-reuse-subtree'." (old-revision (tp--surface-revision surface)) (old-client-state (tp--surface-client-state surface)) (old-report (tp--surface-report surface)) + (journals + (with-current-buffer buffer + (save-restriction + (widen) + (let ((base (marker-position (tp--surface-start surface)))) + (mapcar + (lambda (patch) + (let ((start (+ base (plist-get patch :old-start))) + (end (+ base (plist-get patch :old-end)))) + (list buffer start end (buffer-substring start end)))) + (tp-commit-batch-patches batch)))))) (views (tp--capture-view-state (list buffer))) (group (tp--prepare-change-group-for-buffers (list buffer))) - success) + counts success) (unwind-protect (progn - (tp--commit-batch-apply-patches surface batch) + (setq counts (tp--commit-batch-apply-patches surface batch)) (tp--commit-batch-validate-buffer surface batch) (tp--commit-batch-validate-mounts surface batch (tp--surface-mounts surface)) @@ -2171,14 +2234,15 @@ to the committed projection, as with `tp-object-reuse-subtree'." :surface-id (tp--surface-id surface) :old-revision old-revision :new-revision (tp-commit-batch-target-revision batch) - :text-operations (length (tp-commit-batch-patches batch)) - :property-operations 0 :commit-batch t + :text-operations (car counts) + :property-operations (cdr counts) :commit-batch t :rolled-back nil :failure nil)) (accept-change-group group) (setq success t) (tp-surface-report surface)) (unless success (tp--cancel-change-group-safely group) + (tp--restore-property-journals journals) (setf (tp--surface-client-state surface) old-client-state (tp--surface-revision surface) old-revision (tp--surface-report surface) old-report)) @@ -2620,7 +2684,7 @@ same mount record twice. Queue spines are private; no mount IDs are allocated." (with-current-buffer (tp--surface-buffer surface) (save-restriction (widen) - (equal-including-properties + (tp--text-property-semantic-equal-p (buffer-substring start end) (tp--prepared-surface-rendered prepared)))))))) @@ -2628,6 +2692,10 @@ same mount record twice. Queue spines are private; no mount IDs are allocated." "Return non-nil when PREPARED differs from its committed surface." (let ((surface (tp--prepared-surface-surface prepared))) (or (tp--prepared-surface-initial prepared) + ;; An authenticated batch explicitly advances the revision, including + ;; an empty batch. Preparation already checked its base and topology; + ;; its retained plan is not a new candidate to compare recursively. + (tp--prepared-surface-commit-batch prepared) (not (tp--plan-equal-p (tp--surface-plan surface) (tp--prepared-surface-plan prepared))) (not (equal (tp--surface-client-state surface) @@ -2696,7 +2764,7 @@ the transaction can commit." (substring-no-properties rendered))) (signal 'tp-publication-mismatch (list :buffer buffer :start start :end end))) - (equal-including-properties + (tp--text-property-semantic-equal-p (buffer-substring start end) rendered)))) (defun tp--content-text-operation (surface rendered) @@ -2732,8 +2800,68 @@ character makes a large rendered surface quadratic in its number of runs." (or (not (tp--plan-props-equal-p (text-properties-at buffer-start buffer) (text-properties-at from rendered))) + ;; Unlike ordinary face paint, native mouse-face boundaries are + ;; defined by identity. Every published run must use the candidate + ;; group's exact value, even when its face attributes compare equal. + (not (eq (get-text-property buffer-start 'mouse-face buffer) + (get-text-property from 'mouse-face rendered))) (< buffer-next buffer-end)))) +(defun tp--align-scoped-mouse-face-groups! (buffer base rendered ranges) + "Preserve native hover identities crossing scoped RANGES in RENDERED. +BUFFER at BASE already has the candidate characters. An unchanged outside +gap authenticates the existing identity for its whole contiguous candidate +group. Separate groups are never interned by paint value. If outside gaps +disagree on identity, the requested scope cannot publish that group change." + (let ((seen (make-hash-table :test #'eql)) + (limit (length rendered))) + (dolist (range ranges) + (let ((position (car range))) + (while (< position (cdr range)) + (let* ((value (get-text-property position 'mouse-face rendered)) + (end (next-single-property-change + position 'mouse-face rendered limit)) + (start (previous-single-property-change + (1+ position) 'mouse-face rendered 0))) + (when (and value (not (gethash start seen))) + (puthash start t seen) + (let ((outside (tp--subtract-ranges (list (cons start end)) ranges)) + identity found) + (dolist (gap outside) + (let ((cursor (+ base (car gap))) + (stop (+ base (cdr gap)))) + (while (< cursor stop) + (let ((actual (get-text-property cursor 'mouse-face buffer))) + (unless (and (tp--property-value-equal-p + 'mouse-face value actual) + (or (not found) (eq identity actual))) + (signal 'tp-scope-mismatch + (list :mouse-face-group start end))) + (setq identity actual found t + cursor (next-single-property-change + cursor 'mouse-face buffer stop)))))) + (when found + ;; Reusing the outside identity must not silently erase a + ;; candidate boundary against another unchanged group. + (dolist (neighbor (list (1- start) end)) + (when (and (<= 0 neighbor) (< neighbor limit) + (not (tp--range-contained-in-p + neighbor (1+ neighbor) ranges)) + (eq identity + (get-text-property (+ base neighbor) + 'mouse-face buffer))) + (signal 'tp-scope-mismatch + (list :mouse-face-boundary start end)))) + (unless (eq identity value) + (put-text-property start end 'mouse-face identity rendered) + ;; Inserted text was validated before this ownership + ;; alignment. Reapply its properties too when its native + ;; group now adopts an unchanged outside identity. + (setq tp--content-published-ranges + (tp--subtract-ranges tp--content-published-ranges + (list (cons start end)))))))) + (setq position end))))))) + (defun tp--content-property-operations-in-range (buffer start rendered from to) "Return property operations for RENDERED FROM..TO at BUFFER position START." @@ -2756,6 +2884,9 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set." (let* ((buffer (tp--surface-buffer surface)) (start (marker-position (tp--surface-start surface))) (ranges (if scoped ranges (list (cons 0 (length rendered))))) + (_hover-groups + (when scoped + (tp--align-scoped-mouse-face-groups! buffer start rendered ranges))) (ranges (if tp--content-published-ranges (tp--subtract-ranges @@ -3027,7 +3158,7 @@ the generic property-operation ledger." (range (tp--surface-range surface)) (start (car range)) (end (cdr range)) - (changed (not (equal-including-properties + (changed (not (tp--text-property-semantic-equal-p (with-current-buffer buffer (buffer-substring start end)) rendered)))) @@ -3054,13 +3185,12 @@ the generic property-operation ledger." "Publish PREPARED's text and properties, returning operation counts." (cl-block publish (when-let* ((batch (tp--prepared-surface-commit-batch prepared))) - (let ((surface (tp--prepared-surface-surface prepared))) - (tp--commit-batch-apply-patches surface batch) + (let* ((surface (tp--prepared-surface-surface prepared)) + (counts (tp--commit-batch-apply-patches surface batch))) (tp--publication-step 'text surface) (tp--commit-batch-validate-buffer surface batch) (tp--publication-step 'property surface) - (cl-return-from publish - (cons (length (tp-commit-batch-patches batch)) 0)))) + (cl-return-from publish counts))) (let* ((surface (tp--prepared-surface-surface prepared)) (buffer (tp--surface-buffer surface)) (rendered (tp--prepared-surface-rendered prepared)) @@ -3469,6 +3599,152 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (push (substring string cursor) pieces) (apply #'concat (nreverse pieces)))))) +(cl-defstruct (tp--shadow-batch-output + (:constructor tp--make-shadow-batch-output)) + "Detached patch evidence over the unchanged output of a retained surface." + base patches extent) + +(defun tp--shadow-batch-output-create (base batch) + "Snapshot BASE and BATCH's output evidence without rebuilding the target. +BASE is the already captured buffer string. Patch strings and coordinates +are detached before publication, so changing a staged patch cannot change +the expected output. Native callback identities survive the snapshot." + (tp--make-shadow-batch-output + :base base :extent (tp-commit-batch-target-extent batch) + :patches + (mapcar + (lambda (patch) + (list :old-start (plist-get patch :old-start) + :old-end (plist-get patch :old-end) + :new-start (plist-get patch :new-start) + :new-end (plist-get patch :new-end) + :mouse-face-first + (let ((text (plist-get patch :replacement))) + (and (> (length text) 0) (get-text-property 0 'mouse-face text))) + :mouse-face-last + (let ((text (plist-get patch :replacement))) + (and (> (length text) 0) + (get-text-property (1- (length text)) 'mouse-face text))) + :replacement + (tp-property-value-copy (plist-get patch :replacement)))) + (tp-commit-batch-patches batch)))) + +(defun tp--shadow-props-identical-p (left right) + "Return non-nil when property lists LEFT and RIGHT have identical values. +An identity match is sufficient proof even for opaque native callbacks. +Different order or copied values require the ordinary policy comparison." + (while (and left right (eq (car left) (car right)) + (eq (cadr left) (cadr right))) + (setq left (cddr left) right (cddr right))) + (and (null left) (null right))) + +(defvar tp--shadow-output-reusable-p nil + "Non-nil while a live output proof has used only identity or pure policies. +Custom equality functions may retain or mutate their arguments without +changing the buffer tick, so their proofs need a separate actual snapshot.") + +(defun tp--shadow-text-range-equal-p + (left left-start left-end right right-start right-end) + "Compare LEFT from LEFT-START to LEFT-END with RIGHT's corresponding range. +RIGHT-START and RIGHT-END delimit that range in the RIGHT string or buffer. +Unchanged runs use property identity as a proof; changed identities still +use the same native-property policies as ordinary publication." + (and (= (- left-end left-start) (- right-end right-start)) + (eq t (if (bufferp right) + (compare-strings + left left-start left-end + (with-current-buffer right + (buffer-substring-no-properties right-start right-end)) + 0 nil) + (compare-strings left left-start left-end + right right-start right-end))) + (tp--mouse-face-groups-equal-p + left left-start left-end right right-start right-end) + (let ((equal-p t)) + (while (and equal-p (< left-start left-end)) + (let ((left-props (text-properties-at left-start left)) + (right-props (text-properties-at right-start right))) + (unless (or (tp--shadow-props-identical-p left-props right-props) + (progn + (when tp--shadow-output-reusable-p + (setq tp--shadow-output-reusable-p + (cl-loop for (property _value) on left-props by #'cddr + always + (memq (tp-property-policy-equality + (tp-register-text-property property)) + '(eq equal tp--native-property-value-equal-p))))) + (tp--plan-props-equal-p left-props right-props))) + (setq equal-p nil))) + (let ((step + (min (- (next-property-change left-start left left-end) + left-start) + (- (next-property-change right-start right right-end) + right-start)))) + (setq left-start (+ left-start step) + right-start (+ right-start step)))) + equal-p))) + +(defun tp--shadow-batch-output-equal-p + (expected actual &optional actual-start actual-end groups-only) + "Prove ACTUAL equals EXPECTED's patches and every unchanged outside gap. +This checks the whole output, including hostile writes made with hooks or +undo recording inhibited. Only construction of a second full output and +semantic comparison of identical property values are avoided. +ACTUAL may be a buffer delimited by ACTUAL-START and ACTUAL-END. +With GROUPS-ONLY, compare only native hover topology. This shares the same +segment and seam evidence with precommit validation without copying output." + (setq actual-start (or actual-start 0) + actual-end (or actual-end (and (stringp actual) (length actual)))) + (and (or (stringp actual) (buffer-live-p actual)) + actual-end + (= (- actual-end actual-start) (tp--shadow-batch-output-extent expected)) + (let ((base (tp--shadow-batch-output-base expected)) + (patches (tp--shadow-batch-output-patches expected)) + (old-position 0) (new-position 0) (equal-p t) + previous-face have-previous) + (cl-labels + ((segment-equal-p + (source from to target-start target-end first-face last-face) + (setq target-start (+ actual-start target-start) + target-end (+ actual-start target-end)) + (and + (or (= from to) + (prog1 + (or (not have-previous) + (eq (eq previous-face first-face) + (eq (get-text-property (1- target-start) + 'mouse-face actual) + (get-text-property target-start + 'mouse-face actual)))) + (setq previous-face last-face have-previous t))) + (if groups-only + (tp--mouse-face-groups-equal-p + source from to actual target-start target-end) + (tp--shadow-text-range-equal-p + source from to actual target-start target-end)))) + (base-equal-p (from to target-start target-end) + (segment-equal-p + base from to target-start target-end + (and (< from to) (get-text-property from 'mouse-face base)) + (and (< from to) (get-text-property (1- to) 'mouse-face base))))) + (while (and equal-p patches) + (let* ((patch (pop patches)) + (old-start (plist-get patch :old-start)) + (new-start (plist-get patch :new-start)) + (replacement (plist-get patch :replacement))) + (setq equal-p + (and (base-equal-p old-position old-start new-position new-start) + (segment-equal-p + replacement 0 (length replacement) + new-start (plist-get patch :new-end) + (plist-get patch :mouse-face-first) + (plist-get patch :mouse-face-last)))) + (setq old-position (plist-get patch :old-end) + new-position (plist-get patch :new-end)))) + (and equal-p + (base-equal-p old-position (length base) + new-position (- actual-end actual-start))))))) + (defun tp--shadow-apply-property-operations-to-string (string base operations) "Return STRING with absolute property OPERATIONS rebased from BASE." @@ -3494,7 +3770,9 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (let ((surface (tp--prepared-surface-surface prepared))) (if (eq (tp--surface-capability surface) 'content) (if-let* ((batch (tp--prepared-surface-commit-batch prepared))) - (tp--shadow-apply-commit-batch-to-string old-output batch) + (if (tp--prepared-surface-retained-mount-state-p prepared) + (tp--shadow-batch-output-create old-output batch) + (tp--shadow-apply-commit-batch-to-string old-output batch)) (copy-sequence (tp--prepared-surface-rendered prepared))) (pcase-let ((`(,start . ,_end) (tp--surface-range surface))) (tp--shadow-apply-property-operations-to-string @@ -3520,11 +3798,21 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (equal (plist-get expected :mounts) (plist-get actual :mounts)) (equal (plist-get expected :ledger) (plist-get actual :ledger)) (= (plist-get expected :point) (plist-get actual :point)) - (equal-including-properties - (plist-get expected :output) (plist-get actual :output)))) + (let ((output (plist-get expected :output))) + (if (tp--shadow-batch-output-p output) + (or (eq output (plist-get actual :output)) + (tp--shadow-batch-output-equal-p output (plist-get actual :output))) + (tp--text-property-semantic-equal-p + output (plist-get actual :output)))))) -(defun tp--shadow-current-artifact (surface) - "Return a normalized read-only artifact for current SURFACE state." +(defun tp--shadow-current-artifact (surface &optional expected-output) + "Return a normalized read-only artifact for current SURFACE state. +When EXPECTED-OUTPUT is retained patch evidence, first compare all live text +and properties with it. A successful proof can use that immutable output as +its policy-equivalent representation, avoiding another full property copy. +The buffer tick must stay unchanged and no custom equality may run: custom +policies can retain mutable evidence without changing that tick. A failed, +custom, or unstable comparison keeps an independent snapshot for diagnostics." (list :buffer (tp--surface-buffer surface) :revision (tp--surface-revision surface) :plan (tp--surface-plan surface) @@ -3534,7 +3822,18 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." :mounts (tp--live-mount-signature surface) :ledger (tp--shadow-live-ledger-signature (tp--surface-ledger surface)) :point (with-current-buffer (tp--surface-buffer surface) (point)) - :output (tp--shadow-surface-output surface))) + :output + (if (and (tp--shadow-batch-output-p expected-output) + (with-current-buffer (tp--surface-buffer surface) + (pcase-let ((`(,start . ,end) (tp--surface-range surface)) + (tick (buffer-modified-tick)) + (tp--shadow-output-reusable-p t)) + (and (tp--shadow-batch-output-equal-p + expected-output (current-buffer) start end) + tp--shadow-output-reusable-p + (= tick (buffer-modified-tick)))))) + expected-output + (tp--shadow-surface-output surface)))) (defun tp--surface-shadow-target-entry (prepared snapshot journals views batch-id mapping-generation) @@ -3596,7 +3895,10 @@ batch, or nil when publication does not use a commit batch." (if (eq phase 'commit) :commit :rollback))) - (actual (tp--shadow-current-artifact surface))) + (actual + (if (tp--shadow-batch-output-p (plist-get target :output)) + (tp--shadow-current-artifact surface (plist-get target :output)) + (tp--shadow-current-artifact surface)))) (list :equivalent (tp--shadow-artifact-equal-p target actual) :surface-id (tp--surface-id surface) :expected target :actual actual))))) @@ -3699,7 +4001,10 @@ batch, or nil when publication does not use a commit batch." (= (tp-commit-batch-base-extent commit-batch) (length (plist-get rollback-expected :output))) (= (tp-commit-batch-target-extent commit-batch) - (length (plist-get commit-expected :output))))) + (let ((output (plist-get commit-expected :output))) + (if (tp--shadow-batch-output-p output) + (tp--shadow-batch-output-extent output) + (length output)))))) (= (tp-publication-target-entry-mapping-generation entry) tp--surface-transaction-id)) (signal 'tp-publication-binding-error @@ -3813,6 +4118,25 @@ batch, or nil when publication does not use a commit batch." (list :invalid-retained-batch-precommit (tp--surface-id surface)))))) +(defun tp--validate-retained-batch-hover-groups () + "Reject native hover regrouping in retained publication before acceptance. +Use the authenticated detached patch evidence and live interval boundaries. +Ordinary publication and the full postcommit shadow remain diagnostic." + (when tp--transaction-publication-batch + (dolist (entry (tp-publication-batch-candidate-entries + tp--transaction-publication-batch)) + (let* ((expected (tp-publication-target-entry-shadow-expected entry)) + (output (plist-get (plist-get expected :commit) :output))) + (when (tp--shadow-batch-output-p output) + (let* ((prepared (aref (tp-publication-target-entry-rollback-snapshot entry) 0)) + (surface (tp--prepared-surface-surface prepared)) + (range (tp--surface-range surface))) + (unless (tp--shadow-batch-output-equal-p + output (tp--surface-buffer surface) (car range) (cdr range) t) + (signal 'tp-scope-mismatch + (list :surface (tp--surface-id surface) + :reason 'retained-hover-group-boundaries))))))))) + (defun tp--validate-surface-precommit (state) "Validate final published semantics and rollback ownership in STATE." (unless (and (gethash 'change-group state) @@ -3911,6 +4235,7 @@ batch, or nil when publication does not use a commit batch." (when (tp--surface-mount-anchor mount) (signal 'tp-surface-error (list :invalid-content-anchor mount))))))))) + (tp--validate-retained-batch-hover-groups) state)) (defun tp--surface-prevalidate-cleanup (state) @@ -3942,6 +4267,9 @@ batch, or nil when publication does not use a commit batch." "Accept the active surface transaction's prepared change group." (when-let* ((state (tp--transaction-extension tp--surface-extension-key))) (when-let* ((group (gethash 'change-group state))) + ;; Lifecycle and cleanup callbacks run after precommit validation. + ;; A second boundary-only check also covers those unrecorded writes. + (tp--validate-retained-batch-hover-groups) (accept-change-group group)))) (defun tp--surface-precommit-transaction () @@ -4011,6 +4339,39 @@ batch, or nil when publication does not use a commit batch." (tp--surface-publishing t)) (cancel-change-group group)))) +(defun tp--restore-retained-batch-output () + "Restore retained output after cancellation, including unrecorded writes. +The old output already belongs to the publication entry. Replaying it only +on rollback restores native group identities even when a host disabled undo." + (when tp--transaction-publication-batch + (dolist (entry (tp-publication-batch-candidate-entries + tp--transaction-publication-batch)) + (let* ((expected (tp-publication-target-entry-shadow-expected entry)) + (output (plist-get (plist-get expected :commit) :output))) + (when (tp--shadow-batch-output-p output) + (let* ((prepared (aref (tp-publication-target-entry-rollback-snapshot entry) 0)) + (surface (tp--prepared-surface-surface prepared)) + (buffer (tp--surface-buffer surface)) + (old (tp--shadow-batch-output-base output))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-restriction + (widen) + (pcase-let* ((`(,start . ,end) (tp--surface-range surface)) + (plain (buffer-substring-no-properties start end)) + (prefix (tp--common-prefix-length plain old)) + (suffix (tp--common-suffix-length plain old prefix)) + (inhibit-read-only t) + (inhibit-modification-hooks t) + (buffer-undo-list t)) + (unless (equal plain (substring-no-properties old)) + (delete-region (+ start prefix) (- end suffix)) + (goto-char (+ start prefix)) + (insert (substring old prefix (- (length old) suffix)))) + (set-marker (tp--surface-start surface) start) + (set-marker (tp--surface-end surface) (+ start (length old))) + (tp--replay-string-properties buffer start old))))))))))) + (defun tp--surface-rollback-transaction () "Rollback buffers, side state, markers, and contexts for this transaction." (when-let* ((state (tp--transaction-extension tp--surface-extension-key))) @@ -4029,6 +4390,7 @@ batch, or nil when publication does not use a commit batch." (lambda () (tp--restore-property-journals (gethash 'journals state)))) + (attempt 'retained-output #'tp--restore-retained-batch-output) (dolist (entry (gethash 'snapshots state)) (attempt (list 'surface @@ -4290,7 +4652,7 @@ batch, or nil when publication does not use a commit batch." (let* ((next (with-current-buffer buffer (next-single-property-change start property buffer end))) (current (tp--property-state-at buffer start property))) - (if (tp--property-state-equal-p current published) + (if (tp--property-state-policy-equal-p property current published) (push (list :start start :end next :property property :present (tp--property-ledger-baseline-present entry) :value (tp--property-ledger-baseline-value entry))