Harden TP transactions and preserve point

README.md

@@ -146,6 +146,15 @@ TP records the host baseline and each TP contribution per property interval. Ove
 
 Observers run only after a successful commit. Their failures are recorded and do not roll back an already committed transaction. A buffer killed during publication remains killed; rollback never recreates it.
 
+ETAF integration uses the same boundary through one opaque transaction
+participant. ETAF prepares its immutable generation and Ebox candidate before
+TP accepts the transaction; participant publish, TP final accept, and
+post-accept cleanup are ordered explicitly. A participant failure restores the
+previous generation and client state, while a post-accept observer failure is
+contained as a diagnostic. ETAF's runtime fixed-point guard records each
+effect's input/version tuple for one flush and stops repeated or over-bound
+cycles instead of spinning.
+
 ## Property policies
 
 `tp-define-property-policy` registers generic semantics for a final Emacs text property:

README_CN.md

@@ -145,6 +145,13 @@ TP 为每个 property interval 保存 host baseline 和各个 TP contribution。
 
 observer 只在成功提交之后运行，observer failure 只记录，不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡，rollback 不会把它重新创建。
 
+ETAF 集成复用同一事务边界，只注册一个 opaque transaction participant。ETAF
+先准备 immutable generation 和 Ebox candidate，再由 TP 按固定顺序完成
+participant publish、TP final accept 和 post-accept cleanup。participant failure
+会恢复旧 generation 与 client state；accept 之后的 observer failure 只保留为
+diagnostic。ETAF 的 Runtime fixed-point guard 会在一次 flush 中记录每个
+effect 的 input/version tuple，重复或超过图规模上限时停止循环，不会静默自旋。
+
 ## Property policy
 
 `tp-define-property-policy` 为一个最终 Emacs text property 注册通用语义：

docs/API-REFERENCE.md

@@ -244,6 +244,11 @@ publish 在 surface publication 后、source commit 前运行，失败时按逆
 rollback。tp-variable-signal 用 Emacs variable watcher 适配全局或指定
 Buffer 的变量，不是旧的 $variable API。
 
+ETAF registers one opaque participant for its immutable generation and Ebox
+client state. Its publish is paired with rollback across TP final accept; the
+ETAF runtime separately records effect input/version tuples and reports a
+bounded non-converging flush instead of spinning.
+
 ## 6. Retained surface
 
 ### 6.1 Plan、result 和 object

docs/API-SEMANTICS.md

@@ -204,6 +204,13 @@ TP 为每个 interval 保存：
 
 `tp-transaction-participate` 允许 client side state 在 surfaces 发布后、source commit 前加入同一 rollback boundary。participant key 在一个 outer transaction 中必须唯一。它不是 observer；失败会回滚 transaction。Observer failure 只记录，不回滚已提交结果。
 
+ETAF uses this API with one opaque participant for its immutable generation and
+Ebox client state. The participant is published only after candidate
+preparation, and its paired rollback is still required when TP final accept
+fails. This keeps ETAF generation visibility, Ebox publication, signals, and
+client state on one commit boundary; ETAF's own flush guard is responsible for
+detecting repeated input/version tuples and bounded non-convergence.
+
 ## 12. Diagnostics 与 reports
 
 `tp-surface-report` 返回最近一次成功 publication 的防御性 report；equal/no-op update 不替换 report。字段包括 transaction/surface/revision、candidate source writes、binding counters、object reconcile counts、text/property operation counts、touched characters、scope/full-root 和 failure-related slots。

docs/ARCHITECTURE.md

@@ -200,6 +200,17 @@ Rollback restores text, properties, marker/index state, plans, producer, client
 
 If publication kills a target buffer, kill teardown is authoritative. Other surfaces and source state roll back; TP never recreates the killed buffer.
 
+### ETAF participant contract
+
+ETAF is a consumer of this public boundary, not a second TP runtime. It stages
+an immutable semantic generation and an Ebox candidate, then registers one
+opaque participant. The participant publishes the generation only after TP
+preparation succeeds; TP final accept is the last fallible operation. Failure
+restores the old generation, client state, and Ebox publication together.
+ETAF's outer flush records effect input/version tuples and applies a graph-size
+derived step bound, so a repeated tuple or monotonic cycle becomes a
+diagnostic instead of an unbounded dispatch.
+
 ## 12. Lifecycle
 
 Surfaces are buffer-local lifecycle owners. A weak global registry supports lookup without keeping dead buffers alive. Mount installs local change/kill hooks; unmount and kill remove hooks, markers, ledger entries, objects, bindings, subscriptions, indexes, client state and weak registrations.

tests/tp-binding-tests.el

@@ -14,6 +14,56 @@
 (defvar tp-binding-test-variable nil
   "Variable used by scoped signal adapter tests.")
 
