;;; tp-transaction-tests.el --- TP structured transaction contract -*- lexical-binding: t; -*-

;; Copyright (C) 2026 Geekinney

;;; Commentary:

;; Characterization and fault tests for the v2 transaction protocol.  These
;; tests deliberately exercise
;; the internal protocol: the public contract remains `tp-with-transaction'
;; body return and primary condition preservation.

;;; Code:

(require 'cl-lib)
(require 'ert)
(require 'tp-transaction)
(require 'tp-surface)

(declare-function tp--transaction-participate-v2 "tp-reactive" (&rest args))
(declare-function tp-transaction-participate-v2 "tp-reactive" (&rest args))
(declare-function tp--transaction-participant-protocol "tp-reactive" (value))
(declare-function tp--transaction-participant-state "tp-reactive" (value))
(declare-function tp--transaction-participant-journal "tp-reactive" (value))
(declare-function tp--transaction-register-final-marker
                  "tp-reactive" (&rest args))
(defvar tp--transaction-publication-batch)
(defvar tp--transaction-outcome)
(defvar tp--last-shadow-proof)

(define-error 'tp-transaction-test-error "Injected TP transaction failure")

(defvar tp-transaction-test--precommit-condition nil)
(defvar tp-transaction-test--trace nil)

(defun tp--transaction-test-precommit-inject ()
  "Record precommit and signal the configured test condition."
  (push 'precommit tp-transaction-test--trace)
  (when tp-transaction-test--precommit-condition
    (signal (car tp-transaction-test--precommit-condition)
            (cdr tp-transaction-test--precommit-condition))))

(defun tp--transaction-test-participant-precommit ()
  "Record one declared structured-participant precommit."
  (push 'participant-precommit tp-transaction-test--trace))

(defun tp-transaction-test--leaf (text)
  "Return a retained content leaf displaying TEXT."
  (tp-surface-plan-create
   :key 'root :kind 'text :text text :capability 'content))

(defun tp-transaction-test--producer (source)
  "Return a retained producer reading SOURCE."
  (lambda (context)
    (tp-object-ensure context nil 'root 'text)
    (tp-transaction-test--leaf
     (number-to-string (tp-signal-read source)))))

(defun tp-transaction-test--capture (function)
  "Call FUNCTION and return its complete signaled condition."
  (condition-case condition
      (progn (funcall function) nil)
    ((error quit) condition)))

(defun tp-transaction-test--entry (&rest overrides)
  "Return one valid publication target entry with OVERRIDES."
  (let ((buffer (or (plist-get overrides :buffer)
                    (current-buffer))))
    (let ((arguments
           (list :surface-id 'surface-a
                 :transaction-id 'transaction-a
                 :batch-id 'batch-a
                 :candidate-id 'candidate-a
                 :mount-ids '(mount-a)
                 :buffer buffer
                 :old-revision 7
                 :new-revision 8
                 :plan '(:plan old)
                 :diff '(:replace 1 2)
                 :ledger '(:ledger candidate)
                 :objects '(:object candidate)
                 :ranges '((1 . 2))
                 :client-state '(:client candidate)
                 :rollback-snapshot '(:snapshot old)
                 :authority-token 'entry-authority-a
                 :mapping-generation 3)))
      (while overrides
        (setq arguments
              (plist-put arguments (pop overrides) (pop overrides))))
      (apply #'tp--publication-target-entry-create arguments))))

(defun tp-transaction-test--batch (&optional entries)
  "Return a prepared batch for ENTRIES or one default target."
  (tp--publication-batch-prepare
   :transaction-id 'transaction-a
   :batch-id 'batch-a
   :entries (or entries (list (tp-transaction-test--entry)))
   :participants []
   :journals nil
   :final-accept #'ignore
   :diagnostics nil))

(ert-deftest tp-transaction-test-unique-identities-use-equal-semantics ()
  "Distinct identity values stay distinct; equal values remain duplicates."
  (dolist (items (list nil '(nil) '(1 1.0) '(nil mount-a "mount-a")
                      (number-sequence 1 2000)))
    (let ((before (copy-tree items)))
      (should (tp--proper-unique-list-p items))
      (should (equal items before))))
  (dolist (items (list '(nil nil) '(mount-a mount-a)
                      (list (copy-sequence "mount") (copy-sequence "mount"))
                      (list (list 'owner 1) (list 'owner 1))
                      (list (vector 'owner 1) (vector 'owner 1))))
    (should-not (tp--proper-unique-list-p items))
    (should-error (tp-transaction-test--entry :mount-ids items)
                  :type 'tp-publication-binding-error)))

(ert-deftest tp-transaction-test-unique-identities-reject-improper-lists ()
  "Malformed identity sequences cannot enter publication authority bindings."
  (let ((cycle (list 'mount-a 'mount-b)))
    (setcdr (last cycle) cycle)
    (dolist (items (list 'mount-a [mount-a] '(mount-a . mount-b) cycle))
      (should-not (tp--proper-unique-list-p items))
      (should-error (tp-transaction-test--entry :mount-ids items)
                    :type 'tp-publication-binding-error))))

(defun tp-transaction-test--slot-writes (target values)
  "Return fixed slot writes assigning VALUES into TARGET from index zero."
  (vconcat
   (cl-loop for value across values
            for index from 0
            collect
            (tp--final-marker-slot-write-create
             :target target :index index :value value))))

(defun tp-transaction-test--marker-arguments
    (target next-values inverse-values &rest overrides)
  "Return TARGET marker args for NEXT-VALUES, INVERSE-VALUES, and OVERRIDES."
  (let* ((token-index (- (length target) 2))
         (version-index (1- (length target)))
         (arguments
          (list
           :owner-key 'owner-a
           :expected-token
           (tp--final-marker-expectation-create
            :target target :index token-index :value (aref target token-index))
           :expected-version
           (tp--final-marker-expectation-create
            :target target :index version-index
            :value (aref target version-index))
           :next-values (tp-transaction-test--slot-writes target next-values)
           :inverse-values
           (tp-transaction-test--slot-writes target inverse-values)
           :slot-write-count (length next-values)
           :operation-key 'tp-vector-slots/v1)))
    (while overrides
      (setq arguments
            (plist-put arguments (pop overrides) (pop overrides))))
    arguments))

(defun tp-transaction-test--property-producer (source anchor)
  "Return a properties-only producer reading SOURCE over ANCHOR."
  (lambda (context)
    (let ((object (tp-object-ensure context nil 'root 'range))
          (value (tp-signal-read source)))
      (tp-object-attach-range context object anchor)
      (tp-surface-result-create
       (tp-surface-plan-create
        :key 'root :kind 'range
        :props (list 'face (if (= value 1) 'bold 'italic))
        :capability 'properties)
       (list :value value)))))

(defun tp-transaction-test--property-state (surface)
  "Return exact rollback-sensitive observational state for SURFACE."
  (let ((buffer (tp--surface-buffer surface)))
    (with-current-buffer buffer
      (list :point (point)
            :mount-ids (copy-sequence (tp--live-mount-ids surface))
            :mounts (tp--copy-property-value
                     (tp--live-mount-signature surface))
            :ledger (tp--copy-property-value
                     (tp--shadow-live-ledger-signature
                      (tp--surface-ledger surface)))
            :client-state
            (tp--copy-property-value (tp--surface-client-state surface))
            :revision (tp-surface-revision surface)
            :output (buffer-substring (point-min) (point-max))))))

(defun tp-transaction-test--should-match-property-state (surface expected)
  "Assert that SURFACE exactly matches rollback EXPECTED."
  (let ((actual (tp-transaction-test--property-state surface)))
    (dolist (key '(:point :mount-ids :mounts :ledger
                          :client-state :revision))
      (should (equal (plist-get actual key) (plist-get expected key))))
    (should (equal-including-properties
             (plist-get actual :output) (plist-get expected :output)))))

(defun tp-transaction-test--set-batch-proof-fields (candidate)
  "Install deterministic proof fields on low-level CANDIDATE."
  (setf (tp-publication-batch-candidate-operation-counts candidate)
        '(:text 1)
        (tp-publication-batch-candidate-phase-timings candidate)
        '(:total 0.1)
        (tp-publication-batch-candidate-diagnostics candidate) nil)
  candidate)

(defun tp-transaction-test--should-match-outcome-counts (outcome surfaces)
  "Assert OUTCOME mapping generation and counts match SURFACES' reports."
  (let* ((entries (tp-committed-success-outcome-entries outcome))
         (aggregate (tp-committed-success-outcome-operation-counts outcome))
         (generation (tp-committed-success-outcome-mapping-generation outcome))
         (text 0) (properties 0) (touched 0))
    (should generation)
    (should (= (length entries) (length surfaces)))
    (dolist (surface surfaces)
      (let* ((surface-id (tp--surface-id surface))
             (report (tp-surface-report surface))
             (entry
              (cl-find surface-id entries
                       :key #'tp-publication-outcome-entry-surface-id
                       :test #'equal))
             (counts
              (and entry
                   (tp-publication-outcome-entry-operation-counts entry))))
        (should entry)
        (should (equal (tp-publication-outcome-entry-mapping-generation entry)
                       generation))
        (should (equal (plist-get counts :mapping-generation) generation))
        (dolist (key '(:old-revision :new-revision :text-operations
                                     :property-operations
                                     :touched-characters))
          (should (equal (plist-get counts key) (plist-get report key))))
        (cl-incf text (plist-get report :text-operations))
        (cl-incf properties (plist-get report :property-operations))
        (cl-incf touched (plist-get report :touched-characters))))
    (should (= (plist-get aggregate :targets) (length surfaces)))
    (should (= (plist-get aggregate :text-operations) text))
    (should (= (plist-get aggregate :property-operations) properties))
    (should (= (plist-get aggregate :touched-characters) touched))
    (should (= (length (plist-get aggregate :target-counts))
               (length surfaces)))))

(cl-defmacro tp-transaction-test--with-surface
    ((buffer surface source) &rest body)
  "Create BUFFER, SOURCE and SURFACE, then evaluate BODY."
  (declare (indent 1) (debug ((symbolp symbolp symbolp) body)))
  `(let* ((,buffer (generate-new-buffer " *tp-transaction-test*"))
          (,source (tp-signal-create 1))
          (,surface
           (tp-surface-mount
            ,buffer (tp-transaction-test--producer ,source)
            '(:capability content))))
     (unwind-protect
         (progn ,@body)
       (when (buffer-live-p ,buffer)
         (kill-buffer ,buffer))
       (when (tp-signal-live-p ,source)
         (tp-signal-dispose ,source)))))

(ert-deftest tp-transaction-test-v2-body-return-and-phase-order ()
  "The v2 facade returns BODY and retains its established phase order."
  (let ((tp-transaction-test--trace nil)
        (tp--transaction-precommit-functions
         '(tp--transaction-test-precommit-inject))
        (tp--transaction-precommit-allowed-functions
         '(tp--transaction-test-precommit-inject)))
    (should
     (equal
      (tp-with-transaction
        (tp-transaction-participate-v2
         :key 'v2
         :stage (lambda () (push 'participant tp-transaction-test--trace))
         :rollback (lambda () (push 'rollback tp-transaction-test--trace)))
        (tp--enqueue-after-commit
         (lambda () (push 'after-commit tp-transaction-test--trace)))
        (push 'body tp-transaction-test--trace)
        'body-value)
      'body-value))
    (should (equal (nreverse tp-transaction-test--trace)
                   '(body participant precommit after-commit)))))

(ert-deftest tp-transaction-test-v2-participant-and-precommit-fault-order ()
  "A late v2 fault rolls staged participants back in reverse order."
  (let* ((injected '(tp-transaction-test-error :phase precommit :raw (1 2)))
         (tp-transaction-test--trace nil)
         (tp-transaction-test--precommit-condition injected)
         (tp--transaction-precommit-functions
          '(tp--transaction-test-precommit-inject))
         (tp--transaction-precommit-allowed-functions
          '(tp--transaction-test-precommit-inject))
         (failure
          (tp-transaction-test--capture
           (lambda ()
             (tp-with-transaction
               (tp-transaction-participate-v2
                :key 'first
                :stage (lambda () (push 'stage-first tp-transaction-test--trace))
                :rollback (lambda () (push 'rollback-first tp-transaction-test--trace)))
               (tp-transaction-participate-v2
                :key 'second
                :stage (lambda () (push 'stage-second tp-transaction-test--trace))
                :rollback (lambda () (push 'rollback-second tp-transaction-test--trace))))))))
    (should (equal failure injected))
    (should (equal (nreverse tp-transaction-test--trace)
                   '(stage-first stage-second precommit
                     rollback-second rollback-first)))))

(ert-deftest tp-transaction-test-final-accept-fault-preserves-body-state ()
  "A final-accept fault restores source, surface revision and buffer."
  (tp-transaction-test--with-surface (buffer surface source)
    (let ((old-revision (tp-surface-revision surface))
          (injected '(tp-transaction-test-error :phase final-accept)))
      (should
       (equal
        (cl-letf (((symbol-function 'accept-change-group)
                   (lambda (_group)
                     (signal (car injected) (cdr injected)))))
          (tp-transaction-test--capture
           (lambda ()
             (tp-with-transaction
               (tp-signal-set source 2)
               'unobservable-body-value))))
        injected))
      (should (= (tp-signal-peek source) 1))
      (should (= (tp-signal-revision source) 0))
      (should (= (tp-surface-revision surface) old-revision))
      (with-current-buffer buffer
        (should (equal (buffer-string) "1"))))))

(ert-deftest tp-transaction-test-batch-validates-entries-and-owns-input ()
  "Batch preparation rejects invalid entries and owns mutable input."
  (should-error
   (tp--publication-batch-prepare
    :transaction-id 'transaction-a :batch-id 'batch-a
    :entries nil :participants [] :final-accept #'ignore)
   :type 'tp-publication-binding-error)
  (with-temp-buffer
    (let* ((mount-ids (list 'mount-a))
           (diff (list :replace (list 1 2)))
           (client-state (list :client (list 'candidate)))
           (entry (tp-transaction-test--entry
                   :mount-ids mount-ids
                   :diff diff
                   :client-state client-state))
           (entries (list entry))
           (batch (tp-transaction-test--batch entries)))
      (setcar mount-ids 'mutated-after-create)
      (setcar (plist-get diff :replace) 'mutated-after-create)
      (setcar (plist-get client-state :client) 'mutated-after-create)
      (setcar entries (tp-transaction-test--entry
                       :candidate-id 'replacement
                       :surface-id 'replacement-surface
                       :authority-token 'replacement-authority))
      (should (tp-publication-target-entry-p entry))
      (should (tp-publication-batch-candidate-p batch))
      (should (eq (tp-publication-batch-candidate-state batch) 'prepared))
      (should (equal (tp-publication-target-entry-mount-ids
                      (car (tp-publication-batch-candidate-entries batch)))
                     '(mount-a)))
      (should (equal (tp-publication-target-entry-diff entry)
                     '(:replace (1 2))))
      (should (equal (tp-publication-target-entry-client-state entry)
                     '(:client (candidate))))
      (should (eq (car (tp-publication-batch-candidate-entries batch)) entry))
      (should-error
       (tp-transaction-test--batch (list entry entry))
       :type 'tp-publication-binding-error))))

(ert-deftest tp-transaction-test-batch-is-one-shot-and-discard-is-prestage-only ()
  "Batch state is monotonic and has exactly one terminal disposition."
  (with-temp-buffer
    (let ((batch (tp-transaction-test--batch)))
      (should-error (tp--publication-batch-transition batch 'participants)
                    :type 'tp-publication-state-error)
      (dolist (state '(staged participants precommit final-accepting committed))
        (should (eq (tp--publication-batch-transition batch state) batch))
        (should (eq (tp-publication-batch-candidate-state batch) state)))
      (should-error (tp--publication-batch-transition batch 'committed)
                    :type 'tp-publication-state-error)
      (should-error (tp--publication-batch-discard batch 'too-late)
                    :type 'tp-publication-state-error))
    (let ((discarded (tp-transaction-test--batch)))
      (should-not (tp--publication-batch-discard discarded 'unused))
      (should (eq (tp-publication-batch-candidate-state discarded) 'discarded))
      (should-error (tp--publication-batch-discard discarded 'twice)
                    :type 'tp-publication-state-error)
      (should-error (tp--publication-batch-transition discarded 'staged)
                    :type 'tp-publication-state-error))))

(ert-deftest tp-transaction-test-v2-participant-is-single-structured-record ()
  "The v2 facade installs one structured record with no legacy bridge."
  (let (saved)
    (tp-with-transaction
      (tp-transaction-participate-v2 :key 'structured :stage #'ignore
                                     :rollback #'ignore)
      (setq saved (car tp--transaction-participants))
      (should (= (length tp--transaction-participants) 1))
      (should (eq (tp--transaction-participant-protocol saved) 'v2))
      (should (eq (tp--transaction-participant-state saved) 'prepared)))
    (should (eq (tp--transaction-participant-state saved) 'committed))))

(ert-deftest tp-transaction-test-v2-participant-stage-precommit-and-after-commit ()
  "A structured participant owns its journal and advances exactly once."
  (let ((tp-transaction-test--trace nil)
        (tp--transaction-participant-precommit-allowed-functions
         '(tp--transaction-test-participant-precommit))
        participant)
    (tp-with-transaction
      (tp--transaction-participate-v2
       :key 'structured
       :stage (lambda () (push 'stage tp-transaction-test--trace))
       :rollback (lambda () (push 'rollback tp-transaction-test--trace))
       :precommit 'tp--transaction-test-participant-precommit
       :after-commit (lambda () (push 'participant-after-commit
                                     tp-transaction-test--trace))
       :journal '(:owner old-state))
      (setq participant (car tp--transaction-participants)))
    (should (equal (nreverse tp-transaction-test--trace)
                   '(stage participant-precommit participant-after-commit)))
    (should (equal (tp--transaction-participant-journal participant)
                   '(:owner old-state)))
    (should (eq (tp--transaction-participant-state participant) 'committed))))

(ert-deftest tp-transaction-test-public-v2-participant-api-registers-v2-record ()
  "The public v2 API registers one v2 object on the sole live route."
  (let ((tp-transaction-test--trace nil)
        participant)
      (should
       (eq
        (tp-with-transaction
          (should
           (eq
            (tp-transaction-participate-v2
             :key 'public-v2
             :stage (lambda () (push 'stage tp-transaction-test--trace))
             :rollback (lambda () (push 'rollback tp-transaction-test--trace))
             :journal '(:owner public))
            'public-v2))
          (setq participant (car tp--transaction-participants))
          'body-result)
        'body-result))
      (should (equal tp-transaction-test--trace '(stage)))
      (should (eq (tp--transaction-participant-protocol participant) 'v2))
      (should (equal (tp--transaction-participant-journal participant)
                     '(:owner public)))
      (should (eq (tp--transaction-participant-state participant) 'committed))))

(ert-deftest tp-transaction-test-v2-participant-stage-fault-rolls-back-prior-only ()
  "A structured stage fault reverses only participants that entered staged."
  (let ((tp-transaction-test--trace nil)
        (injected '(tp-transaction-test-error :phase participant-stage)))
    (should
     (equal
      (tp-transaction-test--capture
       (lambda ()
         (tp-with-transaction
           (tp--transaction-participate-v2
            :key 'first
            :stage (lambda () (push 'stage-first tp-transaction-test--trace))
            :rollback (lambda () (push 'rollback-first
                                      tp-transaction-test--trace)))
           (tp--transaction-participate-v2
            :key 'second
            :stage (lambda ()
                     (push 'stage-second tp-transaction-test--trace)
                     (signal (car injected) (cdr injected)))
            :rollback (lambda () (push 'rollback-second
                                      tp-transaction-test--trace))))))
      injected))
    (should (equal (nreverse tp-transaction-test--trace)
                   '(stage-first stage-second rollback-second rollback-first)))))

(ert-deftest tp-transaction-test-final-marker-validates-registry-contract ()
  "Built-in marker registration validates owner, expectation, and payload."
  (tp-transaction-test--with-surface (buffer _surface source)
    (let ((target (vector 'old 'token-a 4)))
      (tp-with-transaction
        (tp-signal-set source 2)
        (apply #'tp--transaction-register-final-marker
               (tp-transaction-test--marker-arguments
                target [new] [old]))
        (should-error
         (apply #'tp--transaction-register-final-marker
                (tp-transaction-test--marker-arguments
                 target [new] [old]))
         :type 'tp-final-marker-error))
      (should (eq (aref target 0) 'new))
      (dolist (case '(operation expectation payload))
        (aset target 0 'old)
        (should-error
         (tp-with-transaction
           (tp-signal-set source (1+ (tp-signal-peek source)))
           (apply #'tp--transaction-register-final-marker
                  (pcase case
                    ('operation
                     (tp-transaction-test--marker-arguments
                      target [new] [old]
                      :owner-key 'bad-operation
                      :operation-key 'not-whitelisted))
                    ('expectation
                     (tp-transaction-test--marker-arguments
                      target [new] [old]
                      :owner-key 'bad-expectation
                      :expected-version
                      (tp--final-marker-expectation-create
                       :target target :index 2 :value 3)))
                    ('payload
                     (tp-transaction-test--marker-arguments
                      target [new] [old]
                      :owner-key 'bad-payload :slot-write-count 2)))))
         :type 'tp-final-marker-error)
        (should (eq (aref target 0) 'old))))))

(ert-deftest tp-transaction-test-public-final-marker-wrappers-share-contract ()
  "Public marker constructors and registration retain the bounded core rules."
  (tp-transaction-test--with-surface (buffer _surface source)
    (let ((target (vector 'detached 'token 0)))
      (tp-with-transaction
        (tp-signal-set source 2)
        (tp-transaction-register-final-marker
         :owner-key 'public-host
         :expected-token
         (tp-final-marker-expectation-create
          :target target :index 1 :value 'token)
         :expected-version
         (tp-final-marker-expectation-create
          :target target :index 2 :value 0)
         :next-values
         (vector
          (tp-final-marker-slot-write-create
           :target target :index 0 :value 'attached))
         :inverse-values
         (vector
          (tp-final-marker-slot-write-create
           :target target :index 0 :value 'detached))
         :slot-write-count 1
         :operation-key 'tp-vector-slots/v1))
      (should (eq (aref target 0) 'attached)))))

(ert-deftest tp-transaction-test-marker-partial-apply-restores-in-reverse ()
  "Partial marker apply restores applied owners before normal rollback."
  (tp-transaction-test--with-surface (buffer _surface source)
    (let* ((first (vector 'old 'token 1))
           (second (vector 'old 'token 1))
           (trace nil)
           (apply-one (symbol-function
                       'tp--transaction-apply-one-final-marker))
           (restore-one (symbol-function
                         'tp--transaction-restore-one-final-marker)))
      (cl-letf
          (((symbol-function 'tp--transaction-apply-one-final-marker)
            (lambda (marker)
              (funcall apply-one marker)
              (let ((owner (tp-final-accept-marker-owner-key marker)))
                (push (list 'apply owner) trace)
                (when (eq owner 'second-owner)
                  (signal 'tp-transaction-test-error
                          '(:phase marker-apply))))))
           ((symbol-function 'tp--transaction-restore-one-final-marker)
            (lambda (marker)
              (funcall restore-one marker)
              (push (list 'restore
                          (tp-final-accept-marker-owner-key marker))
                    trace))))
        (should-error
         (tp-with-transaction
           (tp-signal-set source 2)
           (apply #'tp--transaction-register-final-marker
                  (tp-transaction-test--marker-arguments
                   first [new] [old] :owner-key 'first-owner))
           (apply #'tp--transaction-register-final-marker
                  (tp-transaction-test--marker-arguments
                   second [new] [old] :owner-key 'second-owner)))
         :type 'tp-transaction-test-error))
      (should (eq (aref first 0) 'old))
      (should (eq (aref second 0) 'old))
      (should
       (equal (nreverse trace)
              '((apply first-owner) (apply second-owner)
                (restore second-owner) (restore first-owner)))))))

(ert-deftest tp-transaction-test-accept-fault-restores-all-markers-reverse ()
  "An accept fault reverses all applied markers before transaction rollback."
  (tp-transaction-test--with-surface (buffer _surface source)
    (let* ((first (vector 'old 'token 1))
           (second (vector 'old 'token 1))
           (trace nil)
           (apply-one (symbol-function
                       'tp--transaction-apply-one-final-marker))
           (restore-one (symbol-function
                         'tp--transaction-restore-one-final-marker)))
      (should-error
       (cl-letf
           (((symbol-function 'tp--transaction-apply-one-final-marker)
             (lambda (marker)
               (funcall apply-one marker)
               (push (list 'apply
                           (tp-final-accept-marker-owner-key marker))
                     trace)))
            ((symbol-function 'tp--transaction-restore-one-final-marker)
             (lambda (marker)
               (funcall restore-one marker)
               (push (list 'restore
                           (tp-final-accept-marker-owner-key marker))
                     trace)))
            ((symbol-function 'accept-change-group)
             (lambda (_group)
               (signal 'tp-transaction-test-error '(:phase accept)))))
         (tp-with-transaction
           (tp-signal-set source 2)
           (apply #'tp--transaction-register-final-marker
                  (tp-transaction-test--marker-arguments
                   first [new] [old] :owner-key 'first-owner))
           (apply #'tp--transaction-register-final-marker
                  (tp-transaction-test--marker-arguments
                   second [new] [old] :owner-key 'second-owner))))
       :type 'tp-transaction-test-error)
      (should (equal first [old token 1]))
      (should (equal second [old token 1]))
      (should
       (equal (nreverse trace)
              '((apply first-owner) (apply second-owner)
                (restore second-owner) (restore first-owner)))))))

(ert-deftest tp-transaction-test-success-outcome-is-side-channel-only ()
  "Committed evidence appears after accept without replacing BODY return."
  (tp-transaction-test--with-surface (buffer surface source)
    (let ((tp--last-transaction-outcome nil))
      (should (eq (tp-with-transaction
                    (tp-signal-set source 2)
                    'body-value)
                  'body-value))
      (should (tp-committed-success-outcome-p
               tp--last-transaction-outcome))
      (should-not (tp-publication-failure-outcome-p
                   tp--last-transaction-outcome))
      (tp-transaction-test--should-match-outcome-counts
       tp--last-transaction-outcome (list surface))
      (should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
      (should (plist-get tp--last-shadow-proof :equivalent))
      (should (plist-get tp--last-shadow-proof :outcome-equivalent))
      (should (= (plist-get tp--last-shadow-proof :entry-count) 1))
      (should (eq (plist-get
                   (tp--committed-success-outcome-snapshot
                    tp--last-transaction-outcome)
                   :tag)
                  'committed-success))
      (should-not (fboundp 'tp-committed-success-outcome-promote))
      (should-not (fboundp 'tp-committed-success-outcome-mutate)))))

(ert-deftest tp-transaction-test-failure-outcome-is-observational ()
  "Failure evidence preserves the primary condition and cannot pass success."
  (tp-transaction-test--with-surface (buffer surface source)
    (let ((tp--last-transaction-outcome nil)
          (old-text (with-current-buffer buffer (buffer-string)))
          (old-revision (tp-surface-revision surface))
          (injected '(tp-transaction-test-error :phase precommit))
          (tp-transaction-test--precommit-condition
           '(tp-transaction-test-error :phase precommit))
          (tp--transaction-precommit-functions
           '(tp--transaction-test-precommit-inject))
          (tp--transaction-precommit-allowed-functions
           '(tp--transaction-test-precommit-inject)))
      (should (equal (tp-transaction-test--capture
                      (lambda () (tp-signal-set source 2)))
                     injected))
      (should (tp-publication-failure-outcome-p
               tp--last-transaction-outcome))
      (should-not (tp-committed-success-outcome-p
                   tp--last-transaction-outcome))
      (should-not (tp--committed-success-outcome-valid-for-p
                   tp--last-transaction-outcome 'any-batch))
      (should (equal (plist-get tp--last-shadow-proof :phase) 'rollback))
      (should (plist-get tp--last-shadow-proof :equivalent))
      (should (plist-get tp--last-shadow-proof :outcome-equivalent))
      (should (= (plist-get tp--last-shadow-proof :entry-count) 1))
      (should (= (tp-surface-revision surface) old-revision))
      (with-current-buffer buffer
        (should (equal (buffer-string) old-text))))))

(ert-deftest tp-transaction-test-success-outcome-binding-rejects-replay ()
  "Outcome validation rejects a different candidate at the same revision."
  (with-temp-buffer
    (let* ((entry (tp-transaction-test--entry))
           (candidate
            (tp-transaction-test--set-batch-proof-fields
             (tp-transaction-test--batch (list entry)))))
      (dolist (state '(staged participants precommit final-accepting committed))
        (tp--publication-batch-transition candidate state))
      (let* ((outcome
              (tp--committed-success-outcome-finalize
               (tp--committed-success-outcome-draft
                candidate '(:text 1) '(:total 0.1) nil 0)))
             (replay-entry
              (tp-transaction-test--entry
               :candidate-id 'same-revision-different-candidate
               :authority-token 'different-authority))
             (replay
              (tp-transaction-test--set-batch-proof-fields
               (tp-transaction-test--batch (list replay-entry)))))
        (dolist (state
                 '(staged participants precommit final-accepting committed))
          (tp--publication-batch-transition replay state))
        (should (tp--committed-success-outcome-valid-for-p
                 outcome candidate 3))
        (should-not (tp--committed-success-outcome-valid-for-p
                     outcome replay 3))
        (should-not (tp--committed-success-outcome-valid-for-p
                     outcome candidate 4))
        (setcar (cdr (tp-committed-success-outcome-operation-counts outcome))
                2)
        (should-not (tp--committed-success-outcome-valid-for-p
                     outcome candidate 3))
        (should (equal (buffer-string) ""))))))

(ert-deftest tp-transaction-test-outcome-rejects-cross-surface-and-mount-replay ()
  "Exact replay rejects cross-surface and different-mount candidates purely."
  (let ((first-buffer (generate-new-buffer " *tp-replay-first*"))
        (second-buffer (generate-new-buffer " *tp-replay-second*"))
        (state (vector 'unchanged)))
    (unwind-protect
        (progn
          (with-current-buffer first-buffer (insert "first"))
          (with-current-buffer second-buffer (insert "second"))
          (let* ((entry
                  (with-current-buffer first-buffer
                    (tp-transaction-test--entry :buffer first-buffer)))
                 (candidate
                  (tp-transaction-test--set-batch-proof-fields
                   (tp-transaction-test--batch (list entry)))))
            (dolist (next
                     '(staged participants precommit final-accepting committed))
              (tp--publication-batch-transition candidate next))
            (let* ((outcome
                    (tp--committed-success-outcome-finalize
                     (tp--committed-success-outcome-draft
                      candidate '(:text 1) '(:total 0.1) nil 0)))
                   (cross-entry
                    (with-current-buffer second-buffer
                      (tp-transaction-test--entry
                       :surface-id 'surface-b :buffer second-buffer
                       :authority-token 'entry-authority-b)))
                   (mount-entry
                    (with-current-buffer first-buffer
                      (tp-transaction-test--entry
                       :mount-ids '(different-mount))))
                   (cross
                    (tp-transaction-test--set-batch-proof-fields
                     (tp-transaction-test--batch (list cross-entry))))
                   (mount
                    (tp-transaction-test--set-batch-proof-fields
                     (tp-transaction-test--batch (list mount-entry)))))
              (dolist (replay (list cross mount))
                (dolist (next
                         '(staged participants precommit
                           final-accepting committed))
                  (tp--publication-batch-transition replay next))
                (should-not
                 (tp--committed-success-outcome-valid-for-p
                  outcome replay 3)))
              (should (equal state [unchanged]))
              (with-current-buffer first-buffer
                (should (equal (buffer-string) "first")))
              (with-current-buffer second-buffer
                (should (equal (buffer-string) "second"))))))
      (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
      (when (buffer-live-p second-buffer) (kill-buffer second-buffer)))))

(ert-deftest tp-transaction-test-multifragment-mount-ids-are-stable-in-outcome ()
  "One logical object's distinct fragment mounts retain exact outcome IDs."
  (let ((buffer (generate-new-buffer " *tp-multifragment-outcome*"))
        (left "A") (right "C") logical)
    (unwind-protect
        (let* ((producer
                (lambda (context)
                  (let* ((root (tp-object-ensure context nil 'root 'group))
                         (left-object
                          (tp-object-ensure context root 'left 'text))
                         (gap-object
                          (tp-object-ensure context root 'gap 'text))
                         (right-object
                          (tp-object-ensure context root 'right 'text)))
                    (setq logical
                          (tp-object-ensure context root 'logical 'item))
                    (tp-object-retain context logical)
                    (tp-object-attach-fragment
                     context logical left-object '(:slot left))
                    (tp-object-attach-fragment
                     context logical right-object '(:slot right))
                    (ignore gap-object))
                  (tp-surface-plan-create
                   :key 'root :kind 'group :capability 'content
                   :children
                   (list
                    (tp-surface-plan-create
                     :key 'left :kind 'text :text left :capability 'content)
                    (tp-surface-plan-create
                     :key 'gap :kind 'text :text "|" :capability 'content)
                    (tp-surface-plan-create
                     :key 'right :kind 'text :text right
                     :capability 'content)))))
               (surface
                (tp-surface-mount buffer producer '(:capability content)))
               (before
                (mapcar #'tp--ensure-surface-mount-id
                        (cl-remove-if-not
                         (lambda (mount)
                           (eq (tp--surface-mount-object mount) logical))
                         (tp--surface-mounts surface)))))
          (should (= (length before) 2))
          (should-not (= (car before) (cadr before)))
          (setq left "LEFT" right "RIGHT")
          (tp-surface-update-scoped surface (list logical) producer)
          (let* ((after
                  (mapcar #'tp--ensure-surface-mount-id
                          (cl-remove-if-not
                           (lambda (mount)
                             (eq (tp--surface-mount-object mount) logical))
                           (tp--surface-mounts surface))))
                 (entry (car (tp-committed-success-outcome-entries
                              tp--last-transaction-outcome)))
                 (outcome-ids
                  (tp-publication-outcome-entry-mount-ids entry)))
            (should (equal after before))
            (dolist (id before)
              (should (memq id outcome-ids)))
            (tp-transaction-test--should-match-outcome-counts
             tp--last-transaction-outcome (list surface))))
      (when (buffer-live-p buffer) (kill-buffer buffer)))))

(ert-deftest tp-transaction-test-candidates-remain-invisible-until-staged ()
  "Preparing a candidate does not mutate any live buffer or revision."
  (tp-transaction-test--with-surface (buffer surface source)
    (let ((text (with-current-buffer buffer (buffer-string)))
          (revision (tp-surface-revision surface)))
      (with-current-buffer buffer
        (tp-transaction-test--batch
         (list (tp-transaction-test--entry
                :surface-id (tp--surface-id surface)
                :buffer buffer
                :old-revision revision
                :new-revision (1+ revision)))))
      (should (= (tp-surface-revision surface) revision))
      (with-current-buffer buffer
        (should (equal (buffer-string) text))))))

(ert-deftest tp-transaction-test-v2-is-multisurface-and-single-writer ()
  "The v2 artifacts cover all surfaces while each live writer runs once."
  (let* ((source (tp-signal-create 1))
         (producer (tp-transaction-test--producer source))
         (first-buffer (generate-new-buffer " *tp-transaction-first*"))
         (second-buffer (generate-new-buffer " *tp-transaction-second*"))
         (first (tp-surface-mount first-buffer producer '(:capability content)))
         (second (tp-surface-mount second-buffer producer '(:capability content)))
         (calls (make-hash-table :test #'eq))
         (writer (symbol-function 'tp--publish-one-surface))
         (tp--last-transaction-outcome nil))
    (unwind-protect
        (cl-letf (((symbol-function 'tp--publish-one-surface)
                   (lambda (prepared)
                     (let ((surface (tp--prepared-surface-surface prepared)))
                       (puthash surface (1+ (gethash surface calls 0)) calls))
                     (funcall writer prepared))))
          (tp-signal-set source 2)
          (should (= (gethash first calls 0) 1))
          (should (= (gethash second calls 0) 1))
          (should (tp-committed-success-outcome-p
                   tp--last-transaction-outcome))
          (tp-transaction-test--should-match-outcome-counts
           tp--last-transaction-outcome (list first second))
          (should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
          (should (plist-get tp--last-shadow-proof :equivalent))
          (should (plist-get tp--last-shadow-proof :outcome-equivalent))
          (should (= (plist-get tp--last-shadow-proof :entry-count) 2))
          (should (integerp
                   (tp-committed-success-outcome-mapping-generation
                    tp--last-transaction-outcome)))
          (should (= (length (tp-committed-success-outcome-entries
                              tp--last-transaction-outcome))
                     2))
          (dolist (entry (tp-committed-success-outcome-entries
                          tp--last-transaction-outcome))
            (should (= (tp-publication-outcome-entry-new-revision entry)
                       (1+ (tp-publication-outcome-entry-old-revision entry))))
            (should (= (tp-publication-outcome-entry-mapping-generation entry)
                       (tp-committed-success-outcome-mapping-generation
                        tp--last-transaction-outcome)))))
      (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
      (when (buffer-live-p second-buffer) (kill-buffer second-buffer))
      (when (tp-signal-live-p source) (tp-signal-dispose source)))))

(ert-deftest tp-transaction-test-canonical-artifact-mismatch-is-diagnostic ()
  "A postcommit canonical artifact mismatch is detected and contained."
  (tp-transaction-test--with-surface (buffer surface source)
    (let ((current-artifact (symbol-function 'tp--shadow-current-artifact)))
      (cl-letf (((symbol-function 'tp--shadow-current-artifact)
                 (lambda (target)
                   (let ((artifact (funcall current-artifact target)))
                     (plist-put artifact :revision
                                (1+ (plist-get artifact :revision)))))))
        (tp-signal-set source 2))
      (should (= (tp-signal-peek source) 2))
      (should (= (tp-surface-revision surface) 2))
      (with-current-buffer buffer
        (should (equal (buffer-string) "2")))
      (should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
      (should-not (plist-get tp--last-shadow-proof :equivalent))
      (should (plist-get tp--last-shadow-proof :outcome-equivalent))
      (should (= (plist-get tp--last-shadow-proof :entry-count) 1))
      (should
       (cl-some
        (lambda (entry)
          (and (eq (car entry) 'shadow-proof)
               (eq (cadr entry) 'commit)))
        tp--last-transaction-diagnostics)))))

(ert-deftest tp-transaction-test-zero-surface-does-not-create-batch-or-outcome ()
  "Pure, semantic and external-only transactions stay outside batch API."
  (let ((tp--last-transaction-outcome 'sentinel)
        captured-batch captured-outcome)
    (should (eq (tp-with-transaction
                  (setq captured-batch tp--transaction-publication-batch
                        captured-outcome tp--transaction-outcome)
                  'pure-result)
                'pure-result))
    (should-not captured-batch)
    (should-not captured-outcome)
    (should-not tp--last-transaction-outcome)
    (tp-with-transaction
      (tp-transaction-participate-v2 :key 'external-only
                                     :stage #'ignore :rollback #'ignore))
    (should-not tp--last-transaction-outcome)))

(ert-deftest tp-transaction-test-unobserved-signal-excludes-publication-batch ()
  "An unobserved semantic signal commit creates no publication evidence."
  (let ((signal (tp-signal-create 1))
        (begin-batch (symbol-function 'tp--transaction-begin-publication-batch))
        (batch-calls 0))
    (unwind-protect
        (cl-letf (((symbol-function 'tp--transaction-begin-publication-batch)
                   (lambda (&rest arguments)
                     (cl-incf batch-calls)
                     (apply begin-batch arguments))))
          (tp-signal-set signal 2)
          (should (= (tp-signal-peek signal) 2))
          (should (= (tp-signal-revision signal) 1))
          (should (= batch-calls 0))
          (should-not tp--last-transaction-outcome))
      (when (tp-signal-live-p signal) (tp-signal-dispose signal)))))

(ert-deftest tp-transaction-test-surface-unmount-excludes-publication-batch ()
  "Surface teardown uses its external path without batch or outcome evidence."
  (let* ((buffer (generate-new-buffer " *tp-unmount-exclusion*"))
         (surface
          (tp-surface-mount
           buffer (tp-transaction-test--leaf "mounted")
           '(:capability content)))
         (begin-batch (symbol-function 'tp--transaction-begin-publication-batch))
         (batch-calls 0))
    (unwind-protect
        (progn
          (setq tp--last-transaction-outcome nil)
          (cl-letf
              (((symbol-function 'tp--transaction-begin-publication-batch)
                (lambda (&rest arguments)
                  (cl-incf batch-calls)
                  (apply begin-batch arguments))))
            (tp-surface-unmount surface))
          (should (= batch-calls 0))
          (should-not tp--last-transaction-outcome)
          (should-not (tp-surface-live-p surface))
          (with-current-buffer buffer
            (should (equal (buffer-string) ""))))
      (when (buffer-live-p buffer) (kill-buffer buffer)))))

(ert-deftest tp-transaction-test-output-equal-does-not-create-batch-or-outcome ()
  "A recompute with no surface artifact change stays outside batch API."
  (let* ((buffer (generate-new-buffer " *tp-transaction-output-equal*"))
         (source (tp-signal-create 1))
         (surface
          (tp-surface-mount
           buffer
           (lambda (context)
             (tp-object-ensure context nil 'root 'text)
             (tp-signal-read source)
             (tp-transaction-test--leaf "constant"))
           '(:capability content)))
         (revision (tp-surface-revision surface))
         (tp--last-transaction-outcome 'sentinel)
         captured-batch)
    (unwind-protect
        (progn
          (tp-with-transaction
            (tp-signal-set source 2)
            (setq captured-batch tp--transaction-publication-batch))
          (should-not captured-batch)
          (should-not tp--last-transaction-outcome)
          (should (= (tp-surface-revision surface) revision))
          (with-current-buffer buffer
            (should (equal (buffer-string) "constant"))))
      (when (buffer-live-p buffer) (kill-buffer buffer))
      (when (tp-signal-live-p source) (tp-signal-dispose source)))))

(ert-deftest tp-transaction-test-live-candidate-is-body-invisible-and-outcome-cell-separated ()
  "The body sees old live state while its retained cell receives evidence."
  (tp-transaction-test--with-surface (buffer surface source)
    (let ((old-revision (tp-surface-revision surface))
          outcome-cell body-batch body-text body-revision)
      (should
       (eq
        (tp-with-transaction
          (tp-signal-set source 2)
          (setq outcome-cell (tp--transaction-current-outcome-cell)
                body-batch tp--transaction-publication-batch
                body-text (with-current-buffer buffer (buffer-string))
                body-revision (tp-surface-revision surface))
          'body-result)
        'body-result))
      (should-not body-batch)
      (should (equal body-text "1"))
      (should (= body-revision old-revision))
      (should (vectorp outcome-cell))
      (should (= (length outcome-cell) 1))
      (should (tp-committed-success-outcome-p (aref outcome-cell 0)))
      (should (eq (aref outcome-cell 0) tp--last-transaction-outcome))
      (should (= (tp-surface-revision surface) (1+ old-revision)))
      (with-current-buffer buffer
        (should (equal (buffer-string) "2"))))))

(ert-deftest tp-transaction-test-scoped-content-v2-publication ()
  "Scoped content artifacts equal the single committed writer result."
  (let ((buffer (generate-new-buffer " *tp-transaction-scoped*"))
        (middle "B")
        (middle-face 'bold)
        middle-object)
    (unwind-protect
        (let* ((producer
                (lambda (context)
                  (let ((root (tp-object-ensure context nil 'root 'group)))
                    (tp-object-ensure context root 'left 'text)
                    (setq middle-object
                          (tp-object-ensure context root 'middle 'text))
                    (tp-object-ensure context root 'right 'text))
                  (tp-surface-plan-create
                   :key 'root :kind 'group :capability 'content
                   :children
                   (list
                    (tp-surface-plan-create
                     :key 'left :kind 'text :text "A"
                     :capability 'content)
                    (tp-surface-plan-create
                     :key 'middle :kind 'text :text middle
                     :props (list 'face middle-face)
                     :capability 'content)
                    (tp-surface-plan-create
                     :key 'right :kind 'text :text "C"
                     :capability 'content)))))
               (surface
                (tp-surface-mount buffer producer '(:capability content)))
               (revision (tp-surface-revision surface)))
          (setq middle "LONG"
                middle-face 'italic)
          (tp-surface-update-scoped
           surface (list middle-object) producer)
          (should (= (tp-surface-revision surface) (1+ revision)))
          (with-current-buffer buffer
            (should (equal (buffer-string) "ALONGC"))
            (should (eq (get-text-property 2 'face) 'italic)))
          (should (tp-committed-success-outcome-p
                   tp--last-transaction-outcome))
          (tp-transaction-test--should-match-outcome-counts
           tp--last-transaction-outcome (list surface)))
      (when (buffer-live-p buffer) (kill-buffer buffer)))))

(ert-deftest tp-transaction-test-properties-only-v2-publication ()
  "Properties-only artifacts equal live properties without replacing text."
  (let ((buffer (generate-new-buffer " *tp-transaction-properties*"))
        (value 'bold))
    (unwind-protect
        (with-current-buffer buffer
          (insert "host")
          (let* ((anchor (tp-range-anchor-create buffer 1 5))
                 (producer
                  (lambda (context)
                    (let ((object
                           (tp-object-ensure context nil 'root 'range)))
                      (tp-object-attach-range context object anchor))
                    (tp-surface-plan-create
                     :key 'root :kind 'range :props (list 'face value)
                     :capability 'properties)))
                 (surface
                  (tp-surface-mount
                   buffer producer '(:capability properties)))
                 (revision (tp-surface-revision surface)))
            (setq value 'italic)
            (tp-surface-update surface producer)
            (should (equal (buffer-string) "host"))
            (should (eq (get-text-property 2 'face) 'italic))
            (should (= (tp-surface-revision surface) (1+ revision)))
            (should (tp-committed-success-outcome-p
                     tp--last-transaction-outcome))
            (tp-transaction-test--should-match-outcome-counts
             tp--last-transaction-outcome (list surface))))
      (when (buffer-live-p buffer) (kill-buffer buffer)))))

(ert-deftest tp-transaction-test-property-surface-fault-matrix-restores-exact-state ()
  "Every late fault restores exact multi-surface property publication state."
  (dolist (phase '(second-surface participant precommit final-accept))
    (let* ((source (tp-signal-create 1))
           (first-buffer (generate-new-buffer " *tp-property-fault-first*"))
           (second-buffer
            (generate-new-buffer " *tp-property-fault-second*"))
           first-anchor second-anchor first second first-state second-state
           (injected
            (list 'tp-transaction-test-error :phase phase :payload '(raw))))
      (unwind-protect
          (progn
            (with-current-buffer first-buffer
              (insert "first")
              (goto-char 3)
              (setq first-anchor
                    (tp-range-anchor-create first-buffer 1 (point-max))))
            (with-current-buffer second-buffer
              (insert "second")
              (goto-char 4)
              (setq second-anchor
                    (tp-range-anchor-create second-buffer 1 (point-max))))
            (setq first
                  (with-current-buffer first-buffer
                    (tp-surface-mount
                     first-buffer
                     (tp-transaction-test--property-producer
                      source first-anchor)
                     '(:capability properties)))
                  second
                  (with-current-buffer second-buffer
                    (tp-surface-mount
                     second-buffer
                     (tp-transaction-test--property-producer
                      source second-anchor)
                     '(:capability properties)))
                  first-state (tp-transaction-test--property-state first)
                  second-state (tp-transaction-test--property-state second))
            (let ((tp--surface-publication-step-function
                   (and
                    (eq phase 'second-surface)
                    (lambda (step surface)
                      (when (and (eq step 'client-state)
                                 (eq surface second))
                        (signal (car injected) (cdr injected))))))
                  (tp-transaction-test--precommit-condition
                   (and (eq phase 'precommit) injected))
                  (tp--transaction-precommit-functions
                   (if (eq phase 'precommit)
                       '(tp--transaction-test-precommit-inject)
                     tp--transaction-precommit-functions))
                  (tp--transaction-precommit-allowed-functions
                   (if (eq phase 'precommit)
                       '(tp--transaction-test-precommit-inject)
                     tp--transaction-precommit-allowed-functions)))
              (should
               (equal
                (cl-letf
                    (((symbol-function 'accept-change-group)
                      (let ((accept (symbol-function 'accept-change-group)))
                        (lambda (group)
                          (if (eq phase 'final-accept)
                              (signal (car injected) (cdr injected))
                            (funcall accept group))))))
                  (tp-transaction-test--capture
                   (lambda ()
                     (tp-with-transaction
                       (when (eq phase 'participant)
                        (tp-transaction-participate-v2
                         :key 'property-fault-participant
                         :stage (lambda ()
                                  (signal (car injected) (cdr injected)))
                         :rollback #'ignore))
                       (tp-signal-set source 2)))))
                injected)))
            (should (= (tp-signal-peek source) 1))
            (should (= (tp-signal-revision source) 0))
            (tp-transaction-test--should-match-property-state
             first first-state)
            (tp-transaction-test--should-match-property-state
             second second-state)
            (with-current-buffer first-buffer
              (should (eq (get-text-property 2 'face) 'bold)))
            (with-current-buffer second-buffer
              (should (eq (get-text-property 2 'face) 'bold)))
            (should (tp-publication-failure-outcome-p
                     tp--last-transaction-outcome)))
        (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
        (when (buffer-live-p second-buffer) (kill-buffer second-buffer))
        (when (tp-signal-live-p source) (tp-signal-dispose source))))))

(ert-deftest tp-transaction-test-final-accept-source-uses-v2-binding ()
  "V2 validates the candidate final accept binding before publication."
  (let* ((structured-buffer (generate-new-buffer " *tp-final-structured*"))
         (initial (tp-transaction-test--leaf "old"))
         (next (tp-transaction-test--leaf "new"))
         (structured (tp-surface-mount structured-buffer initial
                                       '(:capability content)))
         (sync (symbol-function 'tp--transaction-sync-publication-batch)))
    (unwind-protect
        (cl-letf (((symbol-function 'tp--transaction-sync-publication-batch)
                   (lambda ()
                     (funcall sync)
                     (when tp--transaction-publication-batch
                       (setf (tp-publication-batch-candidate-final-accept
                              tp--transaction-publication-batch)
                             #'ignore)))))
          (should-error (tp-surface-update structured next)
                        :type 'tp-publication-binding-error)
          (with-current-buffer structured-buffer
            (should (equal (buffer-string) "old")))
          (should (tp-publication-failure-outcome-p
                   tp--last-transaction-outcome)))
      (when (buffer-live-p structured-buffer) (kill-buffer structured-buffer))
      )))

(ert-deftest tp-transaction-test-structured-batch-owns-surface-stage-once ()
  "Structured execution enters the candidate seam and writes each entry once."
  (let* ((source (tp-signal-create 1))
         (producer (tp-transaction-test--producer source))
         (first-buffer (generate-new-buffer " *tp-structured-first*"))
         (second-buffer (generate-new-buffer " *tp-structured-second*"))
         (first (tp-surface-mount first-buffer producer '(:capability content)))
         (second (tp-surface-mount second-buffer producer '(:capability content)))
         (execute (symbol-function 'tp--publication-batch-execute-stage))
         (writer (symbol-function 'tp--publish-one-surface))
         (calls (make-hash-table :test #'eq))
         (stage-calls 0))
    (unwind-protect
        (cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
                   (lambda (candidate)
                     (cl-incf stage-calls)
                     (funcall execute candidate)))
                  ((symbol-function 'tp--publish-one-surface)
                   (lambda (prepared)
                     (let ((surface (tp--prepared-surface-surface prepared)))
                       (puthash surface (1+ (gethash surface calls 0)) calls))
                     (funcall writer prepared))))
          (tp-signal-set source 2)
          (should (= stage-calls 1))
          (should (= (gethash first calls 0) 1))
          (should (= (gethash second calls 0) 1))
          (should (tp-committed-success-outcome-p tp--last-transaction-outcome)))
      (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
      (when (buffer-live-p second-buffer) (kill-buffer second-buffer))
      (when (tp-signal-live-p source) (tp-signal-dispose source)))))

(ert-deftest tp-transaction-test-public-v2-participant-stages-once-from-batch ()
  "The public v2 participant is one structured participant in the batch vector."
  (tp-transaction-test--with-surface (buffer _surface source)
    (let ((stages 0) captured participant)
      (tp-with-transaction
        (tp-transaction-participate-v2
         :key 'public-v2
         :stage (lambda ()
           (cl-incf stages)
           (setq captured tp--transaction-publication-batch
                 participant
                 (aref (tp-publication-batch-candidate-participants
                        tp--transaction-publication-batch)
                       0)))
         :rollback #'ignore)
        (tp-signal-set source 2))
      (should (= stages 1))
      (should (tp-publication-batch-candidate-p captured))
      (should (eq (tp--transaction-participant-protocol participant) 'v2))
      (should (eq (tp--transaction-participant-state participant) 'committed)))))

(ert-deftest tp-transaction-test-batch-rejects-foreign-stage-capability ()
  "A publication batch accepts only the closed package-owned stage seam."
  (should-error
   (tp--publication-batch-prepare
    :transaction-id 'transaction-a
    :batch-id 'batch-a
    :entries (list (tp-transaction-test--entry))
    :participants []
    :journals nil
    :stage-entries #'ignore
    :final-accept #'ignore)
   :type 'tp-publication-binding-error))

(ert-deftest tp-transaction-test-participant-vector-drift-rolls-back-surfaces ()
  "Registration drift after batch binding fails fast and restores live state."
  (tp-transaction-test--with-surface (buffer surface source)
    (let ((revision (tp-surface-revision surface))
          (stage (symbol-function 'tp--publication-batch-execute-stage)))
      (cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
                 (lambda (candidate)
                   (tp-transaction-participate-v2 :key 'late
                                                  :stage #'ignore
                                                  :rollback #'ignore)
                   (funcall stage candidate))))
        (should-error (tp-signal-set source 2)
                      :type 'tp-publication-binding-error))
      (should (= (tp-signal-peek source) 1))
      (should (= (tp-surface-revision surface) revision))
      (with-current-buffer buffer
        (should (equal (buffer-string) "1"))))))

(ert-deftest tp-transaction-test-ordinary-update-success-has-zero-markers ()
  "An ordinary publication records zero final authority markers."
  (tp-transaction-test--with-surface (buffer _surface source)
    (tp-signal-set source 2)
    (should (tp-committed-success-outcome-p tp--last-transaction-outcome))
    (should (= (tp-committed-success-outcome-marker-count
                tp--last-transaction-outcome)
               0))
    (let ((timings
           (tp-committed-success-outcome-phase-timings
            tp--last-transaction-outcome)))
      (dolist (phase '(body recompute publication participants
                           precommit signal-commit))
        (should (numberp (alist-get phase timings)))
        (should (>= (alist-get phase timings) 0.0))))))

(ert-deftest tp-transaction-test-final-marker-global-count-bound ()
  "The fixed marker registry rejects one owner beyond its global bound."
  (tp-transaction-test--with-surface (buffer _surface source)
    (let (targets)
      (dotimes (_ tp--final-marker-max-count)
        (push (vector 'old 'token 1) targets))
      (setq targets (nreverse targets))
      (tp-with-transaction
        (tp-signal-set source 2)
        (cl-loop for target in targets
                 for index from 0
                 do
                 (apply #'tp--transaction-register-final-marker
                        (tp-transaction-test--marker-arguments
                         target [new] [old]
                         :owner-key (intern (format "owner-%d" index)))))
        (let ((extra (vector 'old 'token 1)))
          (should-error
           (apply #'tp--transaction-register-final-marker
                  (tp-transaction-test--marker-arguments
                   extra [new] [old] :owner-key 'owner-overflow))
           :type 'tp-final-marker-error)
          (should (eq (aref extra 0) 'old))))
      (dolist (target targets)
        (should (eq (aref target 0) 'new))))))

(ert-deftest tp-transaction-test-final-marker-aggregate-slot-write-bound ()
  "Real three-slot and one-slot payloads obey the aggregate write bound."
  (tp-transaction-test--with-surface (buffer _surface source)
    (let ((three-slot-targets
           (cl-loop repeat 5 collect
                    (vector 'old 'old 'old 'token 1)))
          (one-slot-target (vector 'old 'token 1))
          (overflow-target (vector 'old 'token 1)))
      (tp-with-transaction
        (tp-signal-set source 2)
        (cl-loop for target in three-slot-targets
                 for index from 0
                 do
                 (apply #'tp--transaction-register-final-marker
                        (tp-transaction-test--marker-arguments
                         target [new new new] [old old old]
                         :owner-key
                         (intern (format "three-slot-owner-%d" index)))))
        (apply #'tp--transaction-register-final-marker
               (tp-transaction-test--marker-arguments
                one-slot-target [new] [old] :owner-key 'one-slot-owner))
        (should-error
         (apply #'tp--transaction-register-final-marker
                (tp-transaction-test--marker-arguments
                 overflow-target [new] [old] :owner-key 'slot-overflow))
         :type 'tp-final-marker-error))
      (dolist (target three-slot-targets)
        (should (equal (seq-subseq target 0 3) [new new new])))
      (should (eq (aref one-slot-target 0) 'new))
      (should (eq (aref overflow-target 0) 'old)))))

(ert-deftest tp-transaction-test-marker-restore-faults-exhaust-all-markers ()
  "Restore error, quit, and throw cannot skip markers or rollback."
  (dolist (kind '(error quit throw))
    (tp-transaction-test--with-surface (buffer surface source)
      (let* ((targets
              (list (vector 'old 'token 1)
                    (vector 'old 'token 1)
                    (vector 'old 'token 1)))
             (revision (tp-surface-revision surface))
             (restore-one (symbol-function
                           'tp--transaction-restore-one-final-marker))
             (injected '(tp-transaction-test-error :phase accept))
             result)
        (cl-letf
            (((symbol-function 'tp--transaction-restore-one-final-marker)
              (lambda (marker)
                (funcall restore-one marker)
                (when (eq (tp-final-accept-marker-owner-key marker)
                          'middle-owner)
                  (pcase kind
                    ('error
                     (signal 'tp-transaction-test-error
                             '(:phase marker-restore)))
                    ('quit (signal 'quit nil))
                    ('throw
                     (throw 'tp-transaction-test-restore-throw kind))))))
             ((symbol-function 'accept-change-group)
              (lambda (_group) (signal (car injected) (cdr injected)))))
          (let ((transaction
                 (lambda ()
                   (tp-with-transaction
                     (tp-signal-set source 2)
                     (cl-loop
                      for target in targets
                      for owner in '(first-owner middle-owner last-owner)
                      do
                      (apply #'tp--transaction-register-final-marker
                             (tp-transaction-test--marker-arguments
                              target [new] [old] :owner-key owner)))))))
            (setq result
                  (if (eq kind 'throw)
                      (catch 'tp-transaction-test-restore-throw
                        (funcall transaction)
                        'not-thrown)
                    (tp-transaction-test--capture transaction)))))
        (if (eq kind 'throw)
            (should (eq result 'throw))
          (should (equal (seq-take result 3) injected))
          (should (tp--transaction-condition-trailer
                   result :rollback-failures)))
        (dolist (target targets)
          (should (equal target [old token 1])))
        (should (= (tp-signal-peek source) 1))
        (should (= (tp-signal-revision source) 0))
        (should (= (tp-surface-revision surface) revision))
        (with-current-buffer buffer
          (should (equal (buffer-string) "1")))))))

(ert-deftest tp-transaction-test-participant-after-commit-fault-is-contained ()
  "After-commit participant failure is diagnostic and stays committed."
  (let (participant)
    (should
     (eq
      (tp-with-transaction
        (tp--transaction-participate-v2
         :key 'contained-after-commit
         :stage #'ignore
         :rollback (lambda ()
                     (error "Committed participant must not roll back"))
         :after-commit
         (lambda ()
           (signal 'tp-transaction-test-error '(:phase after-commit))))
        (setq participant (car tp--transaction-participants))
        'body-result)
      'body-result))
    (should (eq (tp--transaction-participant-state participant) 'committed))
    (should
     (cl-some
      (lambda (entry)
        (and (eq (car entry) 'after-commit)
             (equal (caddr entry)
                    '(tp-transaction-test-error :phase after-commit))))
      tp--last-transaction-diagnostics))))

(ert-deftest tp-transaction-test-marker-nonlocal-throw-restores-state ()
  "Marker apply and accept throws reverse authority and live publication."
  (dolist (phase '(apply accept))
    (tp-transaction-test--with-surface (buffer surface source)
      (let* ((target (vector 'old 'token 1))
             (revision (tp-surface-revision surface))
             (apply-one (symbol-function
                         'tp--transaction-apply-one-final-marker))
             (accept (symbol-function 'accept-change-group)))
        (should
         (eq
          (catch 'tp-transaction-test-nonlocal
            (cl-letf (((symbol-function
                        'tp--transaction-apply-one-final-marker)
                       (lambda (marker)
                         (funcall apply-one marker)
                         (when (eq phase 'apply)
                           (throw 'tp-transaction-test-nonlocal phase))))
                      ((symbol-function 'accept-change-group)
                       (lambda (group)
                         (if (eq phase 'accept)
                             (throw 'tp-transaction-test-nonlocal phase)
                           (funcall accept group)))))
              (tp-with-transaction
                (tp-signal-set source 2)
                (apply #'tp--transaction-register-final-marker
                       (tp-transaction-test--marker-arguments
                        target [new] [old] :owner-key phase))))
            'not-thrown)
          phase))
        (should (equal target [old token 1]))
        (should (= (tp-signal-peek source) 1))
        (should (= (tp-signal-revision source) 0))
        (should (= (tp-surface-revision surface) revision))
        (with-current-buffer buffer
          (should (equal (buffer-string) "1")))))))

(ert-deftest tp-transaction-test-manifest-advertises-v2-only-contract ()
  "The manifest advertises v2 without any legacy route capability."
  (should (eq tp-transaction-protocol 'tp-transaction-protocol-v2))
  (let ((manifest (tp-runtime-manifest)))
    (should (equal (plist-get manifest :version) "2.0.0"))
    (should (eq (plist-get manifest :transaction-protocol)
                'tp-transaction-protocol-v2))
    (should (eq (plist-get manifest :structured-participant-api)
                'tp-transaction-participate-v2))
    (should (plist-get manifest :batch-artifacts))
    (should (plist-get manifest :batch-execute))
    (should (plist-get manifest :single-live-writer))
    (dolist (property '(:execution-route :execution-default :execution-routes
                        :route-option :batch-execution :v1-adapter
                        :v1-rollback-route))
      (should-not (plist-member manifest property)))))

(ert-deftest tp-transaction-test-v1-public-controls-are-absent ()
  "TP 2.0 exposes no executable v1 facade or route switches."
  (should-not (fboundp 'tp-transaction-participate))
  (should-not (fboundp 'tp--publish-transaction-participants))
  (should-not (fboundp 'tp--surface-stage-v1-prepared))
  (should-not (fboundp 'tp--transaction-validate-execution-route))
  (should-not (boundp 'tp-transaction-execution-route))
  (should-not (boundp 'tp--transaction-artifact-mode)))

(provide 'tp-transaction-tests)

;;; tp-transaction-tests.el ends here