+(define-error 'tp-binding-test-primary "TP binding test primary failure")
+
+(defvar tp-binding-test-transaction-trace nil
+  "Dynamic transaction phase trace used by rollback tests.")
+
+(defvar tp-binding-test-precommit-condition nil
+  "Condition signaled by the test precommit hook, or nil.")
+
+(defvar tp-binding-test-final-accept-function nil
+  "Test final-accept function installed by the test precommit hook.")
+
+(defun tp--binding-test-precommit-inject ()
+  "Record precommit and signal `tp-binding-test-precommit-condition'."
+  (push 'precommit tp-binding-test-transaction-trace)
+  (when tp-binding-test-final-accept-function
+    (tp--transaction-install-final-accept
+     tp-binding-test-final-accept-function))
+  (when tp-binding-test-precommit-condition
+    (signal (car tp-binding-test-precommit-condition)
+            (cdr tp-binding-test-precommit-condition))))
+
+(defun tp--binding-test-foreign-precommit ()
+  "Represent an undeclared private-looking foreign precommit function."
+  nil)
+
+(defun tp-binding-test--rollback-hook-fail ()
+  "Record rollback hook failure and signal it."
+  (push 'rollback-hook-fail tp-binding-test-transaction-trace)
+  (error "Rollback hook failure"))
+
+(defun tp-binding-test--rollback-hook-after ()
+  "Record the rollback hook following a failed hook."
+  (push 'rollback-hook-after tp-binding-test-transaction-trace))
+
+(defun tp-binding-test--rollback-final-fail ()
+  "Record rollback-final failure and signal it."
+  (push 'rollback-final-fail tp-binding-test-transaction-trace)
+  (error "Rollback final failure"))
+
+(defun tp-binding-test--rollback-final-after ()
+  "Record the rollback-final hook following a failed hook."
+  (push 'rollback-final-after tp-binding-test-transaction-trace))
+
+(defun tp-binding-test--capture-condition (function)
+  "Call FUNCTION and return its signaled error or quit condition."
+  (condition-case condition
+      (progn (funcall function) nil)
+    (error condition)
+    (quit condition)))
+
 (defmacro tp-binding-test--isolated (&rest body)
   "Run BODY with an isolated reactive runtime."
   (declare (indent 0) (debug t))
@@ -110,6 +160,340 @@
       (should (= calls 2))
       (should (= (plist-get (tp-reactive-counters) :recomputed) 1)))))
 
+(ert-deftest tp-binding-test-transaction-commits-signals-in-first-touch-order ()
+  "Touched signals commit once in first-touch order, including net reverts."
+  (tp-binding-test--isolated
+    (let* ((first (tp-signal-create 0))
+           (second (tp-signal-create 0))
+           (third (tp-signal-create 0))
+           (original (symbol-function 'tp--commit-signal-entry))
+           commit-order final-accept-order (final-accept-count 0))
+      (cl-letf (((symbol-function 'tp--commit-signal-entry)
+                 (lambda (entry)
+                   (push (tp-signal-id
+                          (tp--signal-commit-entry-signal entry))
+                         commit-order)
+                   (funcall original entry)))
+                ((symbol-function 'tp--transaction-noop-final-accept)
+                 (lambda ()
+                   (cl-incf final-accept-count)
+                   (setq final-accept-order
+                         (mapcar
+                          (lambda (entry)
+                            (tp-signal-id
+                             (tp--signal-commit-entry-signal entry)))
+                          tp--transaction-signal-commit-journal)))))
+        (tp-with-transaction
+          (tp-signal-set second 1)
+          (tp-with-transaction
+            (tp-signal-set first 1)
+            (tp-signal-set second 0))
+          (tp-signal-set third 3)))
+      (setq commit-order (nreverse commit-order))
+      (should (equal commit-order
+                     (mapcar #'tp-signal-id (list second first third))))
+      (should (equal final-accept-order commit-order))
+      (should (= final-accept-count 1))
+      (should (= (tp-signal-peek first) 1))
+      (should (= (tp-signal-peek second) 0))
+      (should (= (tp-signal-peek third) 3))
+      (dolist (signal (list first second third))
+        (should (= (tp-signal-revision signal) 1))))))
+
+(ert-deftest tp-binding-test-signal-commit-journal-rolls-back-every-write ()
+  "Every signal-write injection restores values, revisions, and bindings."
+  (tp-binding-test--isolated
+    (dolist (fail-after '(0 1 2 3))
+      (let* ((first (tp-signal-create 1))
+             (second (tp-signal-create 2))
+             (third (tp-signal-create 3))
+             (binding
+              (tp-bind (list 'owner fail-after) '(test . sum)
+                       (lambda ()
+                         (+ (tp-signal-read first)
+                            (tp-signal-read second)
+                            (tp-signal-read third)))))
+             (binding-revision (tp-binding-revision binding))
+             (original (symbol-function 'tp--commit-signal-entry))
+             (writes 0))
+        (cl-letf (((symbol-function 'tp--commit-signal-entry)
+                   (lambda (entry)
+                     (when (and (zerop fail-after) (zerop writes))
+                       (error "Before first signal write"))
+                     (funcall original entry)
+                     (cl-incf writes)
+                     (when (= writes fail-after)
+                       (error "After signal write %d" writes)))))
+          (should-error
+           (tp-with-transaction
+             (tp-signal-set first 10)
+             (tp-signal-set second 20)
+             (tp-signal-set third 30))))
+        (should (equal (mapcar #'tp-signal-peek (list first second third))
+                       '(1 2 3)))
+        (should (equal (mapcar #'tp-signal-revision
+                               (list first second third))
+                       '(0 0 0)))
+        (should (= (tp-binding-read binding) 6))
+        (should (= (tp-binding-revision binding) binding-revision))
+        (should (= (tp-binding-dependency-count binding) 3))
+        (dolist (signal (list first second third))
+          (should (= (tp-signal-subscriber-count signal) 1)))
+        (tp-with-transaction
+          (tp-signal-set first 10)
+          (tp-signal-set second 20)
+          (tp-signal-set third 30))
+        (should (equal (mapcar #'tp-signal-peek (list first second third))
+                       '(10 20 30)))
+        (should (equal (mapcar #'tp-signal-revision
+                               (list first second third))
+                       '(1 1 1)))
+        (should (= (tp-binding-read binding) 60))))))
+
+(ert-deftest tp-binding-test-precommit-and-final-accept-failures-roll-back ()
+  "Precommit and final-accept error or quit restores pure reactive state."
+  (tp-binding-test--isolated
+    (dolist (phase '(precommit final-accept))
+      (dolist (condition '((error "Injected error") (quit)))
+        (let* ((signal (tp-signal-create 1))
+               observed-final
+               (tp--transaction-precommit-functions
+                '(tp--binding-test-precommit-inject))
+               (tp--transaction-precommit-allowed-functions
+                '(tp--binding-test-precommit-inject))
+               (tp-binding-test-precommit-condition
+                (and (eq phase 'precommit) condition))
+               (tp-binding-test-final-accept-function
+                (and (eq phase 'final-accept)
+                     (lambda ()
+                       (setq observed-final
+                             (list (tp-signal-committed-value signal)
+                                   (tp-signal-revision signal)))
+                       (signal (car condition) (cdr condition))))))
+          (let ((failure
+                 (tp-binding-test--capture-condition
+                  (lambda ()
+                    (tp-with-transaction (tp-signal-set signal 2))))))
+            (should (eq (car failure) (car condition))))
+          (when (eq phase 'final-accept)
+            (should (equal observed-final '(2 1))))
+          (should (= (tp-signal-peek signal) 1))
+          (should (= (tp-signal-revision signal) 0))
+          (setq tp--transaction-precommit-functions nil
+                tp-binding-test-precommit-condition nil
+                tp-binding-test-final-accept-function nil)
+          (tp-signal-set signal 2)
+          (should (= (tp-signal-peek signal) 2))
+          (should (= (tp-signal-revision signal) 1)))))))
+
+(ert-deftest tp-binding-test-final-accept-pending-quit-is-contained ()
+  "Clear final-accept pending quit before committed and after-commit actions."
+  (tp-binding-test--isolated
+    (let ((signal (tp-signal-create 1)) after-ran
+          (tp--transaction-precommit-functions
+           '(tp--binding-test-precommit-inject))
+          (tp--transaction-precommit-allowed-functions
+           '(tp--binding-test-precommit-inject))
+          (tp-binding-test-final-accept-function
+           (lambda () (setq quit-flag t))))
+      (tp-with-transaction
+        (tp-signal-set signal 2)
+        (tp--enqueue-after-commit (lambda () (setq after-ran t))))
+      (should (= 2 (tp-signal-peek signal)))
+      (should after-ran)
+      (should (eq 'final-accept
+                  (caar tp--last-transaction-diagnostics))))))
+
+(ert-deftest tp-binding-test-precommit-registry-rejects-foreign-functions ()
+  "Only declared TP-internal symbols may enter the precommit registry."
+  (tp-binding-test--isolated
+    (let ((tp--transaction-precommit-functions nil)
+          (tp--transaction-precommit-allowed-functions
+           '(tp--binding-test-precommit-inject)))
+      (tp--transaction-register-precommit-function
+       'tp--binding-test-precommit-inject)
+      (should (equal tp--transaction-precommit-functions
+                     '(tp--binding-test-precommit-inject)))
+      (should-error
+       (tp--transaction-register-precommit-function
+        'tp--binding-test-foreign-precommit)
+       :type 'tp-reactive-error)
+      (dolist (foreign
+               (list 'ignore 'tp--binding-test-foreign-precommit
+                     (lambda () nil)))
+        (let ((signal (tp-signal-create 1))
+              (tp--transaction-precommit-functions (list foreign)))
+          (should-error
+           (tp-with-transaction (tp-signal-set signal 2))
+           :type 'tp-reactive-error)
+          (should (= (tp-signal-peek signal) 1))
+          (should (= (tp-signal-revision signal) 0)))))))
+
+(ert-deftest tp-binding-test-production-precommit-registry-is-exact ()
+  "The package exposes exactly its one statically declared precommit owner."
+  (should (equal tp--transaction-precommit-allowed-functions
+                 '(tp--surface-precommit-transaction)))
+  (should (equal tp--transaction-precommit-functions
+                 '(tp--surface-precommit-transaction))))
+
+(ert-deftest tp-binding-test-condition-trailer-cannot-collide-with-primary-data ()
+  "User condition data ending like rollback metadata is not a TP trailer."
+  (let ((condition '(error "Primary" :rollback-failures user-value)))
+    (should-not
+     (tp--transaction-condition-trailer condition :rollback-failures))))
+
+(ert-deftest tp-binding-test-rollback-preserves-primary-and-runs-all-phases ()
+  "Rollback failures attach in order without replacing the primary condition."
+  (tp-binding-test--isolated
+    (let* ((signal (tp-signal-create 1))
+           (binding (tp-bind 'owner '(test . rollback)
+                             (lambda () (tp-signal-read signal))))
+           (tp-binding-test-transaction-trace nil)
+           (tp-binding-test-precommit-condition nil)
+           (tp--transaction-precommit-functions
+            '(tp--binding-test-precommit-inject))
+           (tp--transaction-precommit-allowed-functions
+            '(tp--binding-test-precommit-inject))
+           (tp-binding-test-final-accept-function
+            (lambda ()
+              (signal 'tp-binding-test-primary
+                      '(:payload 7 :rollback-failures user-value))))
+           (tp--transaction-rollback-functions
+            '(tp-binding-test--rollback-hook-fail
+              tp-binding-test--rollback-hook-after))
+           (tp--transaction-rollback-final-functions
+            '(tp-binding-test--rollback-final-fail
+              tp-binding-test--rollback-final-after))
+           (restore-signal (symbol-function 'tp--restore-signal-entry))
+           (rollback-bindings (symbol-function 'tp--rollback-bindings))
+           (restore-counters
+            (symbol-function 'tp--restore-transaction-counters))
+           signal-restore-failed
+           failure)
+      (cl-letf (((symbol-function 'tp--restore-signal-entry)
+                 (lambda (entry)
+                   (funcall restore-signal entry)
+                   (push 'signal-restored tp-binding-test-transaction-trace)
+                   (unless signal-restore-failed
+                     (setq signal-restore-failed t)
+                     (error "Signal restore failure"))))
+                ((symbol-function 'tp--rollback-bindings)
+                 (lambda ()
+                   (funcall rollback-bindings)
+                   (push 'bindings-restored
+                         tp-binding-test-transaction-trace)))
+                ((symbol-function 'tp--restore-transaction-counters)
+                 (lambda (snapshot)
+                   (funcall restore-counters snapshot)
+                   (push 'counters-restored
+                         tp-binding-test-transaction-trace))))
+        (setq failure
+              (condition-case condition
+                  (tp-with-transaction
+                    (tp-transaction-participate
+                     'first
+                     (lambda ()
+                       (push 'publish-first
+                             tp-binding-test-transaction-trace))
+                     (lambda ()
+                       (push 'rollback-first
+                             tp-binding-test-transaction-trace)))
+                    (tp-transaction-participate
+                     'second
+                     (lambda ()
+                       (push 'publish-second
+                             tp-binding-test-transaction-trace))
+                     (lambda ()
+                       (push 'rollback-second
+                             tp-binding-test-transaction-trace)))
+                    (tp-signal-set signal 2))
+                (tp-binding-test-primary condition))))
+      (should (eq (car failure) 'tp-binding-test-primary))
+      (should (= (plist-get (cdr failure) :payload) 7))
+      (should (equal (butlast failure 2)
+                     '(tp-binding-test-primary
+                       :payload 7 :rollback-failures user-value)))
+      (let ((rollback-failures
+             (tp--transaction-condition-trailer
+              failure :rollback-failures)))
+        (should (equal (mapcar #'car rollback-failures)
+                       '(rollback-hooks signal-journal rollback-final))))
+      (should
+       (equal (nreverse tp-binding-test-transaction-trace)
+              '(publish-first publish-second precommit
+                rollback-second rollback-first
+                rollback-hook-fail rollback-hook-after
+                signal-restored bindings-restored counters-restored
+                rollback-final-fail rollback-final-after)))
+      (should (= (tp-signal-peek signal) 1))
+      (should (= (tp-signal-revision signal) 0))
+      (should (= (tp-binding-read binding) 1)))))
+
+(ert-deftest tp-binding-test-rollback-preserves-quit-primary ()
+  "A quit remains primary when rollback hooks fail and later hooks still run."
+  (tp-binding-test--isolated
+    (let* ((signal (tp-signal-create 1))
+           (tp-binding-test-transaction-trace nil)
+           (tp--transaction-precommit-functions
+            '(tp--binding-test-precommit-inject))
+           (tp--transaction-precommit-allowed-functions
+            '(tp--binding-test-precommit-inject))
+           (tp-binding-test-final-accept-function
+            (lambda () (signal 'quit '(:payload 9))))
+           (tp--transaction-rollback-functions
+            '(tp-binding-test--rollback-hook-fail
+              tp-binding-test--rollback-hook-after))
+           (failure
+            (tp-binding-test--capture-condition
+             (lambda ()
+               (tp-with-transaction (tp-signal-set signal 2))))))
+      (should (eq (car failure) 'quit))
+      (should (= (plist-get (cdr failure) :payload) 9))
+      (should
+       (equal (mapcar #'car
+                      (tp--transaction-condition-trailer
+                       failure :rollback-failures))
+              '(rollback-hooks)))
+      (should (equal (nreverse tp-binding-test-transaction-trace)
+                     '(precommit rollback-hook-fail rollback-hook-after)))
+      (should (= (tp-signal-peek signal) 1))
+      (should (= (tp-signal-revision signal) 0)))))
+
+(ert-deftest tp-binding-test-final-accept-throw-rolls-back-nonlocally ()
+  "A final-accept throw preserves its tag/value after complete rollback."
+  (tp-binding-test--isolated
+    (let* ((signal (tp-signal-create 1))
+           (binding (tp-bind 'owner '(test . throw)
+                             (lambda () (tp-signal-read signal))))
+           (binding-revision (tp-binding-revision binding))
+           (tp-binding-test-transaction-trace nil)
+           (tp--transaction-precommit-functions
+            '(tp--binding-test-precommit-inject))
+           (tp--transaction-precommit-allowed-functions
+            '(tp--binding-test-precommit-inject))
+           (tp-binding-test-final-accept-function
+            (lambda () (throw 'tp-binding-test-tag 'thrown-value)))
+           (tp--transaction-rollback-functions
+            '(tp-binding-test--rollback-hook-fail
+              tp-binding-test--rollback-hook-after))
+           (result
+            (catch 'tp-binding-test-tag
+              (tp-with-transaction (tp-signal-set signal 2))
+              'not-thrown)))
+      (should (eq result 'thrown-value))
+      (should (equal (nreverse tp-binding-test-transaction-trace)
+                     '(precommit rollback-hook-fail rollback-hook-after)))
+      (should (= (tp-signal-peek signal) 1))
+      (should (= (tp-signal-revision signal) 0))
+      (should (= (tp-binding-read binding) 1))
+      (should (= (tp-binding-revision binding) binding-revision))
+      (setq tp-binding-test-final-accept-function nil
+            tp--transaction-precommit-functions nil
+            tp--transaction-rollback-functions nil)
+      (tp-signal-set signal 2)
+      (should (= (tp-signal-peek signal) 2))
+      (should (= (tp-signal-revision signal) 1)))))
+
 (ert-deftest tp-binding-test-nested-write-queues-a-second-pass ()
   "A compute write queues stabilization instead of recursing."
   (tp-binding-test--isolated

tests/tp-surface-tests.el

@@ -32,6 +32,21 @@
      (tp-surface-test--leaf 'root (number-to-string (tp-signal-read signal)))
      (list :value (tp-signal-peek signal)))))
 
+(defun tp-surface-test--capture-condition (function)
+  "Call FUNCTION and return its error or quit condition."
+  (condition-case condition
+      (progn (funcall function) nil)
+    (error condition)
+    (quit condition)))
+
+(defun tp-surface-test--update-mode (mode surface object plan signal value)
+  "Update SURFACE in MODE with PLAN while touching SIGNAL to VALUE."
+  (tp-with-transaction
+    (tp-signal-set signal value)
+    (if (eq mode 'full)
+        (tp-surface-update surface plan)
+      (tp-surface-update-scoped surface (list object) plan))))
+
 (defvar-local tp-surface-test--corrupt-next nil
   "When non-nil, the test after-change hook corrupts one inserted range.")
 
@@ -636,6 +651,36 @@
       (should (= (plist-get report :text-operations) 1))
       (should (= (plist-get report :property-operations) 1)))))
 
+(ert-deftest tp-surface-test-incremental-content-update-never-leaves-point-at-patch ()
+  "Incremental text publication restores point after a length-changing patch."
+  (tp-surface-test--with-buffer
+    (let ((surface
+           (tp-surface-mount
+            buffer (tp-surface-test--leaf 'root "prefix old suffix"
+                                          '(face bold))
+            '(:capability content))))
+      (goto-char 8)
+      (let ((point-before (point)))
+        (tp-surface-update
+         surface (tp-surface-test--leaf 'root "prefix much-longer suffix"
+                                         '(face italic)))
+        (should (= (point) point-before))))))
+
+(ert-deftest tp-surface-test-scoped-content-update-preserves-point-after-patch ()
+  "A scoped update after point does not move the current cursor."
+  (tp-surface-test--with-buffer
+    (let ((surface
+           (tp-surface-mount
+            buffer (tp-surface-test--leaf 'root "before target after"
+                                          '(face bold))
+            '(:capability content))))
+      (goto-char 4)
+      (let ((point-before (point)))
+        (tp-surface-update
+         surface (tp-surface-test--leaf 'root "before changed-target after"
+                                         '(face italic)))
+        (should (= (point) point-before))))))
+
 (ert-deftest tp-surface-test-content-publication-reapplies-hook-corruption ()
   "A hook that changes inserted properties must be corrected before commit."
   (tp-surface-test--with-buffer
@@ -968,6 +1013,26 @@
           (should (plist-get report :full-root))
           (should (plist-get report :scope-fallback)))))))
 
+(ert-deftest tp-surface-test-scope-ignores-property-plist-order-outside-owner ()
+  "Keep a scoped update when unchanged outside text reorders properties."
+  (let ((old (copy-sequence "ABC"))
+        (new (copy-sequence "AMC")))
+    (add-text-properties 0 1 '(face bold help-echo "left") old)
+    (add-text-properties 2 3 '(face italic help-echo "right") old)
+    ;; Same semantic properties, deliberately inserted in reverse order.
+    (add-text-properties 0 1 '(help-echo "left" face bold) new)
+    (add-text-properties 2 3 '(help-echo "right" face italic) new)
+    (let ((analysis
+           (tp--scope-replacement-analysis old new '((1 . 2)) '((1 . 2)))))
+      (should analysis)
+      (should (= 1 (length (plist-get analysis :patches))))
+      (should (= 1 (plist-get (car (plist-get analysis :patches))
+                              :old-start)))
+      (should (tp--text-property-semantic-equal-p
+               (substring old 0 1) (substring new 0 1)))
+      (should (tp--text-property-semantic-equal-p
+               (substring old 2 3) (substring new 2 3))))))
+
 (ert-deftest tp-surface-test-scoped-update-rejects-outside-change ()
   "A scoped update should fail before publication when another range changes."
   (tp-surface-test--with-buffer
@@ -1608,6 +1673,279 @@
         (should (= (tp-surface-revision surface) revision))
         (should (eq object (tp-object-resolve surface '(root))))))))
 
+(ert-deftest tp-surface-test-full-and-scoped-precommit-stages-roll-back ()
+  "Every full and scoped precommit stage restores the complete old state."
+  (dolist (mode '(full scoped))
+    (dolist (stage '(validate view anchors lifecycle observers cleanup))
+      (tp-surface-test--with-buffer
+        (let* ((signal (tp-signal-create 1))
+               (surface
+                (tp-surface-mount
+                 buffer (tp-surface-test--leaf 'root "old")
+                 '(:capability content)))
+               (object (tp-object-resolve surface '(root)))
+               (revision (tp-surface-revision surface))
+               (transaction-id tp--surface-transaction-id)
+               (fail-stage stage)
+               (tp--surface-precommit-step-function
+                (lambda (current _state)
+                  (when (eq current fail-stage)
+                    (error "Injected precommit %S" current)))))
+          (goto-char (point-min))
+          (should-error
+           (tp-surface-test--update-mode
+            mode surface object (tp-surface-test--leaf 'root "new")
+            signal 2))
+          (should (equal (buffer-string) "old"))
+          (should (= (tp-surface-revision surface) revision))
+          (should (= tp--surface-transaction-id transaction-id))
+          (should (= (tp-signal-peek signal) 1))
+          (should (= (tp-signal-revision signal) 0))
+          (should (eq object (tp-object-resolve surface '(root))))
+          (should (= (point) (point-min)))
+          (setq fail-stage nil)
+          (tp-surface-test--update-mode
+           mode surface object (tp-surface-test--leaf 'root "new")
+           signal 2)
+          (should (equal (buffer-string) "new"))
+          (should (= (tp-surface-revision surface) (1+ revision)))
+          (should (= (tp-signal-peek signal) 2))
+          (should (= (tp-signal-revision signal) 1)))))))
+
+(ert-deftest tp-surface-test-full-and-scoped-final-accept-roll-back ()
+  "Final-accept error or quit rolls full and scoped state back exactly."
+  (dolist (mode '(full scoped))
+    (dolist (injected '((error "Final accept error") (quit)))
+      (tp-surface-test--with-buffer
+        (let* ((signal (tp-signal-create 1))
+               (surface
+                (tp-surface-mount
+                 buffer (tp-surface-test--leaf 'root "old")
+                 '(:capability content)))
+               (object (tp-object-resolve surface '(root)))
+               (revision (tp-surface-revision surface))
+               (transaction-id tp--surface-transaction-id)
+               (original (symbol-function 'accept-change-group))
+               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--update-mode
+                      mode surface object
+                      (tp-surface-test--leaf 'root "new") signal 2)))))
+          (should (eq (car failure) (car injected)))
+          (should (equal (buffer-string) "old"))
+          (should (= (tp-surface-revision surface) revision))
+          (should (= tp--surface-transaction-id transaction-id))
+          (should (= (tp-signal-peek signal) 1))
+          (should (= (tp-signal-revision signal) 0))
+          (should (eq object (tp-object-resolve surface '(root))))
+          (cl-letf (((symbol-function 'accept-change-group) original))
+            (tp-surface-test--update-mode
+             mode surface object (tp-surface-test--leaf 'root "new")
+             signal 2))
+          (should (equal (buffer-string) "new"))
+          (should (= (tp-surface-revision surface) (1+ revision)))
+          (should (= (tp-signal-revision signal) 1)))))))
+
+(ert-deftest tp-surface-test-final-accept-pending-quit-runs-postaccept ()
+  "A pending quit raised by accept cannot skip committed cleanup or observers."
+  (tp-surface-test--with-buffer
+    (let* ((signal (tp-signal-create 1))
+           (surface
+            (tp-surface-mount
+             buffer (tp-surface-test--leaf 'root "old")
+             '(:capability content)))
+           (old-mounts (copy-sequence (tp--surface-mounts surface)))
+           (original (symbol-function 'accept-change-group))
+           cleanup-ran observer-ran)
+      (setf (tp--surface-observers surface)
+            (list (lambda (_surface _report) (setq observer-ran t))))
+      (let ((tp--surface-cleanup-step-function
+             (lambda (_surface _owner) (setq cleanup-ran t))))
+        (cl-letf (((symbol-function 'accept-change-group)
+                   (lambda (group)
+                     (funcall original group)
+                     (setq quit-flag t))))
+          (tp-with-transaction
+            (tp-signal-set signal 2)
+            (tp-surface-update
+             surface (tp-surface-test--leaf 'root "new")))))
+      (should (equal (buffer-string) "new"))
+      (should (= (tp-signal-peek signal) 2))
+      (should cleanup-ran)
+      (should observer-ran)
+      (dolist (mount old-mounts)
+        (when (eq (tp--surface-mount-capability mount) 'content)
+          (should-not (marker-position (tp--surface-mount-start mount)))
+          (should-not (marker-position (tp--surface-mount-end mount))))))))
+
+(ert-deftest tp-surface-test-precommit-validates-final-object-state ()
+  "Precommit rejects corrupted published object state and rolls it back."
+  (tp-surface-test--with-buffer
+    (let* ((surface
+            (tp-surface-mount
+             buffer (tp-surface-test--leaf 'root "old")
+             '(:capability content)))
+           (object (tp-object-resolve surface '(root)))
+           (corrupt t)
+           (tp--surface-precommit-step-function
+            (lambda (stage _state)
+              (when (and corrupt (eq stage 'validate))
+                (setf (tp--surface-object-live object) nil)))))
+      (should-error
+       (tp-surface-update surface (tp-surface-test--leaf 'root "new")))
+      (should (equal (buffer-string) "old"))
+      (should (tp--surface-object-live object))
+      (setq corrupt nil)
+      (tp-surface-update surface (tp-surface-test--leaf 'root "new"))
+      (should (equal (buffer-string) "new")))))
+
+(ert-deftest tp-surface-test-postaccept-failures-are-contained-and-recorded ()
+  "Cleanup, observer, committed, and callback failures cannot undo accept."
+  (dolist (cleanup-condition '((error "Cleanup error") (quit)))
+    (tp-surface-test--with-buffer
+      (let* ((signal (tp-signal-create 1))
+             (surface
+              (tp-surface-mount
+               buffer (tp-surface-test--leaf 'root "old")
+               '(:capability content)))
+             (old-mounts (copy-sequence (tp--surface-mounts surface)))
+             (cleanup-fired nil)
+             (tp--surface-cleanup-step-function
+              (lambda (_surface owner)
+                (when (and (eq owner 'view-markers) (not cleanup-fired))
+                  (setq cleanup-fired t)
+                  (signal (car cleanup-condition)
+                          (cdr cleanup-condition)))))
+             (tp--transaction-committed-functions
+              (append tp--transaction-committed-functions
+                      (list (lambda () (error "Committed failure"))))))
+        (setf (tp--surface-observers surface)
+              (list (lambda (_surface _report) (error "Observer error"))
+                    (lambda (_surface _report) (signal 'quit nil))))
+        (tp-with-transaction
+          (tp--enqueue-after-commit (lambda () (error "Callback error")))
+          (tp--enqueue-after-commit (lambda () (signal 'quit nil)))
+          (tp-signal-set signal 2)
+          (tp-surface-update surface (tp-surface-test--leaf 'root "new")))
+        (should (equal (buffer-string) "new"))
+        (should (= (tp-signal-peek signal) 2))
+        (should (= (tp-signal-revision signal) 1))
+        (should (= (length (plist-get (tp-surface-report surface)
+                                      :cleanup-errors))
+                   1))
+        (should (= (length (plist-get (tp-surface-report surface)
+                                      :observer-errors))
+                   2))
+        (should (equal (mapcar #'car tp--last-transaction-diagnostics)
+                       '(committed after-commit after-commit)))
+        (dolist (mount old-mounts)
+          (when (eq (tp--surface-mount-capability mount) 'content)
+            (should-not (marker-position (tp--surface-mount-start mount)))
+            (should-not (marker-position (tp--surface-mount-end mount)))))))))
+
+(ert-deftest tp-surface-test-view-capture-cleans-partial-markers ()
+  "A partial view snapshot failure disposes every marker already allocated."
+  (tp-surface-test--with-buffer
+    (let ((original (symbol-function 'copy-marker))
+          (calls 0)
+          created)
+      (cl-letf (((symbol-function 'get-buffer-window-list)
+                 (lambda (&rest _arguments) (list (selected-window))))
+                ((symbol-function 'copy-marker)
+                 (lambda (&rest arguments)
+                   (cl-incf calls)
+                   (when (= calls 2) (error "Second marker failure"))
+                   (let ((marker (apply original arguments)))
+                     (push marker created)
+                     marker))))
+        (should-error (tp--capture-view-state (list buffer))))
+      (should (= (length created) 1))
+      (should-not (marker-position (car created))))))
+
+(ert-deftest tp-surface-test-anchor-apply-failure-uses-complete-undo-journal ()
+  "An anchor mutation failure restores old opaque ownership before retry."
+  (tp-surface-test--with-buffer
+    (insert "host")
+    (let* ((old-anchor (tp-range-anchor-create buffer 1 5))
+           (new-anchor (tp-range-anchor-create buffer 1 5))
+           (current old-anchor)
+           (producer
+            (lambda (context)
+              (let ((object (tp-object-ensure context nil 'root 'range)))
+                (tp-object-attach-range context object current))
+              (tp-surface-plan-create
+               :key 'root :kind 'range :props '(help-echo "owned")
+               :capability 'properties)))
+           (surface (tp-surface-mount
+                     buffer producer '(:capability properties)))
+           (original (symbol-function 'tp--apply-anchor-ownership)))
+      (setq current new-anchor)
+      (cl-letf (((symbol-function 'tp--apply-anchor-ownership)
+                 (lambda (&rest arguments)
+                   (apply original arguments)
+                   (error "After anchor ownership mutation"))))
+        (should-error (tp-surface-update surface producer)))
+      (should (memq surface (tp--anchor-surfaces old-anchor)))
+      (should-not (memq surface (tp--anchor-surfaces new-anchor)))
+      (should (tp-range-anchor-live-p old-anchor))
+      (tp-surface-update surface producer)
+      (should-not (tp-range-anchor-live-p old-anchor))
+      (should (memq surface (tp--anchor-surfaces new-anchor))))))
+
+(ert-deftest tp-surface-test-phase2-failure-does-not-skip-later-undo ()
+  "A phase-2 restoration failure still runs surface, view, and anchor undo."
+  (tp-surface-test--with-buffer
+    (let* ((surface (tp-surface-mount
+                     buffer (tp-surface-test--leaf 'root "old")
+                     '(:capability content)))
+           (restore-properties
+            (symbol-function 'tp--restore-property-journals))
+           (restore-snapshot
+            (symbol-function 'tp--restore-surface-snapshot))
+           (restore-view (symbol-function 'tp--restore-view-state))
+           (undo-anchors (symbol-function 'tp--undo-anchor-ownership))
+           trace failure)
+      (cl-letf (((symbol-function 'accept-change-group)
+                 (lambda (_group)
+                   (setq trace nil)
+                   (error "Primary accept failure")))
+                ((symbol-function 'tp--restore-property-journals)
+                 (lambda (journals)
+                   (funcall restore-properties journals)
+                   (push 'properties trace)
+                   (error "Property rollback failure")))
+                ((symbol-function 'tp--restore-surface-snapshot)
+                 (lambda (&rest arguments)
+                   (push 'surface trace)
+                   (apply restore-snapshot arguments)))
+                ((symbol-function 'tp--restore-view-state)
+                 (lambda (&rest arguments)
+                   (push 'view trace)
+                   (apply restore-view arguments)))
+                ((symbol-function 'tp--undo-anchor-ownership)
+                 (lambda (undo)
+                   (push 'anchors trace)
+                   (funcall undo-anchors undo))))
+        (setq failure
+              (tp-surface-test--capture-condition
+               (lambda ()
+                 (tp-surface-update
+                  surface (tp-surface-test--leaf 'root "new"))))))
+      (should (eq (car failure) 'error))
+      (should (equal (cadr failure) "Primary accept failure"))
+      (should (equal (nreverse trace)
+                     '(properties surface view anchors)))
+      (should (equal (buffer-string) "old"))
+      (should (equal (mapcar #'car
+                             (tp--transaction-condition-trailer
+                              failure :rollback-failures))
+                     '(rollback-hooks))))))
+
 (ert-deftest tp-surface-test-global-signal-update-is-multi-surface-atomic ()
   "A second-surface failure rolls back buffers, bindings, and source value."
   (let* ((signal (tp-signal-create 1))
@@ -1925,6 +2263,50 @@
       (should (= (tp-surface-revision surface) revision))
       (should (equal (buffer-string) "1")))))
 
+(ert-deftest tp-surface-test-output-equal-precommit-finalizes-and-rolls-back ()
+  "Output-equal candidates finalize lifecycle without visible publication."
+  (tp-surface-test--with-buffer
+    (let* ((source (tp-signal-create 10))
+           (auxiliary (tp-signal-create 1))
+           (include t)
+           binding
+           (producer
+            (lambda (context)
+              (let ((object (tp-object-ensure context nil 'root 'text)))
+                (when include
+                  (setq binding
+                        (tp-bind object '(test . optional)
+                                 (lambda () (tp-signal-read auxiliary))))
+                  (tp-binding-read binding)))
+              (tp-surface-test--leaf
+               'root (number-to-string (/ (tp-signal-read source) 10)))))
+           (surface (tp-surface-mount
+                     buffer producer '(:capability content)))
+           (revision (tp-surface-revision surface))
+           (transaction-id tp--surface-transaction-id)
+           (fail t)
+           (tp--surface-precommit-step-function
+            (lambda (step _state)
+              (when (and fail (eq step 'lifecycle-finalized))
+                (error "After output-equal lifecycle")))))
+      (setq include nil)
+      (should-error (tp-signal-set source 11))
+      (should (tp-binding-live-p binding))
+      (should (= (tp-signal-subscriber-count auxiliary) 1))
+      (should (= (tp-signal-peek source) 10))
+      (should (= (tp-signal-revision source) 0))
+      (should (= (tp-surface-revision surface) revision))
+      (should (= tp--surface-transaction-id transaction-id))
+      (should (equal (buffer-string) "1"))
+      (setq fail nil)
+      (tp-signal-set source 11)
+      (should-not (tp-binding-live-p binding))
+      (should (= (tp-signal-subscriber-count auxiliary) 0))
+      (should (= (tp-signal-revision source) 1))
+      (should (= (tp-surface-revision surface) revision))
+      (should (= tp--surface-transaction-id transaction-id))
+      (should (equal (buffer-string) "1")))))
+
 (ert-deftest tp-surface-test-keyed-reorder-preserves-object-handles ()
   "Keyed children keep identity when their display order changes."
   (tp-surface-test--with-buffer

tp-reactive.el

@@ -46,6 +46,11 @@
   "One rollback-capable side-state participant in a TP transaction."
   key publish rollback)
 
+(cl-defstruct (tp--signal-commit-entry
+               (:constructor tp--make-signal-commit-entry))
+  "One transaction signal's candidate and exact committed rollback state."
+  signal old-committed-value old-revision candidate-value)
+
 (defconst tp--reactive-absent (make-symbol "tp-reactive-absent"))
 
 (defvar tp--signal-id-counter 0)
@@ -76,6 +81,9 @@
 (defvar tp--transaction-participants nil)
 (defvar tp--transaction-participant-keys nil)
 (defvar tp--transaction-published-participants nil)
+(defvar tp--transaction-signal-commit-journal nil)
+(defvar tp--transaction-contained-failures nil)
+(defvar tp--last-transaction-diagnostics nil)
 (defvar tp--current-binding nil)
 (defvar tp--binding-compute-stack nil)
 (defvar tp--collected-dependency-set nil)
@@ -83,10 +91,22 @@
 (defvar tp--binding-touch-function nil)
 (defvar tp--binding-changed-functions nil)
 (defvar tp--transaction-publish-functions nil)
+(defvar tp--transaction-precommit-functions nil
+  "Internal TP-owned precommit hook symbols in deterministic order.")
+(defconst tp--transaction-precommit-allowed-functions
+  '(tp--surface-precommit-transaction)
+  "Exact TP-owned symbols allowed in the internal precommit registry.")
+(defvar tp--transaction-final-accept-function
+  #'tp--transaction-noop-final-accept
+  "Internal single final-accept function for the active transaction.")
 (defvar tp--transaction-rollback-functions nil)
 (defvar tp--transaction-rollback-final-functions nil)
 (defvar tp--transaction-committed-functions nil)
 
+(defconst tp--transaction-condition-trailer-tag
+  (make-symbol "tp--transaction-condition-trailer")
+  "Unforgeable tag separating primary condition data from TP metadata.")
+
 (defun tp--counter-increment (key)
   "Increment reactive counter KEY."
   (setq tp--reactive-counters
@@ -587,9 +607,10 @@ transaction."
     (dolist (participant tp--transaction-published-participants)
       (condition-case failure
           (funcall (tp--transaction-participant-rollback participant))
-        (error
-         (push (list :key (tp--transaction-participant-key participant)
-                     :error failure)
+        ((error quit)
+         (push (list 'participants
+                     (tp--transaction-participant-key participant)
+                     failure)
                failures))))
     (nreverse failures)))
 
@@ -646,18 +667,178 @@ transaction."
           (dolist (dependency (tp-binding-dependencies binding))
             (tp--subscription-add dependency binding)))))))
 
-(defun tp--commit-signal-values ()
-  "Commit candidate signal values after a successful flush."
-  (dolist (signal (nreverse tp--transaction-signals))
+(defun tp--transaction-noop-final-accept ()
+  "Accept a pure reactive transaction with no external publication work."
+  nil)
+
+(defun tp--transaction-precommit-function-p (function)
+  "Return non-nil when FUNCTION is a declared TP-internal hook symbol."
+  (and (symbolp function)
+       (memq function tp--transaction-precommit-allowed-functions)
+       (fboundp function)))
+
+(defun tp--transaction-register-precommit-function (function)
+  "Register declared TP-internal precommit FUNCTION once."
+  (unless (tp--transaction-precommit-function-p function)
+    (signal 'tp-reactive-error
+            (list :invalid-precommit-function function)))
+  (unless (memq function tp--transaction-precommit-functions)
+    (setq tp--transaction-precommit-functions
+          (append tp--transaction-precommit-functions (list function))))
+  function)
+
+(defun tp--transaction-install-final-accept (function)
+  "Install the active transaction's single final-accept FUNCTION."
+  (unless tp--transaction-active
+    (signal 'tp-reactive-error (list :final-accept-outside-transaction)))
+  (unless (functionp function)
+    (signal 'wrong-type-argument (list 'functionp function)))
+  (unless (eq tp--transaction-final-accept-function
+              #'tp--transaction-noop-final-accept)
+    (signal 'tp-reactive-error
+            (list :duplicate-final-accept-function
+                  tp--transaction-final-accept-function function)))
+  (setq tp--transaction-final-accept-function function))
+
+(defun tp--run-contained-transaction-functions (phase functions)
+  "Run postaccept PHASE FUNCTIONS and record contained failures."
+  (dolist (function (tp--transaction-hook-functions functions))
+    (let ((inhibit-quit t)
+          (quit-flag nil))
+      (condition-case failure
+          (funcall function)
+        ((error quit)
+         (push (list phase function failure)
+               tp--transaction-contained-failures))))))
+
+(defun tp--run-transaction-precommit-functions ()
+  "Run the internal declared precommit registry in deterministic order."
+  (dolist (function tp--transaction-precommit-functions)
+    (unless (tp--transaction-precommit-function-p function)
+      (signal 'tp-reactive-error
+              (list :invalid-precommit-function function)))
+    (funcall function)))
+
+(defun tp--prepare-signal-commit-journal ()
+  "Capture every touched signal before any committed field is mutated."
+  (setq tp--transaction-signal-commit-journal
+        (mapcar
+         (lambda (signal)
+           (tp--make-signal-commit-entry
+            :signal signal
+            :old-committed-value (tp-signal-committed-value signal)
+            :old-revision (tp-signal-revision signal)
+            :candidate-value
+            (gethash signal tp--transaction-signal-values)))
+         (nreverse (copy-sequence tp--transaction-signals)))))
+
+(defun tp--commit-signal-entry (entry)
+  "Commit signal journal ENTRY exactly once."
+  (let ((signal (tp--signal-commit-entry-signal entry)))
     (setf (tp-signal-committed-value signal)
-          (gethash signal tp--transaction-signal-values)
-          (tp-signal-revision signal) (1+ (tp-signal-revision signal)))))
+          (tp--signal-commit-entry-candidate-value entry)
+          (tp-signal-revision signal)
+          (1+ (tp--signal-commit-entry-old-revision entry)))))
+
+(defun tp--restore-signal-entry (entry)
+  "Restore signal journal ENTRY's exact committed state."
+  (let ((signal (tp--signal-commit-entry-signal entry)))
+    (setf (tp-signal-committed-value signal)
+          (tp--signal-commit-entry-old-committed-value entry)
+          (tp-signal-revision signal)
+          (tp--signal-commit-entry-old-revision entry))))
+
+(defun tp--commit-signal-values ()
+  "Journal and commit candidate signals in stable first-touch order."
+  (tp--prepare-signal-commit-journal)
+  (dolist (entry tp--transaction-signal-commit-journal)
+    (tp--commit-signal-entry entry)))
+
+(defun tp--restore-transaction-counters (snapshot)
+  "Restore reactive counters from SNAPSHOT."
+  (setq tp--reactive-counters snapshot))
+
+(defun tp--transaction-hook-functions (value)
+  "Return hook VALUE as one ordered function list."
+  (cond
+   ((null value) nil)
+   ((functionp value) (list value))
+   (t value)))
+
+(defun tp--rollback-hook-phase (phase functions)
+  "Run rollback PHASE FUNCTIONS and return ordered failures."
+  (let (failures)
+    (dolist (function (tp--transaction-hook-functions functions))
+      (condition-case failure
+          (funcall function)
+        ((error quit)
+         (push (list phase function failure) failures))))
+    (nreverse failures)))
+
+(defun tp--rollback-signal-journal ()
+  "Restore every signal journal entry and return ordered failures."
+  (let (failures)
+    (dolist (entry tp--transaction-signal-commit-journal)
+      (condition-case failure
+          (tp--restore-signal-entry entry)
+        ((error quit)
+         (push (list 'signal-journal
+                     (tp-signal-id
+                      (tp--signal-commit-entry-signal entry))
+                     failure)
+               failures))))
+    (nreverse failures)))
+
+(defun tp--rollback-transaction-state (counter-snapshot)
+  "Restore COUNTER-SNAPSHOT through every rollback phase.
+Return contained failures in phase order."
+  (let ((failures (tp--rollback-transaction-participants)))
+    (setq failures
+          (append
+           failures
+           (tp--rollback-hook-phase
+            'rollback-hooks tp--transaction-rollback-functions)
+           (tp--rollback-signal-journal)))
+    (condition-case failure
+        (tp--rollback-bindings)
+      ((error quit)
+       (setq failures
+             (append failures
+                     (list (list 'bindings 'binding-graph failure))))))
+    (condition-case failure
+        (tp--restore-transaction-counters counter-snapshot)
+      ((error quit)
+       (setq failures
+             (append failures
+                     (list (list 'counters 'reactive-counters failure))))))
+    (append
+     failures
+     (tp--rollback-hook-phase
+      'rollback-final tp--transaction-rollback-final-functions))))
+
+(defun tp--resignal-transaction-primary (primary-condition failures)
+  "Re-signal PRIMARY-CONDITION with ordered rollback FAILURES attached."
+  (signal (car primary-condition)
+          (if failures
+              (append (cdr primary-condition)
+                      (list tp--transaction-condition-trailer-tag
+                            (list :rollback-failures failures)))
+            (cdr primary-condition))))
+
+(defun tp--transaction-condition-trailer (condition property)
+  "Return PROPERTY from the exact transaction trailer of CONDITION.
+Transaction rollback metadata is appended after, and never merged into,
+the primary condition data."
+  (let ((trailer (last condition 2)))
+    (and (eq (car trailer) tp--transaction-condition-trailer-tag)
+         (plist-get (cadr trailer) property))))
 
 (defun tp--call-with-transaction (function)
   "Call FUNCTION in one atomic signal and binding transaction."
   (if tp--transaction-active
       (funcall function)
-    (let (after-commit result)
+    (let (after-commit result
+          (tp--transaction-contained-failures nil))
       (setq result
             (let ((tp--transaction-active t)
                   (tp--transaction-signal-values
@@ -675,37 +856,83 @@ transaction."
                   (tp--transaction-participants nil)
                   (tp--transaction-participant-keys nil)
                   (tp--transaction-published-participants nil)
+                  (tp--transaction-signal-commit-journal nil)
+                  (tp--transaction-final-accept-function
+                   #'tp--transaction-noop-final-accept)
                   (counter-snapshot (copy-sequence tp--reactive-counters))
                   (tp--transaction-counter-start nil)
-                  success transaction-result rollback-failures)
+                  success transaction-result primary-condition
+                  rollback-failures pending-quit)
               (setq tp--transaction-counter-start counter-snapshot)
               (unwind-protect
-                  (progn
-                    (setq transaction-result (funcall function))
-                    (tp--flush-dirty-bindings)
-                    (run-hooks 'tp--transaction-publish-functions)
-                    (tp--publish-transaction-participants)
-                    (tp--commit-signal-values)
-                    (setq success t)
-                    transaction-result)
+                  (condition-case condition
+                      (progn
+                        (setq transaction-result (funcall function))
+                        (tp--flush-dirty-bindings)
+                        (run-hooks 'tp--transaction-publish-functions)
+                        (tp--publish-transaction-participants)
+                        (tp--run-transaction-precommit-functions)
+                        (tp--commit-signal-values)
+                        (condition-case deferred-quit
+                            (progn
+                              (let ((inhibit-quit t)
+                                    (quit-flag nil))
+                                (unwind-protect
+                                    (progn
+                                      (unless
+                                          (functionp
+                                           tp--transaction-final-accept-function)
+                                        (signal
+                                         'tp-reactive-error
+                                         (list
+                                          :invalid-final-accept-function
+                                          tp--transaction-final-accept-function)))
+                                      (funcall
+                                       tp--transaction-final-accept-function)
+                                      (setq success t)
+                                      (when quit-flag
+                                        (setq pending-quit t
+                                              quit-flag nil))
+                                      (tp--run-contained-transaction-functions
+                                       'committed
+                                       tp--transaction-committed-functions)
+                                      (setq after-commit
+                                            (nreverse
+                                             tp--transaction-after-commit-callbacks))
+                                      (when pending-quit
+                                        (push
+                                         (list 'final-accept
+                                               tp--transaction-final-accept-function
+                                               '(quit))
+                                         tp--transaction-contained-failures)))
+                                  (setq quit-flag nil)))
+                              nil)
+                          (quit
+                           (if success
+                               (push
+                                (list 'final-accept
+                                      tp--transaction-final-accept-function
+                                      deferred-quit)
+                                tp--transaction-contained-failures)
+                             (signal (car deferred-quit)
+                                     (cdr deferred-quit))))))
+                    ((error quit)
+                     (setq primary-condition condition)))
                 (unless success
-                  (let ((inhibit-quit t))
-                    (setq rollback-failures
-                          (tp--rollback-transaction-participants))
-                    (run-hooks 'tp--transaction-rollback-functions)
-                    (tp--rollback-bindings)
-                    (setq tp--reactive-counters counter-snapshot)
-                    (run-hooks 'tp--transaction-rollback-final-functions)
-                    (when rollback-failures
-                      (signal 'tp-reactive-error
-                              (list :participant-rollback-failed
-                                    rollback-failures))))))
-              (when success
-                (run-hooks 'tp--transaction-committed-functions)
-                (setq after-commit
-                      (nreverse tp--transaction-after-commit-callbacks)))
+                  (let ((inhibit-quit t)
+                        (quit-flag nil))
+                    (unwind-protect
+                        (setq rollback-failures
+                              (tp--rollback-transaction-state
+                               counter-snapshot))
+                      (setq quit-flag nil)))))
+              (when primary-condition
+                (tp--resignal-transaction-primary
+                 primary-condition rollback-failures))
               transaction-result))
-      (dolist (callback after-commit) (funcall callback))
+      (tp--run-contained-transaction-functions 'after-commit after-commit)
+      (setq tp--last-transaction-diagnostics
+            (nreverse tp--transaction-contained-failures))
       result)))
 
 ;;;###autoload