tp/tests/tp-surface-tests.el

;;; tp-surface-tests.el --- Tests for TP retained surfaces -*- lexical-binding: t; -*-

;; Copyright (C) 2026 Geekinney

;;; Commentary:

;; Contract tests for TP 1.0 plans, objects, mounts, and publication.

;;; Code:

(require 'ert)
(require 'tp-surface)

(defmacro tp-surface-test--with-buffer (&rest body)
  "Run BODY in a temporary live buffer."
  (declare (indent 0) (debug t))
  `(let ((buffer (generate-new-buffer " *tp-surface-test*")))
     (unwind-protect
         (with-current-buffer buffer ,@body)
       (when (buffer-live-p buffer) (kill-buffer buffer)))))

(defun tp-surface-test--leaf (key text &optional props)
  "Return a content leaf with KEY, TEXT, and PROPS."
  (tp-surface-plan-create
   :key key :kind 'text :text text :props props :capability 'content))

(defun tp-surface-test--producer (signal)
  "Return a retained content producer reading SIGNAL."
  (lambda (context)
    (tp-object-ensure context nil 'root 'text)
    (tp-surface-result-create
     (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--commit-batch-update
    (surface root batch client-state before-stage &optional project-coordinates)
  "Update SURFACE through BATCH after calling BEFORE-STAGE with its entry.
ROOT is the retained object and CLIENT-STATE is transferred by its active
prepare context.  PROJECT-COORDINATES asks TP to map existing mounts through
the batch instead of retaining their unchanged coordinates."
  (let ((execute (symbol-function 'tp--publication-batch-execute-stage)))
    (cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
               (lambda (candidate)
                 (let* ((entry
                         (car (tp-publication-batch-candidate-entries
                               candidate)))
                        (prepared
                         (aref
                          (tp-publication-target-entry-rollback-snapshot entry)
                          0)))
                   (funcall before-stage entry prepared)
                   (funcall execute candidate)))))
      (tp-surface-update
       surface
       (lambda (context)
         (tp-object-reuse-subtree context root)
         (tp-commit-batch-result-create
          context batch :client-state client-state
          :reuse-mount-projection (not project-coordinates)))))))

(defun tp-surface-test--replacement-batch (surface replacement)
  "Return an equal-extent batch replacing SURFACE's middle character."
  (tp-commit-batch-create
   :base-revision (tp-surface-revision surface)
   :target-revision (1+ (tp-surface-revision surface))
   :base-extent 3 :target-extent 3
   :patches
   (list (list :old-start 1 :old-end 2 :new-start 1 :new-end 2
               :replacement replacement))
   :coordinate-patches
   '((:old-start 1 :old-end 2 :new-start 1 :new-end 2))))

(defun tp-surface-test--shadow-apply-commit-batch-oracle (string batch)
  "Return the former exact replay result for STRING and BATCH."
  (let ((result (copy-sequence string)))
    (dolist (patch (reverse (tp-commit-batch-patches batch)))
      (setq result
            (concat (substring result 0 (plist-get patch :old-start))
                    (plist-get patch :replacement)
                    (substring result (plist-get patch :old-end)))))
    result))

(defun tp-surface-test--source-function (name)
  "Return interpreted NAME from the current tp-surface.el source."
  (let ((source
         (expand-file-name
          "tp-surface.el"
          (file-name-directory (or (locate-library "tp-surface")
                                   (error "Cannot locate tp-surface")))))
        definition)
    (with-temp-buffer
      (insert-file-contents source)
      (condition-case nil
          (while (not definition)
            (let ((form (read (current-buffer))))
              (when (and (eq (car-safe form) 'defun)
                         (eq (cadr form) name))
                (setq definition form))))
        (end-of-file nil)))
    (unless definition
      (error "Cannot find source definition for %S" name))
    (eval `(lambda ,(nth 2 definition) ,@(nthcdr 3 definition)) t)))

(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.")

(defun tp-surface-test--corrupt-after-change (beg end _old-length)
  "Corrupt one inserted range for publication rollback tests."
  (when (and tp-surface-test--corrupt-next (< beg end))
    (setq-local tp-surface-test--corrupt-next nil)
    (with-silent-modifications
      (put-text-property beg end 'face 'corrupt))))

(ert-deftest tp-surface-test-commit-batch-is-atomic-and-revision-bound ()
  "A precomputed batch commits text/properties/state once and rolls back."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount
             (current-buffer)
             (tp-surface-test--leaf 'root "abc" '(face bold))
             '(:capability content)))
           (replacement (propertize "XY" 'face 'italic))
           (batch
            (tp-commit-batch-create
             :base-revision (tp-surface-revision surface)
             :target-revision (1+ (tp-surface-revision surface))
             :base-extent 3 :target-extent 4
             :patches
             (list (list :old-start 1 :old-end 2
                         :new-start 1 :new-end 3
                         :replacement replacement))
             :coordinate-patches
             (list (list :old-start 1 :old-end 2
                         :new-start 1 :new-end 3))
             :client-state '(:value next))))
      (tp-surface-commit-batch surface batch)
      (should (equal "aXYc" (buffer-string)))
      (should (eq 'italic (get-text-property 2 'face)))
      (should (= 2 (tp-surface-revision surface)))
      (should (equal '(:value next) (tp-surface-client-state surface)))
      (should (plist-get (tp-surface-report surface) :commit-batch))
      (let ((failing
             (tp-commit-batch-create
              :base-revision 2 :target-revision 3
              :base-extent 4 :target-extent 4
              :patches
              (list (list :old-start 1 :old-end 3
                          :new-start 1 :new-end 3
                          :replacement "ZZ"))
              :client-state '(:value rejected))))
        (add-hook 'after-change-functions
                  #'tp-surface-test--corrupt-after-change nil t)
        (setq-local tp-surface-test--corrupt-next t)
        (unwind-protect
            (should-error (tp-surface-commit-batch surface failing))
          (remove-hook 'after-change-functions
                       #'tp-surface-test--corrupt-after-change t))
        (should (equal "aXYc" (buffer-string)))
        (should (= 2 (tp-surface-revision surface)))
        (should (equal '(:value next)
                       (tp-surface-client-state surface))))
      (should-error (tp-surface-commit-batch surface batch)))))

(ert-deftest tp-surface-test-commit-batch-composes-patch-properties ()
  "Patch-local contributions use the retained-content property composer."
  (let* ((replacement (propertize "abcd" 'face '(bold) 'help-echo "baseline"))
         (before (copy-sequence replacement))
         (contributions
          '((:start 0 :end 4 :props (face (:background "#112233")))
            (:start 1 :end 3 :props (face italic help-echo "inner"))
            (:start 2 :end 3 :props (face nil help-echo nil))))
         (patch (list :old-start 1 :old-end 5 :new-start 1 :new-end 5
                      :replacement replacement :property-contributions contributions))
         (expected (tp--compose-relative-property-contributions
                    replacement contributions))
         (batch (tp-commit-batch-create
                 :base-revision 1 :target-revision 2 :base-extent 6 :target-extent 6
                 :patches (list patch)))
         (stored (car (tp-commit-batch-patches batch))))
    (should (equal-including-properties before replacement))
    (should (eq replacement (plist-get patch :replacement)))
    (should (eq contributions (plist-get patch :property-contributions)))
    (should (equal-including-properties expected (plist-get stored :replacement)))
    (should-not (eq replacement (plist-get stored :replacement)))
    (should-not (plist-member stored :property-contributions))))

(ert-deftest tp-surface-test-commit-batch-freezes-property-policy-at-construction ()
  "Composition snapshots inputs and evaluates custom merge policy exactly once."
  (let ((tp--property-policies (copy-hash-table tp--property-policies))
        (tp--property-policy-order (copy-sequence tp--property-policy-order))
        (merge-calls 0))
    (tp-define-property-policy
     'text/tp-batch-score :equality #'equal
     :merge (lambda (old new) (cl-incf merge-calls) (+ old new))
     :projector (lambda (value) (list 'tp-batch-score value)))
    (let* ((replacement (propertize "AB" 'tp-batch-score 10 'face '(:weight bold)))
           (before (copy-sequence replacement))
           (before-props (copy-tree (text-properties-at 0 replacement)))
           (contributions
            (list (list :start 0 :end 2 :props (list 'tp-batch-score 1))
                  (list :start 1 :end 2 :props (list 'tp-batch-score 2))))
           (before-contributions (copy-tree contributions))
           (patch (list :old-start 0 :old-end 2 :new-start 0 :new-end 2
                        :replacement replacement :property-contributions contributions))
           (expected (tp--compose-relative-property-contributions
                      replacement contributions))
           batch)
      (setq merge-calls 0
            batch (tp-commit-batch-create
                   :base-revision 1 :target-revision 2 :base-extent 2 :target-extent 2
                   :patches (list patch)))
      (should (= merge-calls 2))
      (should (equal-including-properties before replacement))
      (should (equal before-props (text-properties-at 0 replacement)))
      (should (equal before-contributions contributions))
      (should (eq contributions (plist-get patch :property-contributions)))
      (should (eq replacement (plist-get patch :replacement)))
      (tp-define-property-policy
       'text/tp-batch-score :equality #'equal
       :merge (lambda (_old _new) (error "Policy was re-evaluated after construction"))
       :projector (lambda (value) (list 'tp-batch-score value)))
      (tp-surface-test--with-buffer
        (let ((surface (tp-surface-mount buffer (tp-surface-test--leaf 'root "zz")
                                         '(:capability content))))
          (tp-surface-commit-batch surface batch)
          (should (equal-including-properties expected (buffer-string)))
          (should (= (get-text-property 1 'tp-batch-score) 11))
          (should (= (get-text-property 2 'tp-batch-score) 13))
          (should (= merge-calls 2)))))))

(ert-deftest tp-surface-test-commit-batch-isolates-mutable-property-inputs ()
  "Composition owns mutable inputs while preserving opaque function identity."
  (let ((tp--property-policies (copy-hash-table tp--property-policies))
        (tp--property-policy-order (copy-sequence tp--property-policy-order)))
    (tp-define-property-policy
     'text/tp-batch-destructive
     :merge (lambda (old new)
              (setcar old 'merged-old)
              (setcar new 'merged-new)
              (list old new)))
    (let* ((callback (lambda () 'opaque))
           (baseline (list 'baseline))
           (incoming (list 'incoming))
           (mutable (vector (list (copy-sequence "caller")) callback))
           (replacement (propertize "X" 'tp-batch-destructive baseline
                                    'tp-batch-mutable 'existing))
           (contributions
            (list (list :start 0 :end 1
                        :props (list 'tp-batch-mutable mutable
                                     'tp-batch-destructive incoming))))
           (patch (list :old-start 0 :old-end 1 :new-start 0 :new-end 1
                        :replacement replacement :property-contributions contributions))
           (batch (tp-commit-batch-create
                   :base-revision 1 :target-revision 2 :base-extent 1 :target-extent 1
                   :patches (list patch)))
           (stored (plist-get (car (tp-commit-batch-patches batch)) :replacement))
           (stored-mutable (get-text-property 0 'tp-batch-mutable stored)))
      (should (equal baseline '(baseline)))
      (should (equal incoming '(incoming)))
      (should (equal (aref mutable 0) '("caller")))
      (should (eq callback (aref mutable 1)))
      (should (eq baseline (get-text-property 0 'tp-batch-destructive replacement)))
      (should (eq 'existing (get-text-property 0 'tp-batch-mutable replacement)))
      (should (eq replacement (plist-get patch :replacement)))
      (should (eq contributions (plist-get patch :property-contributions)))
      (should (eq callback (aref stored-mutable 1)))
      (aset (car (aref mutable 0)) 0 ?X)
      (setcdr (aref mutable 0) '(changed))
      (aset mutable 1 #'ignore)
      (setcar baseline 'changed-baseline)
      (setcar incoming 'changed-incoming)
      (should (equal (aref stored-mutable 0) '("caller")))
      (should (eq callback (aref stored-mutable 1)))
      (should (equal (get-text-property 0 'tp-batch-destructive stored)
                     '((merged-old) (merged-new)))))))

(ert-deftest tp-surface-test-commit-batch-validates-local-contributions ()
  "Contribution bounds and property shape are validated inside each patch."
  (dolist (case
           '((tp-invalid-content-range ((:start -1 :end 1 :props (face bold))))
             (tp-invalid-content-range ((:start 0 :end 3 :props (face bold))))
             (tp-invalid-content-range ((:start 2 :end 1 :props (face bold))))
             (tp-invalid-content-range ((:start "0" :end 1 :props (face bold))))
             (tp-invalid-content-range ((:start 0 :props (face bold))))
             (tp-invalid-content-range not-a-list)
             (tp-invalid-surface-plan ((:start 0 :end 1 :props (face))))))
    (ert-info ((format "invalid patch contribution=%S" (cadr case)))
      (should-error
       (tp-commit-batch-create
        :base-revision 1 :target-revision 2 :base-extent 6 :target-extent 6
        :patches (list (list :old-start 2 :old-end 4 :new-start 2 :new-end 4
                            :replacement "XY" :property-contributions (cadr case))))
       :type (car case)))))

(ert-deftest tp-surface-test-commit-batch-composed-properties-roll-back-and-retry ()
  "Direct and retained batches atomically publish composed properties and state."
  (dolist (mode '(direct retained))
    (ert-info ((format "composed batch mode=%S" mode))
      (tp-surface-test--with-buffer
        (let* ((surface
                (tp-surface-mount
                 buffer (lambda (context)
                          (tp-object-ensure context nil 'root 'text)
                          (tp-surface-result-create
                           (tp-surface-test--leaf 'root "abc" '(face bold help-echo "base"))
                           '(:value old)))
                 '(:capability content :coordinate-mounts t)))
               (root (tp-object-resolve surface '(root)))
               (before (buffer-string))
               (old-state (tp-surface-client-state surface))
               (mounts (tp--surface-mounts surface))
               (index (tp--surface-mount-index surface))
               (ids (tp--live-mount-ids surface))
               (next-state (list :value 'next))
               (replacement (propertize "X" 'face 'bold 'help-echo "base"))
               (contributions
                '((:start 0 :end 1 :props (face (:background "#112233") help-echo nil))))
               (expected (concat (substring before 0 1)
                                 (tp--compose-relative-property-contributions
                                  replacement contributions)
                                 (substring before 2)))
               (batch
                (tp-commit-batch-create
                 :base-revision 1 :target-revision 2 :base-extent 3 :target-extent 3
                 :patches (list (list :old-start 1 :old-end 2 :new-start 1 :new-end 2
                                     :replacement replacement
                                     :property-contributions contributions))
                 :client-state next-state)))
          (cl-labels
              ((update ()
                 (if (eq mode 'direct)
                     (tp-surface-commit-batch surface batch)
                   (tp-surface-test--commit-batch-update
                    surface root batch next-state #'ignore))))
            (cl-letf (((symbol-function 'accept-change-group)
                       (lambda (_) (error "Reject composed batch"))))
              (should (equal (should-error (update)) '(error "Reject composed batch"))))
            (should (= (tp-surface-revision surface) 1))
            (should (eq old-state (tp-surface-client-state surface)))
            (should (eq mounts (tp--surface-mounts surface)))
            (should (eq index (tp--surface-mount-index surface)))
            (should (equal ids (tp--live-mount-ids surface)))
            (should (equal-including-properties before (buffer-string)))
            (update))
          (should (= (tp-surface-revision surface) 2))
          (should (eq (tp-surface-client-state surface)
                      (if (eq mode 'direct) (tp-commit-batch-client-state batch) next-state)))
          (should (eq mounts (tp--surface-mounts surface)))
          (should (eq index (tp--surface-mount-index surface)))
          (should (equal ids (tp--live-mount-ids surface)))
          (should (equal-including-properties expected (buffer-string))))))))

(ert-deftest tp-surface-test-retained-batch-shadow-matches-commit-and-rollback ()
  "Implicit retained mounts have exact success and rollback shadow artifacts."
  (dolist (coordinate-shift '(nil t))
    (dolist (phase '(rollback commit))
      (ert-info ((format "retained batch phase=%S coordinate-shift=%S"
                         phase coordinate-shift))
        (tp-surface-test--with-buffer
          (let* ((surface
                  (tp-surface-mount
                   buffer (tp-surface-plan-create
                           :key 'root :kind 'group :capability 'content
                           :children (list (tp-surface-test--leaf 'left "a")
                                           (tp-surface-test--leaf 'right "bc")))
                   '(:capability content :coordinate-mounts t)))
                 (root (tp-object-resolve surface '(root)))
                 (mounts (tp--surface-mounts surface))
                 (index (tp--surface-mount-index surface))
                 (ids (tp--live-mount-ids surface))
                 (batch
                  (if coordinate-shift
                      (tp-commit-batch-create
                       :base-revision 1 :target-revision 2 :base-extent 3 :target-extent 3
                       :patches '((:old-start 0 :old-end 3 :new-start 0 :new-end 3
                                  :replacement "XYZ"))
                       :coordinate-patches
                       '((:old-start 0 :old-end 1 :new-start 0 :new-end 2)
                         (:old-start 1 :old-end 3 :new-start 2 :new-end 3)))
                    (tp-surface-test--replacement-batch surface "X")))
                 entry)
            (cl-labels
                ((update ()
                   (tp-surface-test--commit-batch-update
                    surface root batch '(:owned next)
                    (lambda (target prepared)
                      (setq entry target)
                      (should (tp--prepared-surface-retained-mount-state-p prepared))
                      (should (eq (not coordinate-shift)
                                  (null (tp--prepared-surface-mount-specs prepared))))
                      (should (eq (not coordinate-shift)
                                  (zerop (length
                                          (tp--prepared-surface-mount-coordinate-updates
                                           prepared))))))
                    coordinate-shift)))
              (if (eq phase 'rollback)
                  (let ((tp--surface-publication-step-function
                         (lambda (step _surface)
                           (when (eq step 'client-state)
                             (error "Reject retained batch shadow")))))
                    (should (equal (should-error (update))
                                   '(error "Reject retained batch shadow"))))
                (update)))
            (should (equal (buffer-string)
                           (if (eq phase 'rollback) "abc"
                             (if coordinate-shift "XYZ" "aXc"))))
            (should (eq mounts (tp--surface-mounts surface)))
            (should (eq index (tp--surface-mount-index surface)))
            (should (equal ids (tp--live-mount-ids surface)))
            (let ((shadow (funcall (tp-publication-target-entry-shadow-validator entry)
                                   entry phase)))
              (ert-info ((format "expected mount count=%S actual mount count=%S"
                                 (length (plist-get (plist-get shadow :expected) :mounts))
                                 (length (plist-get (plist-get shadow :actual) :mounts))))
                (should (plist-get shadow :equivalent))))
            (should (eq phase (plist-get tp--last-shadow-proof :phase)))
            (should (plist-get tp--last-shadow-proof :equivalent))))))))

(ert-deftest tp-surface-test-publication-entry-adopts-prepared-authority ()
  "A real surface entry references its authenticated prepared values exactly."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount
             (current-buffer) (tp-surface-test--leaf 'root "abc")
             '(:capability content :coordinate-mounts t)))
           (root (tp-object-resolve surface '(root)))
           (batch (tp-surface-test--replacement-batch surface "X"))
           (client-state (list :owned (list 'next)))
           entry prepared)
      (tp-surface-test--commit-batch-update
       surface root batch client-state
       (lambda (target candidate)
         (setq entry target prepared candidate)))
      (should (eq (tp-publication-target-entry-client-state entry)
                  (tp--prepared-surface-client-state prepared)))
      (should (eq (tp-publication-target-entry-diff entry)
                  (tp--prepared-surface-commit-batch prepared)))
      (should (eq (tp-surface-client-state surface) client-state))
      (should (equal (buffer-string) "aXc")))))

(ert-deftest tp-surface-test-publication-entry-rejects-binding-tamper ()
  "Prepared batch, revision, extent, and client identity drift fail before write."
  (dolist (fault '(batch client-state context-inactive context-surface
                         base-revision target-revision base-extent
                         target-extent))
    (tp-surface-test--with-buffer
      (let* ((surface
              (tp-surface-mount
               (current-buffer) (tp-surface-test--leaf 'root "abc")
               '(:capability content :coordinate-mounts t)))
             (root (tp-object-resolve surface '(root)))
             (batch (tp-surface-test--replacement-batch surface "X"))
             (client-state (list :owned (list 'next)))
             captured-context)
        (should-error
         (tp-surface-test--commit-batch-update
          surface root batch client-state
          (lambda (entry prepared)
            (setq captured-context (tp--prepared-surface-context prepared))
            (pcase fault
              ('batch
               (setf (tp--prepared-surface-commit-batch prepared)
                     (tp-surface-test--replacement-batch surface "X")))
              ('client-state
               (setf (tp--prepared-surface-client-state prepared)
                     (copy-tree client-state)))
              ('context-inactive
               (setf (tp--context-active captured-context) nil))
              ('context-surface
               (setf (tp--context-surface captured-context) nil))
              ('base-revision
               (setf (tp-commit-batch-base-revision batch) 0))
              ('target-revision
               (setf (tp-commit-batch-target-revision batch) 9))
              ('base-extent
               (setf (tp-commit-batch-base-extent batch) 2))
              ('target-extent
               (setf (tp-commit-batch-target-extent batch) 4)))
            (should (tp-publication-target-entry-p entry))))
         :type 'tp-publication-binding-error)
        (should (equal (buffer-string) "abc"))
        (should (= (tp-surface-revision surface) 1))
        (should-not (tp-surface-client-state surface))
        (should-not (tp--context-active captured-context))))))

(ert-deftest tp-surface-test-publication-entry-patch-tamper-stays-proven ()
  "Existing full shadow proof diagnoses in-place patch payload mutation."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount
             (current-buffer) (tp-surface-test--leaf 'root "abc")
             '(:capability content :coordinate-mounts t)))
           (root (tp-object-resolve surface '(root)))
           (batch (tp-surface-test--replacement-batch surface "X")))
      (tp-surface-test--commit-batch-update
       surface root batch '(:owned next)
       (lambda (_entry _prepared)
         (setf (plist-get (car (tp-commit-batch-patches batch)) :replacement)
               "Z")))
      (should (equal (buffer-string) "aZc"))
      (should-not (plist-get tp--last-shadow-proof :equivalent))
      (should
       (cl-some
        (lambda (entry)
          (and (eq (car entry) 'shadow-proof)
               (eq (cadr entry) 'commit)))
        tp--last-transaction-diagnostics)))))

(ert-deftest tp-surface-test-shadow-batch-replay-preserves-exact-properties ()
  "Shadow replay preserves Unicode, properties, order, and input ownership."
  (let* ((opaque (make-symbol "owner"))
         (base (propertize (concat "A" "乙丙丁戊")
                           'owner opaque 'face '(bold)))
         (insertion (propertize (concat "a" "β")
                                'owner opaque 'face '(italic)))
         (replacement
          (propertize (copy-sequence "Q")
                      'owner opaque 'display '(space :width 2)))
         (batch
          (tp-commit-batch-create
           :base-revision 0 :target-revision 1
           :base-extent 5 :target-extent 5
           :patches
           (list
            (list :old-start 0 :old-end 0 :new-start 0 :new-end 2
                  :replacement insertion)
            (list :old-start 1 :old-end 3 :new-start 3 :new-end 3
                  :replacement "")
            (list :old-start 4 :old-end 5 :new-start 4 :new-end 5
                  :replacement replacement))))
         (expected
          (concat insertion (substring base 0 1)
                  (substring base 3 4) replacement))
         (result (tp--shadow-apply-commit-batch-to-string base batch)))
    (should (equal-including-properties expected result))
    (should (eq opaque (get-text-property 0 'owner result)))
    (aset base 0 ?X)
    (aset insertion 0 ?z)
    (aset replacement 0 ?R)
    (should (equal-including-properties expected result))))

(ert-deftest tp-surface-test-shadow-batch-replay-preserves-adjacent-inserts ()
  "Zero-width patches at one old coordinate retain declared list order."
  (let* ((first (propertize "α" 'face 'bold))
         (second (propertize "乙" 'face 'italic))
         (batch
          (tp-commit-batch-create
           :base-revision 0 :target-revision 1
           :base-extent 0 :target-extent 2
           :patches
           (list
            (list :old-start 0 :old-end 0 :new-start 0 :new-end 1
                  :replacement first)
            (list :old-start 0 :old-end 0 :new-start 1 :new-end 2
                  :replacement second))
           :coordinate-patches
           '((:old-start 0 :old-end 0 :new-start 0 :new-end 1)
             (:old-start 0 :old-end 0 :new-start 1 :new-end 2)))))
    (let ((result (tp--shadow-apply-commit-batch-to-string "" batch)))
      (should (equal-including-properties (concat first second) result))
      (should (eq (get-text-property 0 'face result) 'bold))
      (should (eq (get-text-property 1 'face result) 'italic)))))

(ert-deftest tp-surface-test-shadow-batch-replay-no-patches-copies-input ()
  "No-patch shadow replay returns an independently mutable string."
  (let* ((base (copy-sequence "value"))
         (batch
          (tp-commit-batch-create
           :base-revision 0 :target-revision 1
           :base-extent 5 :target-extent 5))
         (result (tp--shadow-apply-commit-batch-to-string base batch)))
    (should (equal base result))
    (should-not (eq base result))
    (aset result 0 ?X)
    (should (equal base "value"))))

(ert-deftest tp-surface-test-shadow-batch-replay-matches-oracle ()
  "Single-pass replay matches the former exact algorithm over varied patches."
  (let ((cases
         '(("abcdef" ((0 0 "α") (1 3 "XY") (6 6 "尾")))
           ("abcdef" ((0 6 "") (6 6 "新值")))
           ("abcdef" ((1 2 "") (2 2 "二") (4 5 "四五六"))))))
    (dolist (case cases)
      (let ((old-cursor 0) (new-cursor 0) patches)
        (dolist (spec (cadr case))
          (pcase-let ((`(,old-start ,old-end ,replacement) spec))
            (let ((new-start (+ new-cursor (- old-start old-cursor)))
                  (new-end
                   (+ new-cursor (- old-start old-cursor)
                      (length replacement))))
              (push (list :old-start old-start :old-end old-end
                          :new-start new-start :new-end new-end
                          :replacement replacement)
                    patches)
              (setq old-cursor old-end new-cursor new-end))))
        (setq patches (nreverse patches))
        (let* ((base (car case))
               (target-extent (+ new-cursor (- (length base) old-cursor)))
               (coordinates
                (mapcar
                 (lambda (patch)
                   (list :old-start (plist-get patch :old-start)
                         :old-end (plist-get patch :old-end)
                         :new-start (plist-get patch :new-start)
                         :new-end (plist-get patch :new-end)))
                 patches))
               (batch
                (tp-commit-batch-create
                 :base-revision 0 :target-revision 1
                 :base-extent (length base) :target-extent target-extent
                 :patches patches :coordinate-patches coordinates)))
          (should
           (equal-including-properties
            (tp-surface-test--shadow-apply-commit-batch-oracle base batch)
            (tp--shadow-apply-commit-batch-to-string base batch))))))))

(ert-deftest tp-surface-test-shadow-batch-replay-work-is-linear ()
  "Replay slices the base once and concatenates exactly the target extent."
  (let* ((patch-count 512)
         (base (make-string (* patch-count 2) ?a))
         patches
         (old 0)
         (new 0))
    (dotimes (index patch-count)
      (push (list :old-start old :old-end (1+ old)
                  :new-start new :new-end (+ new 2)
                  :replacement (if (zerop (% index 2)) "甲乙" "αβ"))
            patches)
      (setq old (+ old 2) new (+ new 3)))
    (let* ((patches (nreverse patches))
           (target-extent (+ new (- (length base) old)))
           (coordinates
            (mapcar
             (lambda (patch)
               (list :old-start (plist-get patch :old-start)
                     :old-end (plist-get patch :old-end)
                     :new-start (plist-get patch :new-start)
                     :new-end (plist-get patch :new-end)))
             patches))
           (batch
            (tp-commit-batch-create
             :base-revision 0 :target-revision 1
             :base-extent (length base) :target-extent target-extent
             :patches patches :coordinate-patches coordinates))
           (source-function
            (tp-surface-test--source-function
             'tp--shadow-apply-commit-batch-to-string))
           (real-substring (symbol-function 'substring))
           (real-concat (symbol-function 'concat))
           (substring-count 0)
           (substring-output 0)
           (concat-count 0)
           (concat-input 0)
           recording)
      (cl-letf (((symbol-function 'substring)
                 (lambda (string start &optional end)
                   (let ((result (funcall real-substring string start end)))
                     (when recording
                       (cl-incf substring-count)
                       (cl-incf substring-output (length result)))
                     result)))
                ((symbol-function 'concat)
                 (lambda (&rest sequences)
                   (when recording
                     (cl-incf concat-count)
                     (cl-incf concat-input
                              (apply #'+ (mapcar #'length sequences))))
                   (apply real-concat sequences))))
        (let ((result
               (progn
                 (setq recording t)
                 (prog1 (funcall source-function base batch)
                   (setq recording nil)))))
          (should (= (length result) target-extent))))
      (should (= substring-count (1+ patch-count)))
      (should (<= substring-output (length base)))
      (should (= concat-count 1))
      (should (= concat-input target-extent)))))

(ert-deftest tp-surface-test-producer-can-return-equal-coordinate-batch ()
  "A retained producer can publish a strict batch through normal TP phases."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount
             (current-buffer) (tp-surface-test--leaf 'root "abc")
             '(:capability content :coordinate-mounts t)))
           root)
      (maphash (lambda (_path object)
                 (unless (tp--surface-object-parent object)
                   (setq root object)))
               (tp--surface-objects surface))
      (let ((old-mounts (copy-sequence (tp--surface-mounts surface)))
            (old-index (tp--surface-mount-index surface))
            (batch
             (tp-commit-batch-create
              :base-revision 1 :target-revision 2
              :base-extent 3 :target-extent 4
              :patches
              (list (list :old-start 1 :old-end 2
                          :new-start 1 :new-end 3
                          :replacement (propertize "XY" 'face 'bold)))
              :coordinate-patches
              (list (list :old-start 1 :old-end 2
                          :new-start 1 :new-end 3))
              :client-state '(:batch committed))))
        (tp-surface-update
         surface
         (lambda (context)
           (tp-object-reuse-subtree context root)
           (tp-commit-batch-result-create context batch)))
      (should (equal "aXYc" (buffer-string)))
      (should (eq 'bold (get-text-property 2 'face)))
      (should (= 2 (tp-surface-revision surface)))
      (should (equal '(:batch committed)
                     (tp-surface-client-state surface)))
      (should (eq old-index (tp--surface-mount-index surface)))
      (should (cl-every #'identity
                        (cl-mapcar #'eq old-mounts
                                   (tp--surface-mounts surface))))
      (should
       (cl-every (lambda (mount)
                   (<= (tp--mount-position (tp--surface-mount-end mount))
                       (point-max)))
                 (tp--surface-mounts surface)))
      (should (plist-get (tp-surface-report surface) :commit-batch))
      (let ((before-mounts (tp-object-mounts root))
            (before-live (copy-sequence (tp--surface-mounts surface)))
            (failing
             (tp-commit-batch-create
              :base-revision 2 :target-revision 3
              :base-extent 4 :target-extent 5
              :patches
              (list (list :old-start 1 :old-end 3
                          :new-start 1 :new-end 4
                          :replacement "XYZ"))
              :coordinate-patches
              (list (list :old-start 1 :old-end 3
                          :new-start 1 :new-end 4)))))
        (let ((tp--surface-publication-step-function
               (lambda (step _surface)
                 (when (eq step 'client-state)
                   (error "Injected retained mount rollback")))))
          (should-error
           (tp-surface-update
            surface
            (lambda (context)
              (tp-object-reuse-subtree context root)
              (tp-commit-batch-result-create context failing)))))
        (should (equal "aXYc" (buffer-string)))
        (should (= 2 (tp-surface-revision surface)))
        (should (equal before-mounts (tp-object-mounts root)))
        (should (cl-every #'identity
                          (cl-mapcar #'eq before-live
                                     (tp--surface-mounts surface)))))))))

(ert-deftest tp-surface-test-commit-batch-promotes-exact-target-mounts ()
  "A shrinking batch publishes producer-supplied target mounts atomically."
  (tp-surface-test--with-buffer
    (let ((owned-state (list :batch 'exact-mounts)) root logical)
      (let* ((producer
              (lambda (context)
                (setq root (tp-object-ensure context nil 'root 'text)
                      logical
                      (tp-object-ensure context root 'logical 'item))
                (tp-object-attach-content-range
                 context logical root 4 6 '(:slot old))
                (tp-surface-test--leaf 'root "abcdef")))
             (surface
              (tp-surface-mount
               buffer producer
               '(:capability content :coordinate-mounts t))))
        (tp-surface-update
         surface
         (lambda (context)
           (tp-object-reuse-subtree context root)
           (tp-commit-batch-result-create
            context
            (tp-commit-batch-create
             :base-revision 1 :target-revision 2
             :base-extent 6 :target-extent 2
             :patches
             (list (list :old-start 0 :old-end 6
                         :new-start 0 :new-end 2
                         :replacement "XY"))
             :coordinate-patches
             (list (list :old-start 0 :old-end 6
                         :new-start 0 :new-end 2)))
            :mount-specs
            (list (list :object root :start 0 :end 2 :tags nil)
                  (list :object logical :start 0 :end 2
                        :tags '(:slot new)))
            :client-state owned-state)))
        (should (equal (buffer-string) "XY"))
        (should (= (tp-surface-revision surface) 2))
        (should (eq (tp-surface-client-state surface) owned-state))
        (should (plist-get (tp-surface-report surface) :commit-batch))
        (should (equal (tp-object-mounts logical)
                       '((:start 1 :end 3 :tags (:slot new)))))))))

(ert-deftest tp-surface-test-commit-batch-reuses-proven-mount-projection ()
  "A producer proof can retain mounts despite nonidentity text coordinates."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount
             buffer (tp-surface-test--leaf 'root "abcd")
             '(:capability content :coordinate-mounts t)))
           (root (tp-object-resolve surface '(root)))
           (mounts (tp--surface-mounts surface))
           (mount-index (tp--surface-mount-index surface))
           (batch
            (tp-commit-batch-create
             :base-revision 1 :target-revision 2
             :base-extent 4 :target-extent 4
             :patches
             (list (list :old-start 1 :old-end 3
                         :new-start 1 :new-end 3
                         :replacement "XY"))
             :coordinate-patches
             (list (list :old-start 1 :old-end 2
                         :new-start 1 :new-end 1)
                   (list :old-start 3 :old-end 3
                         :new-start 2 :new-end 3)))))
      (tp-surface-update
       surface
       (lambda (context)
         (tp-object-reuse-subtree context root)
         (tp-commit-batch-result-create
          context batch :reuse-mount-projection t)))
      (should (equal (buffer-string) "aXYd"))
      (should (eq mounts (tp--surface-mounts surface)))
      (should (eq mount-index (tp--surface-mount-index surface)))
      (should (plist-get (tp-surface-report surface)
                         :retained-mount-state)))))

(ert-deftest tp-surface-test-plan-validates-and-defensively-copies ()
  "Plans reject duplicate keys and own their caller-provided values."
  (let* ((callback (byte-compile
                    (lambda (_window _object _position) "help")))
         (props (list 'help-echo callback))
         (text (copy-sequence "A"))
         (child (tp-surface-test--leaf 'child text props))
         (plan (tp-surface-plan-create
                :key 'root :kind 'group :children (list child)
                :capability 'content)))
    (setcar props 'face)
    (aset text 0 ?Z)
    (let ((rendered (tp-surface-materialize-string plan)))
      (should (equal (substring-no-properties rendered) "A"))
      (should (eq (get-text-property 0 'help-echo rendered) callback)))
    (should-error
     (tp-surface-plan-create
      :key 'root :kind 'group
      :children (list (tp-surface-test--leaf 'same "A")
                      (tp-surface-test--leaf 'same "B"))
     :capability 'content)
     :type 'tp-duplicate-object-key)))

(ert-deftest tp-surface-test-plan-snapshots-nested-values ()
  "Nested plan values remain defensive snapshots across producer boundaries."
  (let* ((props (list 'face 'bold))
         (tags (list :role 'leaf))
         (text (copy-sequence "A"))
         (child (tp-surface-plan-create
                 :key 'child :kind 'text :text text :props props :tags tags
                 :capability 'content))
         (children (list child))
         (parent (tp-surface-plan-create
                  :key 'root :kind 'group :children children
                  :capability 'content))
         (result (tp-surface-result-create parent))
         (normalized-from-result
          (car (tp--producer-result result nil nil nil))))
    (tp-surface-test--with-buffer
      (let* ((surface (tp--create-surface
                       buffer 'content '(:capability content)))
             (normalized-from-plan
              (car (tp--producer-result parent surface nil nil))))
        (let* ((result-plan (tp-surface-result-plan result))
               (result-child (car (tp-surface-plan-children result-plan))))
          (setf (tp-surface-plan-children result-plan) nil
                (tp-surface-plan-text result-child) "result-mutated")
          (setcar (tp-surface-plan-tags result-child) :result-mutated))
        (setcar props 'help-echo)
        (setcar tags :mutated)
        (aset text 0 ?Z)
        (setcar children nil)
        (setf (tp-surface-plan-text
               (car (tp-surface-plan-children parent)))
              "mutated")
        (should-not (eq (car (tp-surface-plan-children parent)) child))
        (should-not (eq (tp-surface-result-plan result) parent))
        (should-not (eq normalized-from-result parent))
        (should-not (eq normalized-from-plan parent))
        (let ((rendered (tp-surface-materialize-string normalized-from-result)))
          (should (equal (substring-no-properties rendered) "A"))
          (should (eq (get-text-property 0 'face rendered) 'bold)))
        (should (equal (tp-surface-plan-tags child) '(:role leaf)))))))

(ert-deftest tp-surface-test-retained-content-composes-property-contributions ()
  "A content surface should layer property contributions without text work."
  (tp-surface-test--with-buffer
    (let* ((plan
            (tp-surface-plan-create
             :key 'root :kind 'group :capability 'content
             :children
             (list
              (tp-surface-plan-create
               :key 'fragments :kind 'group :capability 'content
               :children (list (tp-surface-test--leaf 'text "abcd"))))))
           (surface (tp-surface-mount buffer plan '(:capability content)))
           (producer
            (lambda (contributions)
              (lambda (context)
                (let* ((root (tp-object-ensure context nil 'root 'group))
                       (fragments
                        (tp-object-ensure context root 'fragments 'group))
                       (_text
                        (tp-object-ensure context fragments 'text 'text))
                       (owned-plan
                        (tp-surface-plan-create-owned
                         :key 'root :kind 'group :capability 'content
                         :children
                         (list
                          (tp-surface-plan-create-owned
                           :key 'fragments :kind 'group :capability 'content
                           :children
                           (list
                            (tp-surface-plan-create-owned
                             :key 'text :kind 'text :text "abcd"
                             :capability 'content)))))))
                  (tp-surface-retained-content-result-create
                   context owned-plan "abcd" nil nil t contributions)))))
           (base
            (list :start 0 :end 4
                  :props '(face (:foreground "white"
                                 :background "black"))))
           (specific
            (list :start 1 :end 3
                  :props '(face (:foreground "red")))))
      (tp-surface-update surface (funcall producer (list base specific)))
      (should (equal (buffer-string) "abcd"))
      (let ((outer (get-text-property 1 'face))
            (inner (get-text-property 2 'face)))
        (should (equal (plist-get outer :foreground) "white"))
        (should (equal (plist-get outer :background) "black"))
        (should (equal (plist-get inner :foreground) "red"))
        (should (equal (plist-get inner :background) "black")))
      (let* ((next-base
              (list :start 0 :end 4
                    :props '(face (:foreground "#EEEEEE"
                                   :background "#111111"))))
             (report
              (tp-surface-update
               surface (funcall producer (list next-base specific)))))
        (should (equal (buffer-string) "abcd"))
        (should (= 0 (plist-get report :text-operations)))
        (should (> (plist-get report :property-operations) 0))
        (let ((outer (get-text-property 1 'face))
              (inner (get-text-property 2 'face)))
          (should (equal (plist-get outer :foreground) "#EEEEEE"))
          (should (equal (plist-get outer :background) "#111111"))
          (should (equal (plist-get inner :foreground) "red"))
          (should (equal (plist-get inner :background) "#111111")))))))

(ert-deftest tp-surface-test-retained-content-rejects-invalid-contribution ()
  "Invalid contribution ranges must fail before mutating published content."
  (tp-surface-test--with-buffer
    (let* ((plan
            (tp-surface-plan-create
             :key 'root :kind 'group :capability 'content
             :children
             (list
              (tp-surface-plan-create
               :key 'fragments :kind 'group :capability 'content
               :children (list (tp-surface-test--leaf 'text "safe"))))))
           (surface (tp-surface-mount buffer plan '(:capability content))))
      (should-error
       (tp-surface-update
        surface
        (lambda (context)
          (let* ((root (tp-object-ensure context nil 'root 'group))
                 (fragments
                  (tp-object-ensure context root 'fragments 'group))
                 (_text (tp-object-ensure context fragments 'text 'text))
                 (owned-plan
                  (tp-surface-plan-create-owned
                   :key 'root :kind 'group :capability 'content
                   :children
                   (list
                    (tp-surface-plan-create-owned
                     :key 'fragments :kind 'group :capability 'content
                     :children
                     (list
                      (tp-surface-plan-create-owned
                       :key 'text :kind 'text :text "safe"
                       :capability 'content)))))))
            (tp-surface-retained-content-result-create
             context owned-plan "safe" nil nil t
             '((:start 0 :end 9 :props (face bold)))))))
       :type 'tp-invalid-content-range)
      (should (equal (buffer-string) "safe")))))

(ert-deftest tp-surface-test-owned-plan-result-transfers-candidate-tree ()
  "Owned plan and result constructors skip a duplicate candidate snapshot."
  (tp-surface-test--with-buffer
    (let* ((surface (tp--create-surface
                     buffer 'content '(:capability content)))
           (context (tp--make-context surface)))
      (let ((tp--current-prepare-context context))
        (let* ((text (copy-sequence "owned"))
               (child (tp-surface-plan-create-owned
                       :key 'child :kind 'text :text text
                       :capability 'content))
               (parent (tp-surface-plan-create-owned
                        :key 'root :kind 'group :children (list child)
                        :capability 'content))
               (result (tp-surface-result-create-owned context parent))
               (copies 0)
               (original (symbol-function 'tp--copy-surface-plan)))
          (cl-letf (((symbol-function 'tp--copy-surface-plan)
                     (lambda (&rest arguments)
                       (cl-incf copies)
                       (apply original arguments))))
            (should (eq (car (tp--producer-result result surface nil context))
                        parent)))
          (should (= copies 0))
          (should (tp-surface-result-plan-owned-p result))
          (should (tp-surface-result-consumed-p result))
          (should-not (tp-surface-result-plan result))
          (should-not (tp-surface-result-client-state result))
          (should-not (tp-surface-result-owner-context result))
          (should-error
           (tp--producer-result result surface nil context)
           :type 'tp-owned-result-error)
          (should (eq (tp-surface-plan-text child) text)))))))

(ert-deftest tp-surface-test-owned-result-rejects-inactive-or-wrong-context ()
  "Rejected owned results remain unconsumed for inactive or wrong contexts."
  (tp-surface-test--with-buffer
    (let* ((surface (tp--create-surface
                     buffer 'content '(:capability content)))
           (context (tp--make-context surface))
           (other-context (tp--make-context surface))
           (plan (tp-surface-plan-create-owned
                  :key 'root :kind 'text :text "owned"
                  :capability 'content)))
      (let ((tp--current-prepare-context context))
        (let ((result (tp-surface-result-create-owned context plan)))
          (setf (tp--context-active context) nil)
          (should-error
           (tp--producer-result
            result surface nil context)
           :type 'tp-owned-result-error)
          (should-not (tp-surface-result-consumed-p result))
          (should (eq (tp-surface-result-plan result) plan))
          (setf (tp--context-active context) t)
          (let ((tp--current-prepare-context other-context))
            (should-error
             (tp--producer-result result surface nil other-context)
             :type 'tp-owned-result-error))
          (should-not (tp-surface-result-consumed-p result)))))))

(ert-deftest tp-surface-test-direct-plan-prepare-snapshots-once ()
  "Direct plan prepare does not snapshot its already-copied plan twice."
  (let ((plan (tp-surface-test--leaf 'root "direct"))
        (copies 0)
        (original (symbol-function 'tp--copy-surface-plan)))
    (cl-letf (((symbol-function 'tp--copy-surface-plan)
               (lambda (&rest args)
                 (cl-incf copies)
                 (apply original args))))
      (should (equal (substring-no-properties
                      (tp-surface-materialize-string plan))
                     "direct"))
      (should (= copies 1)))))

(ert-deftest tp-surface-test-render-propagation-reuses-prepared-values ()
  "Rendering a prepared plan does not recursively copy inherited properties."
  (let* ((inherited-value (list :space :width 1))
         (parent (list 'display inherited-value))
         (child (list 'face 'bold))
         (render-copies 0)
         (copy-function (symbol-function 'tp--copy-property-value)))
    (cl-letf (((symbol-function 'tp--copy-property-value)
               (lambda (&rest arguments)
                 (cl-incf render-copies)
                 (apply copy-function arguments))))
      (let ((result (tp--plist-overlay parent child t)))
        (should (equal (plist-get result 'face) 'bold))
        (should (eq (plist-get result 'display) inherited-value))
        (should-not (eq result parent))))
    (should (= render-copies 0))))

(ert-deftest tp-surface-test-owned-render-transfers-property-values ()
  "Owned producer plans transfer candidate property values to rendered text."
  (let (candidate-value)
    (let ((rendered
           (tp-surface-materialize-string
           (lambda (context)
              (setq candidate-value (list :space :width 1))
              (tp-object-ensure context nil 'root 'text)
              (tp-surface-result-create-owned
               context
               (tp-surface-plan-create-owned
                :key 'root :kind 'text :text "owned"
                :props (list 'display candidate-value)
                :capability 'content))))))
      (should (equal (substring-no-properties rendered) "owned"))
      (should (eq (get-text-property 0 'display rendered)
                  candidate-value)))))

(ert-deftest tp-surface-test-plan-copy-obeys-value-identity-rules ()
  "Plan data is copied while opaque records and functions keep identity."
  (with-temp-buffer
    (let* ((caller-string (copy-sequence "tag"))
           (caller-vector (vector (copy-sequence "nested")))
           (record (tp--make-native-range (current-buffer) :buffer 1 1))
           (calls 0)
           (callback (lambda () (cl-incf calls)))
           (table (make-hash-table :test #'equal))
           (marker (copy-marker (point-min)))
           (tags (list caller-string caller-vector record callback table
                       marker (current-buffer)))
           (plan (tp-surface-plan-create
                  :key 'root :kind 'text :text "x" :tags tags
                  :capability 'content))
           (copy (tp-surface-plan-tags plan)))
      (should-not (eq copy tags))
      (should-not (eq (nth 0 copy) caller-string))
      (should-not (eq (nth 1 copy) caller-vector))
      (should-not (eq (aref (nth 1 copy) 0) (aref caller-vector 0)))
      (should (eq (nth 2 copy) record))
      (should (eq (nth 3 copy) callback))
      (should (eq (nth 4 copy) table))
      (should (eq (nth 5 copy) marker))
      (should (eq (nth 6 copy) (current-buffer)))
      (should (= calls 0)))))

(ert-deftest tp-surface-test-plan-copy-shares-source-identity-across-children ()
  "One plan snapshot reuses one copy for repeated source identities globally."
  (let* ((shared (list :shared t))
         (equal-but-distinct (list :shared t))
         (child-a (tp--make-surface-plan
                   :key 'a :kind 'text :tags (list shared)))
         (child-b (tp--make-surface-plan
                   :key 'b :kind 'text
                   :tags (list shared equal-but-distinct)))
         (plan (tp--make-surface-plan
                :key 'root :kind 'group
                :children (list child-a child-b)))
         (copy (tp--copy-surface-plan plan))
         (copy-a
          (tp-surface-plan-tags
           (car (tp-surface-plan-children copy))))
         (copy-b
          (tp-surface-plan-tags
           (cadr (tp-surface-plan-children copy)))))
    (should (eq (car copy-a) (car copy-b)))
    (should-not (eq (car copy-b) (cadr copy-b)))
    (should-not (eq (car copy-b) equal-but-distinct))
    (should-not (eq (cadr copy-b) equal-but-distinct))
    (should-not (eq (car copy-a) shared))))

(ert-deftest tp-surface-test-retained-options-own-mutable-containers ()
  "Surface options copy data containers without cloning opaque identities."
  (tp-surface-test--with-buffer
    (let* ((caller-string (copy-sequence "state"))
           (caller-vector (vector (copy-sequence "nested")))
           (record (tp--make-native-range buffer :buffer 1 1))
           (calls 0)
           (callback (lambda () (cl-incf calls)))
           (table (make-hash-table :test #'equal))
           (start (copy-marker (point-min)))
           (end (copy-marker (point-max) t))
           (client-state
            (list caller-string caller-vector record callback table buffer))
           (options
            (list :capability 'content :start start :end end
                  :client-state client-state))
           (surface (tp--create-surface buffer 'content options))
           (stored-options (tp--surface-options surface))
           (stored-state (plist-get stored-options :client-state)))
      (should-not (eq stored-state client-state))
      (should-not (eq (nth 0 stored-state) caller-string))
      (should-not (eq (nth 1 stored-state) caller-vector))
      (should-not (eq (aref (nth 1 stored-state) 0)
                      (aref caller-vector 0)))
      (should (eq (nth 2 stored-state) record))
      (should (eq (nth 3 stored-state) callback))
      (should (eq (nth 4 stored-state) table))
      (should (eq (nth 5 stored-state) buffer))
      (should (eq (plist-get stored-options :start) start))
      (should (eq (plist-get stored-options :end) end))
      (should (= calls 0))
      (aset caller-string 0 ?S)
      (aset (aref caller-vector 0) 0 ?N)
      (should (equal (nth 0 stored-state) "state"))
      (should (equal (nth 1 stored-state) ["nested"])))))

(ert-deftest tp-surface-test-report-copy-is-deep-for-data-values ()
  "Public reports cannot mutate retained data and preserve opaque identities."
  (with-temp-buffer
    (let* ((report-string (copy-sequence "report"))
           (report-vector (vector (copy-sequence "nested")))
           (record (tp--make-native-range (current-buffer) :buffer 1 1))
           (calls 0)
           (callback (lambda () (cl-incf calls)))
           (table (make-hash-table :test #'equal))
           (marker (copy-marker (point-min)))
           (payload (list report-string report-vector record callback table
                          marker (current-buffer)))
           (surface (tp--make-surface :report (list :payload payload)))
           (first-payload (plist-get (tp-surface-report surface) :payload)))
      (should-not (eq (nth 0 first-payload) report-string))
      (should-not (eq (nth 1 first-payload) report-vector))
      (should-not (eq (aref (nth 1 first-payload) 0)
                      (aref report-vector 0)))
      (should (eq (nth 2 first-payload) record))
      (should (eq (nth 3 first-payload) callback))
      (should (eq (nth 4 first-payload) table))
      (should (eq (nth 5 first-payload) marker))
      (should (eq (nth 6 first-payload) (current-buffer)))
      (should (= calls 0))
      (aset (nth 0 first-payload) 0 ?R)
      (aset (aref (nth 1 first-payload) 0) 0 ?N)
      (let ((second-payload
             (plist-get (tp-surface-report surface) :payload)))
        (should (equal (nth 0 second-payload) "report"))
        (should (equal (nth 1 second-payload) ["nested"]))))))

(ert-deftest tp-surface-test-report-summary-contains-only-commit-scalars ()
  "Report summary exposes Ebox metrics without exposing nested report data."
  (let ((surface
         (tp--make-surface
          :report '(:transaction-id 7 :text-operations 2
                     :property-operations 3 :full-root nil
                     :scope-count 4 :scope-range-count 5
                    :scope-fallback t :reconciled-objects 6
                    :created-objects 7 :removed-objects 8 :moved-objects 9
                    :payload (:mutable value)))))
    (should (equal (tp-surface-report-summary surface)
                   '(:transaction-id 7 :text-operations 2
                     :property-operations 3 :full-root nil
                     :scope-count 4 :scope-range-count 5
                     :scope-fallback t :reconciled-objects 6
                     :created-objects 7 :removed-objects 8 :moved-objects 9)))))

(ert-deftest tp-surface-test-materialize-producer-is-ephemeral ()
  "Pure materialization leaves no live object, binding, or subscription."
  (let ((signal (tp-signal-create 7)) object binding)
    (let ((rendered
           (tp-surface-materialize-string
            (lambda (context)
              (setq object (tp-object-ensure context nil 'root 'text)
                    binding (tp-bind object '(test . value)
                                     (lambda () (tp-signal-read signal))))
              (tp-surface-test--leaf
               'root (number-to-string (tp-binding-read binding)))))))
      (should (equal rendered "7")))
    (should-not (tp-object-live-p object))
    (should-not (tp-binding-live-p binding))
    (should (= (tp-signal-subscriber-count signal) 0))))

(ert-deftest tp-surface-test-content-mount-retains-keyed-identity ()
  "A content update reuses keyed objects and publishes a minimal result."
  (tp-surface-test--with-buffer
    (let* ((first (tp-surface-test--leaf 'root "old" '(face bold)))
           (surface (tp-surface-mount buffer first '(:capability content)))
           (object (tp-object-resolve surface '(root))))
      (should (equal (buffer-string) "old"))
      (cl-letf (((symbol-function 'buffer-list)
                 (lambda (&rest _) (error "Unexpected buffer scan")))
                ((symbol-function 'text-property-search-forward)
                 (lambda (&rest _) (error "Unexpected property scan"))))
        (tp-surface-update
         surface (tp-surface-test--leaf 'root "new" '(face italic))))
      (should (equal (buffer-string) "new"))
      (should (eq object (tp-object-resolve surface '(root))))
      (should (eq (get-text-property 1 'face buffer) 'italic))
      (should (= (plist-get (tp-surface-report surface) :text-operations) 1)))))

(ert-deftest tp-surface-test-coordinate-content-mounts-keep-public-ranges ()
  "Coordinate content mounts avoid marker churn without changing the API."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount
             buffer (tp-surface-test--leaf 'root "abc")
             '(:capability content :coordinate-mounts t)))
           (object (tp-object-resolve surface '(root)))
           (mount (car (gethash object (tp--surface-mount-index surface)))))
      (should (integerp (tp--surface-mount-start mount)))
      (should (integerp (tp--surface-mount-end mount)))
      (should (tp-object-mounted-p object))
      (should (equal (car (tp-object-mounts object))
                     '(:start 1 :end 4 :tags nil)))
      (tp-surface-update surface (tp-surface-test--leaf 'root "abcd"))
      (should (equal (car (tp-object-mounts object))
                     '(:start 1 :end 5 :tags nil))))))

(ert-deftest tp-surface-test-batched-content-ranges-preserve-order ()
  "Batched content ranges retain attachment order and caller isolation."
  (tp-surface-test--with-buffer
    (let ((tags (list :slot 'first)))
      (let* ((producer
              (lambda (context)
                (let ((object (tp-object-ensure context nil 'root 'text)))
                  (tp-object-attach-content-ranges
                   context object
                   (list (list :object object :start 0 :end 1 :tags tags)
                         (list :object object :start 1 :end 3
                               :tags '(:slot second))))
                  (tp-surface-plan-create
                   :key 'root :kind 'text :text "abc"
                   :capability 'content))))
             (surface (tp-surface-mount
                       buffer producer
                       '(:capability content :coordinate-mounts t)))
             (object (tp-object-resolve surface '(root))))
        (setcar tags :mutated)
        (should (equal (tp-object-mounts object)
                       '((:start 1 :end 4 :tags nil)
                         (:start 1 :end 2 :tags (:slot first))
                         (:start 2 :end 4 :tags (:slot second)))))))))

(ert-deftest tp-surface-test-batched-content-ranges-reuse-identical-tags ()
  "A bulk attach shares one snapshot when the same TAGS object is reused."
  (tp-surface-test--with-buffer
    (let ((tags (list :slot 'same)))
      (let* ((producer
              (lambda (context)
                (let ((object (tp-object-ensure context nil 'root 'text)))
                  (tp-object-attach-content-ranges
                   context object
                   (list (list :object object :start 0 :end 1
                               :tags tags)
                         (list :object object :start 1 :end 2
                               :tags tags)))
                  (tp-surface-plan-create
                   :key 'root :kind 'text :text "ab"
                   :capability 'content))))
             (surface (tp-surface-mount
                       buffer producer
                       '(:capability content :coordinate-mounts t)))
             (object (tp-object-resolve surface '(root)))
             (tagged
              (cl-remove-if-not
               (lambda (mount)
                 (equal (tp--surface-mount-tags mount) '(:slot same)))
               (gethash object (tp--surface-mount-index surface)))))
        (should (= (length tagged) 2))
        (should (eq (tp--surface-mount-tags (car tagged))
                    (tp--surface-mount-tags (cadr tagged))))
        (let ((public-tags (plist-get (cadr (tp-object-mounts object))
                                      :tags)))
          (setcar public-tags :public-mutated)
          (should (equal (plist-get (cadr (tp-object-mounts object)) :tags)
                         '(:slot same))))
        (setcar tags :mutated)
        (should (equal (tp-object-mounts object)
                       '((:start 1 :end 3 :tags nil)
                         (:start 1 :end 2 :tags (:slot same))
                         (:start 2 :end 3 :tags (:slot same)))))))))

(ert-deftest tp-surface-test-batched-content-ranges-keep-opaque-tags-separate ()
  "Equal opaque tag values keep independent bulk snapshots."
  (tp-surface-test--with-buffer
    (let ((left-tags (copy-sequence "same"))
          (right-tags (copy-sequence "same")))
      (let* ((producer
              (lambda (context)
                (let ((object (tp-object-ensure context nil 'root 'text)))
                  (tp-object-attach-content-ranges
                   context object
                   (list (list :object object :start 0 :end 1
                               :tags left-tags)
                         (list :object object :start 1 :end 2
                               :tags right-tags)))
                  (tp-surface-plan-create
                   :key 'root :kind 'text :text "ab"
                   :capability 'content))))
             (surface (tp-surface-mount
                       buffer producer
                       '(:capability content :coordinate-mounts t)))
             (object (tp-object-resolve surface '(root)))
             (tagged
              (cl-remove-if-not
               (lambda (mount)
                 (stringp (tp--surface-mount-tags mount)))
               (gethash object (tp--surface-mount-index surface)))))
        (should (= (length tagged) 2))
        (should-not (eq (tp--surface-mount-tags (car tagged))
                        (tp--surface-mount-tags (cadr tagged))))
        (aset left-tags 0 ?X)
        (should (equal (mapcar (lambda (mount)
                                 (tp--surface-mount-tags mount))
                               tagged)
                       '("same" "same")))))))

(ert-deftest tp-surface-test-singular-content-range-snapshots-each-call ()
  "Separate singular attachments snapshot mutable tags independently."
  (tp-surface-test--with-buffer
    (let ((tags (list :slot 'before)))
      (let* ((producer
              (lambda (context)
                (let ((object (tp-object-ensure context nil 'root 'text)))
                  (tp-object-attach-content-range
                   context object object 0 1 tags)
                  (setcar (cdr tags) 'after)
                  (tp-object-attach-content-range
                   context object object 1 2 tags)
                  (tp-surface-plan-create
                   :key 'root :kind 'text :text "abc"
                   :capability 'content))))
             (surface (tp-surface-mount
                       buffer producer
                       '(:capability content :coordinate-mounts t)))
             (object (tp-object-resolve surface '(root))))
        (should (equal (tp-object-mounts object)
                       '((:start 1 :end 4 :tags nil)
                         (:start 1 :end 2 :tags (:slot before))
                         (:start 2 :end 3 :tags (:slot after)))))))))

(ert-deftest tp-surface-test-owned-batched-content-ranges-transfer-tags ()
  "Owned bulk ranges retain freshly allocated TAGS without another copy."
  (tp-surface-test--with-buffer
    (let ((tags (list :slot 'owned)))
      (let* ((producer
              (lambda (context)
                (let ((object (tp-object-ensure context nil 'root 'text)))
                  (tp-object-attach-content-ranges-owned
                   context object
                   (list (list :object object :start 0 :end 1 :tags tags)))
                  (tp-surface-plan-create
                   :key 'root :kind 'text :text "a"
                   :capability 'content))))
             (surface (tp-surface-mount
                       buffer producer
                       '(:capability content :coordinate-mounts t)))
             (object (tp-object-resolve surface '(root)))
             (mount (cadr (tp-object-mounts object))))
        (should (eq tags (tp--surface-mount-tags
                          (cadr (gethash object
                                         (tp--surface-mount-index surface))))))
        (should (equal (plist-get mount :tags) '(:slot owned)))))))

(ert-deftest tp-surface-test-owned-batched-content-ranges-reuse-tags-object ()
  "Owned bulk ranges reuse the same transferred TAGS object."
  (tp-surface-test--with-buffer
    (let ((tags (list :slot 'owned-same)))
      (let* ((producer
              (lambda (context)
                (let ((object (tp-object-ensure context nil 'root 'text)))
                  (tp-object-attach-content-ranges-owned
                   context object
                   (list (list :object object :start 0 :end 1 :tags tags)
                         (list :object object :start 1 :end 2 :tags tags)))
                  (tp-surface-plan-create
                   :key 'root :kind 'text :text "ab"
                   :capability 'content))))
             (surface (tp-surface-mount
                       buffer producer
                       '(:capability content :coordinate-mounts t)))
             (object (tp-object-resolve surface '(root)))
             (tagged
              (cl-remove-if-not
               (lambda (mount)
                 (equal (tp--surface-mount-tags mount)
                        '(:slot owned-same)))
               (gethash object (tp--surface-mount-index surface)))))
        (should (= (length tagged) 2))
        (should (eq (tp--surface-mount-tags (car tagged)) tags))
        (should (eq (tp--surface-mount-tags (car tagged))
                    (tp--surface-mount-tags (cadr tagged))))))))

(ert-deftest tp-surface-test-owned-batched-content-ranges-roll-back-tags ()
  "A failed owned range publication restores the previous live TAGS."
  (tp-surface-test--with-buffer
    (let ((text "a")
          (tags (list :slot 'live)))
      (cl-labels
          ((producer
            (context)
            (let ((object (tp-object-ensure context nil 'root 'text)))
              (tp-object-attach-content-ranges-owned
               context object
               (list (list :object object :start 0 :end 1 :tags tags)))
              (tp-surface-plan-create
               :key 'root :kind 'text :text text :capability 'content))))
        (let* ((surface (tp-surface-mount
                         buffer #'producer
                         '(:capability content :coordinate-mounts t)))
               (object (tp-object-resolve surface '(root)))
               (revision (tp-surface-revision surface))
               (live-tags
                (tp--surface-mount-tags
                 (cadr (gethash object
                                (tp--surface-mount-index surface)))))
               (candidate-tags (list :slot 'candidate)))
          (setq text "b"
                tags candidate-tags)
          (let ((tp--surface-publication-step-function
                 (lambda (step _surface)
                   (when (eq step 'client-state)
                     (error "Injected owned range rollback")))))
            (should-error (tp-surface-update surface #'producer)))
          (should (= (tp-surface-revision surface) revision))
          (should (equal (buffer-string) "a"))
          (should (eq object (tp-object-resolve surface '(root))))
          (should
           (eq live-tags
               (tp--surface-mount-tags
                (cadr (gethash object
                               (tp--surface-mount-index surface)))))))))))

(ert-deftest tp-surface-test-content-publication-preserves-point ()
  "Content publication writes properties without losing the point."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount
             buffer (tp-surface-test--leaf 'root "old value" '(face bold))
             '(:capability content)))
           (report
            (progn
              (goto-char 6)
              (tp-surface-update
               surface (tp-surface-test--leaf 'root "new value" '(face italic))))))
      (should (equal (buffer-string) "new value"))
      (should (eq (get-text-property 1 'face buffer) 'italic))
      (should (= (point) 6))
      (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
    (let (surface before revision)
      (add-hook 'after-change-functions
                #'tp-surface-test--corrupt-after-change nil t)
      (unwind-protect
          (progn
            (setq surface
                  (tp-surface-mount
                   buffer (tp-surface-test--leaf 'root "old" '(face bold))
                   '(:capability content)))
            (setq before (buffer-substring 1 4)
                  revision (tp-surface-revision surface)
                  tp-surface-test--corrupt-next t)
            (tp-surface-update
             surface (tp-surface-test--leaf 'root "new" '(face italic)))
            (should (equal (buffer-string) "new"))
            (should (= (tp-surface-revision surface) (1+ revision)))
            (should (eq (get-text-property 1 'face buffer) 'italic))
            (should-not (equal-including-properties (buffer-substring 1 4)
                                                     before)))
        (when (and surface (tp-surface-live-p surface))
          (tp-surface-unmount surface))
        (remove-hook 'after-change-functions
                     #'tp-surface-test--corrupt-after-change t)))))

(ert-deftest tp-surface-test-scoped-content-update-publishes-one-object ()
  "A scoped update should replace only its retained object's mounted text."
  (tp-surface-test--with-buffer
    (let ((middle "B") middle-object)
      (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-test--leaf 'left "A")
                       (tp-surface-test--leaf 'middle middle)
                       (tp-surface-test--leaf 'right "C")))))
             (surface
              (tp-surface-mount buffer producer '(:capability content)))
             (revision (tp-surface-revision surface)))
        (setq middle "LONG")
        (let ((report
               (tp-surface-update-scoped
                surface (list middle-object) producer)))
          (should (equal (buffer-string) "ALONGC"))
          (should (= (tp-surface-revision surface) (1+ revision)))
          (should-not (plist-get report :full-root))
          (should (= (plist-get report :scope-count) 1))
          (should (= (plist-get report :scope-range-count) 1))
          (should (= (plist-get report :touched-characters) 4)))))))

(ert-deftest tp-surface-test-scoped-update-can-skip-report-snapshot ()
  "A scoped caller may skip an unused defensive report snapshot."
  (tp-surface-test--with-buffer
    (let ((middle "B") middle-object)
      (let* ((producer
              (lambda (context)
                (let ((root (tp-object-ensure context nil 'root 'group)))
                  (setq middle-object
                        (tp-object-ensure context root 'middle 'text)))
                (tp-surface-plan-create
                 :key 'root :kind 'group :capability 'content
                 :children (list (tp-surface-test--leaf 'middle middle)))))
             (surface (tp-surface-mount buffer producer '(:capability content)))
             (copies 0)
             (original (symbol-function 'tp-surface-report)))
        (setq middle "LONG")
        (cl-letf (((symbol-function 'tp-surface-report)
                   (lambda (&rest arguments)
                     (cl-incf copies)
                     (apply original arguments))))
          (should-not
           (tp-surface-update-scoped
            surface (list middle-object) producer '(:return-report nil))))
        (should (= copies 0))
        (should (= (tp-surface-revision surface) 2))))))

(ert-deftest tp-surface-test-scoped-content-property-only-keeps-text-stable ()
  "A scoped property-only change must not replace its character range."
  (tp-surface-test--with-buffer
    (let ((middle-face 'bold) middle-object)
      (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-test--leaf 'left "A")
                       (tp-surface-test--leaf 'middle "B"
                                              (list 'face middle-face))
                       (tp-surface-test--leaf 'right "C")))))
             (surface
              (tp-surface-mount buffer producer '(:capability content)))
             (marker (copy-marker 3 t)))
        (setq middle-face 'italic)
        (cl-letf (((symbol-function 'delete-region)
                   (lambda (&rest _)
                     (error "Scoped property update replaced text"))))
          (let ((report
                 (tp-surface-update-scoped
                  surface (list middle-object) producer)))
            (should (= (plist-get report :text-operations) 0))
            (should (> (plist-get report :property-operations) 0))))
        (should (equal (buffer-string) "ABC"))
        (should (eq (get-text-property 2 'face) 'italic))
        (should (= (marker-position marker) 3))
        (set-marker marker nil)))))

(ert-deftest tp-surface-test-scoped-update-supports-disjoint-object-mounts ()
  "One logical scope should update all of its disjoint mounts atomically."
  (tp-surface-test--with-buffer
    (let ((left "A") (right "C") logical)
      (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 'left)
                  (tp-object-attach-fragment context logical right-object 'right)
                  (ignore gap-object))
                (tp-surface-plan-create
                 :key 'root :kind 'group :capability 'content
                 :children
                 (list (tp-surface-test--leaf 'left left)
                       (tp-surface-test--leaf 'gap "|")
                       (tp-surface-test--leaf 'right right)))))
             (surface
              (tp-surface-mount buffer producer '(:capability content)))
             (revision (tp-surface-revision surface)))
        (setq left "LEFT" right "RIGHT")
        (let ((report
               (tp-surface-update-scoped surface (list logical) producer)))
          (should (equal (buffer-string) "LEFT|RIGHT"))
          (should (= (tp-surface-revision surface) (1+ revision)))
          (should (= (plist-get report :scope-count) 1))
          (should (= (plist-get report :scope-range-count) 2))
          (should (= (plist-get report :text-operations) 2)))))))

(ert-deftest tp-surface-test-scoped-update-adds-and-removes-owned-output ()
  "A retained scope should add or remove its owned output between stable text."
  (tp-surface-test--with-buffer
    (let ((visible nil) logical)
      (let* ((producer
              (lambda (context)
                (let* ((root (tp-object-ensure context nil 'root 'group))
                       (left (tp-object-ensure context root 'left 'text))
                       (middle (and visible
                                    (tp-object-ensure
                                     context root 'middle 'text))))
                  (tp-object-ensure context root 'gap 'text)
                  (tp-object-ensure context root 'right 'text)
                  (setq logical
                        (tp-object-ensure context root 'logical 'item))
                  (tp-object-retain context logical)
                  (when middle
                    (tp-object-attach-fragment context logical middle 'owned))
                  (ignore left))
                (tp-surface-plan-create
                 :key 'root :kind 'group :capability 'content
                 :children
                 (delq nil
                       (list (tp-surface-test--leaf 'left "A")
                             (and visible
                                  (tp-surface-test--leaf 'middle "B"))
                             (tp-surface-test--leaf 'gap "|")
                             (tp-surface-test--leaf 'right "C"))))))
             (surface
              (tp-surface-mount buffer producer '(:capability content))))
        (should (equal (buffer-string) "A|C"))
        (setq visible t)
        (let ((report
               (tp-surface-update-scoped surface (list logical) producer)))
          (should (equal (buffer-string) "AB|C"))
          (should (= (plist-get report :text-operations) 1)))
        (setq visible nil)
        (let ((report
               (tp-surface-update-scoped surface (list logical) producer)))
          (should (equal (buffer-string) "A|C"))
          (should (= (plist-get report :text-operations) 1)))))))

(ert-deftest tp-surface-test-scoped-update-survives-outer-transaction ()
  "A scoped request should remain attached until its outer transaction flushes."
  (tp-surface-test--with-buffer
    (let ((middle "B") middle-object)
      (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-test--leaf 'left "A")
                       (tp-surface-test--leaf 'middle middle)
                       (tp-surface-test--leaf 'right "C")))))
             (surface
              (tp-surface-mount buffer producer '(:capability content))))
        (setq middle "LONG")
        (tp-with-transaction
          (tp-surface-update-scoped surface (list middle-object) producer))
        (should (equal (buffer-string) "ALONGC"))
        (should-not (plist-get (tp-surface-report surface) :full-root))
        (setq middle "NEXT")
        (tp-surface-update surface producer)
        (should (equal (buffer-string) "ANEXTC"))
        (should (plist-get (tp-surface-report surface) :full-root))))))

(ert-deftest tp-surface-test-scoped-properties-update-publishes-one-object ()
  "A properties scope should leave another retained range untouched."
  (tp-surface-test--with-buffer
    (insert "left|right")
    (let* ((left-anchor (tp-range-anchor-create buffer 1 5))
           (right-anchor (tp-range-anchor-create buffer 6 11))
           (left-face 'bold)
           left-object
           (producer
            (lambda (context)
              (let ((root (tp-object-ensure context nil 'root 'group)))
                (setq left-object
                      (tp-object-ensure context root 'left 'range))
                (tp-object-attach-range context left-object left-anchor)
                (let ((right-object
                       (tp-object-ensure context root 'right 'range)))
                  (tp-object-attach-range context right-object right-anchor)))
              (tp-surface-plan-create
               :key 'root :kind 'group :capability 'properties
               :children
               (list
                (tp-surface-plan-create
                 :key 'left :kind 'range :props (list 'face left-face)
                 :capability 'properties)
                (tp-surface-plan-create
                 :key 'right :kind 'range :props '(face italic)
                 :capability 'properties)))))
           (surface
            (tp-surface-mount buffer producer '(:capability properties))))
      (setq left-face 'underline)
      (let ((report
             (tp-surface-update-scoped surface (list left-object) producer)))
        (should (eq (get-text-property 2 'face) 'underline))
        (should (eq (get-text-property 7 'face) 'italic))
        (should-not (plist-get report :full-root))
        (should (= (plist-get report :scope-range-count) 1))
        (should (= (plist-get report :property-operations) 1))))))

(ert-deftest tp-surface-test-sparse-property-update-does-not-scan-between-anchors ()
  "A sparse properties update inspects only owned anchor intervals."
  (tp-surface-test--with-buffer
    (insert (make-string 120 ?x))
    (let* ((left-anchor (tp-range-anchor-create buffer 2 3))
           (right-anchor (tp-range-anchor-create buffer 100 101))
           (left-face 'bold)
           (producer
            (lambda (context)
              (let ((root (tp-object-ensure context nil 'root 'group)))
                (let ((left (tp-object-ensure context root 'left 'range))
                      (right (tp-object-ensure context root 'right 'range)))
                  (tp-object-attach-range context left left-anchor)
                  (tp-object-attach-range context right right-anchor)))
              (tp-surface-plan-create
               :key 'root :kind 'group :capability 'properties
               :children
               (list
                (tp-surface-plan-create
                 :key 'left :kind 'range :props (list 'face left-face)
                 :capability 'properties)
                (tp-surface-plan-create
                 :key 'right :kind 'range :props '(face italic)
                 :capability 'properties)))))
           (surface
            (tp-surface-mount buffer producer '(:capability properties))))
      (setq left-face 'underline)
      (let ((original (symbol-function 'next-single-property-change)))
        (cl-letf (((symbol-function 'next-single-property-change)
                   (lambda (position property &optional object limit)
                     (unless (or (and (>= position 2) (< position 3))
                                 (and (>= position 100) (< position 101)))
                       (error "Unexpected sparse scan at %s for %s"
                              position property))
                     (funcall original position property object limit))))
          (tp-surface-update surface producer)))
      (should (eq (get-text-property 2 'face) 'underline))
      (should (eq (get-text-property 100 'face) 'italic)))))

(ert-deftest tp-surface-test-scoped-update-can-explicitly-fall-back-to-root ()
  "A scoped mismatch should publish the root only when explicitly requested."
  (tp-surface-test--with-buffer
    (let ((middle "B") (right "C") middle-object)
      (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-test--leaf 'left "A")
                       (tp-surface-test--leaf 'middle middle)
                       (tp-surface-test--leaf 'right right)))))
             (surface
              (tp-surface-mount buffer producer '(:capability content))))
        (setq middle "M" right "OUTSIDE")
        (let ((report
               (tp-surface-update-scoped
                surface (list middle-object) producer
                '(:on-mismatch root))))
          (should (equal (buffer-string) "AMOUTSIDE"))
          (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
    (let ((middle "B") (right "C") middle-object)
      (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-test--leaf 'left "A")
                       (tp-surface-test--leaf 'middle middle)
                       (tp-surface-test--leaf 'right right)))))
             (surface
              (tp-surface-mount buffer producer '(:capability content)))
             (revision (tp-surface-revision surface)))
        (setq middle "M" right "OUTSIDE")
        (should-error
         (tp-surface-update-scoped surface (list middle-object) producer)
         :type 'tp-scope-mismatch)
        (should (= (tp-surface-revision surface) revision))
        (should (equal (buffer-string) "ABC"))))))

(ert-deftest tp-surface-test-scoped-update-rolls-back-buffer-and-mounts ()
  "A failed scoped publication should restore text, revision, and mounts."
  (tp-surface-test--with-buffer
    (let ((middle "B") middle-object)
      (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-test--leaf 'left "A")
                       (tp-surface-test--leaf 'middle middle)
                       (tp-surface-test--leaf 'right "C")))))
             (surface
              (tp-surface-mount buffer producer '(:capability content)))
             (revision (tp-surface-revision surface))
             (mounts (tp-object-mounts middle-object)))
        (setq middle "LONG")
        (let ((tp--surface-publication-step-function
               (lambda (step _surface)
                 (when (eq step 'client-state)
                   (error "Injected scoped failure")))))
          (should-error
           (tp-surface-update-scoped surface (list middle-object) producer)))
        (should (= (tp-surface-revision surface) revision))
        (should (equal (buffer-string) "ABC"))
        (should (eq middle-object (tp-object-resolve surface '(root middle))))
        (should (equal (tp-object-mounts middle-object) mounts))))))

(ert-deftest tp-surface-test-failed-candidate-does-not-leak-object ()
  "A failed update preserves the live tree and invalidates new handles."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
                              '(:capability content)))
           (root (tp-object-resolve surface '(root)))
           candidate)
      (should-error
       (tp-surface-update
        surface
        (lambda (context)
          (tp-object-ensure context nil 'root 'text)
          (setq candidate (tp-object-ensure context root 'orphan 'text))
          (tp-surface-test--leaf 'root "new")))
       :type 'tp-orphan-object)
      (should (equal (buffer-string) "old"))
      (should (eq root (tp-object-resolve surface '(root))))
      (should-not (tp-object-live-p candidate)))))

(ert-deftest tp-surface-test-logical-object-can-own-disjoint-fragments ()
  "One retained object can resolve several output fragments without scans."
  (tp-surface-test--with-buffer
    (let ((first "A") (second "BC"))
      (let* ((producer
              (lambda (context)
                (let* ((root (tp-object-ensure context nil 'root 'group))
                       (logical
                        (tp-object-ensure context root 'logical 'item))
                       (left
                        (tp-object-ensure context root 'left 'fragment))
                       (right
                        (tp-object-ensure context root 'right 'fragment)))
                  (tp-object-retain context logical)
                  (tp-object-attach-fragment
                   context logical left '(:slot left))
                  (tp-object-attach-fragment
                   context logical right '(:slot right)))
                (tp-surface-plan-create
                 :key 'root :kind 'group :capability 'content
                 :children
                 (list (tp-surface-test--leaf 'left first)
                       (tp-surface-test--leaf 'right second)))))
             (surface (tp-surface-mount
                       buffer producer '(:capability content)))
             (logical (tp-object-resolve surface '(root logical))))
        (should (tp-object-live-p logical))
        (should (equal (tp-object-mounts logical)
                       '((:start 1 :end 2 :tags (:slot left))
                         (:start 2 :end 4 :tags (:slot right)))))
        (should (memq logical (tp-surface-at-point 1 buffer)))
        (should (memq logical (tp-surface-at-point 3 buffer)))
        (setq first "AA" second "BBB")
        (cl-letf (((symbol-function 'buffer-list)
                   (lambda (&rest _) (error "Unexpected buffer scan")))
                  ((symbol-function 'text-property-search-forward)
                   (lambda (&rest _) (error "Unexpected property scan"))))
          (tp-surface-update surface producer))
        (should (eq logical (tp-object-resolve surface '(root logical))))
        (should (equal (tp-object-mounts logical)
                       '((:start 1 :end 3 :tags (:slot left))
                         (:start 3 :end 6 :tags (:slot right)))))))))

(ert-deftest tp-surface-test-retain-subtree-preserves-omitted-objects-and-bindings ()
  "Retaining a live subtree preserves its objects and default bindings."
  (tp-surface-test--with-buffer
    (let ((value "before") logical child binding)
      (cl-labels
          ((producer (context)
             (let ((root (tp-object-ensure context nil 'root 'group)))
               (if logical
                   (tp-object-retain-subtree context logical)
                 (setq logical
                       (tp-object-ensure context root 'logical 'group)
                       child
                       (tp-object-ensure context logical 'child 'item)
                       binding
                       (tp-bind logical '(test . value)
                                (lambda () value)))
                   (tp-object-retain context logical)
                   (tp-object-retain context child))
               (tp-object-ensure context root 'text 'text)
               (tp-surface-plan-create
                :key 'root :kind 'group :capability 'content
                :children (list (tp-surface-test--leaf 'text value))))))
        (let* ((surface (tp-surface-mount
                         buffer #'producer '(:capability content)))
               (revision (tp-surface-revision surface)))
          (setq value "after")
          (tp-surface-update surface #'producer)
          (should (= (tp-surface-revision surface) (1+ revision)))
          (should (eq logical (tp-object-resolve surface '(root logical))))
          (should (eq child (tp-object-resolve
                             surface '(root logical child))))
          (should (tp-binding-live-p binding))
          (should (equal (buffer-string) "after")))))))

(ert-deftest tp-surface-test-reuse-subtree-skips-unchanged-reconcile ()
  "Reusing a proven subtree keeps its objects without reconciling them."
  (tp-surface-test--with-buffer
    (let ((value "before") logical child binding)
      (cl-labels
          ((producer (context)
             (let ((root (tp-object-ensure context nil 'root 'group)))
               (if logical
                   (tp-object-reuse-subtree context logical)
                 (setq logical
                       (tp-object-ensure context root 'logical 'group)
                       child
                       (tp-object-ensure context logical 'child 'item)
                       binding
                       (tp-bind logical '(test . value)
                                (lambda () value)))
                 (tp-object-retain context logical)
                 (tp-object-retain context child))
               (tp-object-ensure context root 'text 'text))
             (tp-surface-plan-create
              :key 'root :kind 'group :capability 'content
              :children (list (tp-surface-test--leaf 'text value)))))
        (let* ((surface (tp-surface-mount
                         buffer #'producer '(:capability content)))
               (revision (tp-surface-revision surface)))
          (setq value "after")
          (tp-surface-update surface #'producer)
          (should (= (tp-surface-revision surface) (1+ revision)))
          (should (= (plist-get (tp-surface-report surface)
                                :reconciled-objects)
                     2))
          (should (eq logical (tp-object-resolve surface '(root logical))))
          (should (eq child (tp-object-resolve
                             surface '(root logical child))))
          (should (tp-binding-live-p binding))
          (should (equal (buffer-string) "after")))))))

(ert-deftest tp-surface-test-reuse-one-preserves-only-proven-object ()
  "Single-object reuse retains that identity without retaining a removed peer."
  (tp-surface-test--with-buffer
    (let ((value "before") kept removed)
      (cl-labels
          ((producer (context)
             (let ((root (tp-object-ensure context nil 'root 'group)))
               (if kept
                   (tp-object-reuse context kept)
                 (setq kept (tp-object-ensure context root 'kept 'item)
                       removed (tp-object-ensure context root 'removed 'item))
                 (tp-object-retain context kept)
                 (tp-object-retain context removed))
               (tp-object-ensure context root 'text 'text))
             (tp-surface-plan-create
              :key 'root :kind 'group :capability 'content
              :children (list (tp-surface-test--leaf 'text value)))))
        (let ((surface (tp-surface-mount
                        buffer #'producer '(:capability content))))
          (setq value "after")
          (tp-surface-update surface #'producer)
          (should (eq kept (tp-object-resolve surface '(root kept))))
          (should-not (tp-object-live-p removed))
          (should (equal (buffer-string) "after")))))))

(ert-deftest tp-surface-test-ensure-at-reuses-anonymous-slot-without-prefix-replay ()
  "Compiled topology can address one anonymous slot directly."
  (tp-surface-test--with-buffer
    (let (second)
      (cl-labels
          ((producer (context)
             (let ((root (tp-object-ensure context nil 'root 'group)))
               (if second
                   (progn
                     (tp-object-reuse
                      context
                      (tp-object-resolve
                       (tp--context-surface context)
                       '(root (:position 0 :kind item))))
                     (setq second
                           (tp-object-ensure-at context root nil 'item 1)))
                 (tp-object-retain
                  context (tp-object-ensure context root nil 'item))
                 (setq second (tp-object-ensure context root nil 'item))
                 (tp-object-retain context second))
               (tp-object-retain context second))
             (tp-surface-plan-create
              :key 'root :kind 'group :capability 'content)))
        (let ((surface (tp-surface-mount
                        buffer #'producer '(:capability content)))
              (identity second))
          (tp-surface-update surface #'producer)
          (should (eq identity second)))))))

(ert-deftest tp-surface-test-logical-object-owns-leaf-local-ranges ()
  "One logical object can own multiple ranges in one content leaf."
  (tp-surface-test--with-buffer
    (let* ((producer
            (lambda (context)
              (let* ((root (tp-object-ensure context nil 'root 'group))
                     (left (tp-object-ensure context root 'left 'item))
                     (right (tp-object-ensure context root 'right 'item))
                     (leaf (tp-object-ensure context root 'leaf 'text)))
                (tp-object-attach-content-range
                 context left leaf 0 1 '(:slot left))
                (tp-object-attach-content-range
                 context left leaf 3 4 '(:slot right))
                (tp-object-attach-content-range
                 context right leaf 1 3 '(:slot middle)))
              (tp-surface-plan-create
               :key 'root :kind 'group :capability 'content
               :children
               (list (tp-surface-plan-create
                      :key 'leaf :kind 'text :text "ABCD"
                      :capability 'content)))))
           (surface (tp-surface-mount
                     buffer producer '(:capability content)))
           (left (tp-object-resolve surface '(root left)))
           (right (tp-object-resolve surface '(root right))))
      (should (equal (buffer-string) "ABCD"))
      (should (equal (tp-object-mounts left)
                     '((:start 1 :end 2 :tags (:slot left))
                       (:start 4 :end 5 :tags (:slot right)))))
      (should (equal (tp-object-mounts right)
                     '((:start 2 :end 4 :tags (:slot middle))))))))

(ert-deftest tp-surface-test-leaf-local-ranges-validate-before-publication ()
  "Leaf-local ranges reject malformed and out-of-bounds attachments."
  (tp-surface-test--with-buffer
    (let ((producer
           (lambda (context)
             (let* ((root (tp-object-ensure context nil 'root 'group))
                    (owner (tp-object-ensure context root 'owner 'item))
                    (leaf (tp-object-ensure context root 'leaf 'text)))
               (tp-object-attach-content-range
                context owner leaf 0 0 '(:slot empty)))
             (tp-surface-plan-create
              :key 'root :kind 'group :capability 'content
              :children
              (list (tp-surface-plan-create
                     :key 'leaf :kind 'text :text "AB"
                     :capability 'content))))))
      (should-error (tp-surface-mount buffer producer '(:capability content))
                    :type 'tp-invalid-content-range)
      (let ((producer
             (lambda (context)
               (let* ((root (tp-object-ensure context nil 'root 'group))
                      (owner (tp-object-ensure context root 'owner 'item))
                      (leaf (tp-object-ensure context root 'leaf 'text)))
                 (tp-object-attach-content-range
                  context owner leaf 0 3 '(:slot too-long)))
               (tp-surface-plan-create
                :key 'root :kind 'group :capability 'content
                :children
                (list (tp-surface-plan-create
                       :key 'leaf :kind 'text :text "AB"
                       :capability 'content))))))
        (should-error (tp-surface-mount buffer producer '(:capability content))
                      :type 'tp-invalid-content-range)))))

(ert-deftest tp-surface-test-explicitly-retained-object-may-be-unmounted ()
  "An explicitly retained logical object may have no rendered characters."
  (tp-surface-test--with-buffer
    (let* ((producer
            (lambda (context)
              (let* ((root (tp-object-ensure context nil 'root 'group))
                     (hidden (tp-object-ensure context root 'hidden 'item)))
                (tp-object-retain context hidden)
                (tp-object-ensure context root 'visible 'text))
              (tp-surface-plan-create
               :key 'root :kind 'group :capability 'content
               :children (list (tp-surface-test--leaf 'visible "x")))))
           (surface (tp-surface-mount
                     buffer producer '(:capability content)))
           (hidden (tp-object-resolve surface '(root hidden))))
      (should (tp-object-live-p hidden))
      (should-not (tp-object-mounts hidden)))))

(ert-deftest tp-surface-test-prepared-mount-ids-preserve-signature-order ()
  "Mount IDs follow first-unused EQ identities and equal tags in spec order."
  (let* ((tp--mount-id-counter 1000)
         (object (tp--make-surface-object :id 1))
         (equal-object (copy-sequence object))
         (other-object (tp--make-surface-object :id 2))
         (anchor (tp--make-range-anchor :id 1))
         (equal-anchor (copy-sequence anchor))
         (index (make-hash-table :test #'eq))
         (records
          (list (list nil object 'content anchor '(:slot unused))
                (list 11 object 'content anchor '(:slot duplicate))
                (list 12 object 'properties anchor '(:slot duplicate))
                (list nil object 'content anchor '(:slot duplicate))
                (list 13 object 'content equal-anchor '(:slot duplicate))
                (list 14 object 'content anchor '(:slot other))
                (list 21 equal-object 'content anchor '(:slot duplicate))
                (list 31 other-object 'content nil '(:slot other))))
         (live
          (cl-loop for (id owner capability attachment tags) in records
                   for position from 1
                   collect (tp--make-surface-mount
                            :id id :object owner :capability capability
                            :anchor attachment :tags (copy-tree tags)
                            :start position :end (1+ position))))
         (spec-signatures
          (list (list object anchor '(:slot other))
                (list equal-object anchor '(:slot duplicate))
                (list object anchor '(:slot duplicate))
                (list object equal-anchor '(:slot duplicate))
                (list object anchor '(:slot duplicate))
                (list object anchor '(:slot duplicate))
                (list equal-object equal-anchor '(:slot duplicate))
                (list equal-object anchor '(:slot duplicate))
                (list other-object nil '(:slot other))
                (list object anchor '(:slot absent))))
         (specs
          (cl-loop for (owner attachment tags) in spec-signatures
                   for position from 101
                   collect (list :object owner :anchor attachment
                                 :tags (copy-tree tags) :mount-id -1
                                 :start position :end (+ position 2))))
         (surface (tp--make-surface :capability 'content
                                    :mounts live :mount-index index))
         (prepared (tp--make-prepared-surface :surface surface :mount-specs specs))
         saved-buckets)
    (should (equal object equal-object))
    (should-not (eq object equal-object))
    (should (equal anchor equal-anchor))
    (should-not (eq anchor equal-anchor))
    (dolist (mount live)
      (let ((owner (tp--surface-mount-object mount)))
        (puthash owner (append (gethash owner index) (list mount)) index)))
    ;; Preserve the matcher's single-use and identity checks even when a
    ;; bucket repeats a record or contains an entry owned by another object.
    (puthash object (append (gethash object index)
                            (list (nth 1 live) (nth 6 live)))
             index)
    (maphash
     (lambda (owner bucket)
       (push (list owner bucket (copy-sequence bucket)
                   (cl-loop for tail on bucket collect tail))
             saved-buckets))
     index)
    (should (eq prepared (tp--assign-prepared-mount-ids prepared)))
    (should (equal (mapcar (lambda (spec) (plist-get spec :mount-id))
                          (tp--prepared-surface-mount-specs prepared))
                   '(14 21 11 13 1001 1002 1003 1004 31 1005)))
    (should (= tp--mount-id-counter 1005))
    ;; An unmatched live mount must not receive an ID while an index is built.
    (should-not (tp--surface-mount-id (car live)))
    (should (= (tp--surface-mount-id (nth 3 live)) 1001))
    (should (eq live (tp--surface-mounts surface)))
    (should (eq index (tp--surface-mount-index surface)))
    (should (= (hash-table-count index) 3))
    (dolist (saved saved-buckets)
      (let ((bucket (gethash (nth 0 saved) index)))
        (should (eq (nth 1 saved) bucket))
        (should (equal (nth 2 saved) bucket))
        (should (cl-every #'identity
                          (cl-mapcar #'eq (nth 3 saved)
                                     (cl-loop for tail on bucket collect tail))))))
    (cl-loop for spec in (tp--prepared-surface-mount-specs prepared)
             for (owner attachment tags) in spec-signatures
             for position from 101
             do (should (eq owner (plist-get spec :object)))
             (should (eq attachment (plist-get spec :anchor)))
             (should (equal tags (plist-get spec :tags)))
             (should (= position (plist-get spec :start)))
             (should (= (+ position 2) (plist-get spec :end))))))

(ert-deftest tp-surface-test-prepared-mount-ids-bound-candidate-scans ()
  "Growing duplicate mounts must not repeatedly scan their used prefix."
  (let ((assign (tp-surface-test--source-function 'tp--assign-prepared-mount-ids))
        (find-if (symbol-function 'cl-find-if))
        samples)
    (dolist (count '(16 32 64))
      (let* ((tp--mount-id-counter 1000)
             (object (tp--make-surface-object :id 1))
             (live (cl-loop for id from 1 to count
                            collect (tp--make-surface-mount
                                     :id id :object object :capability 'content
                                     :tags (list :slot 'same) :start id :end (1+ id))))
             (index (make-hash-table :test #'eq))
             (surface (tp--make-surface :capability 'content
                                        :mounts live :mount-index index))
             (prepared
              (tp--make-prepared-surface
               :surface surface
               :mount-specs
               (cl-loop for position from 101 below (+ 101 count)
                        collect (list :object object :tags (list :slot 'same)
                                      :start position :end (1+ position)))))
             (visits 0))
        (puthash object live index)
        ;; Count actual predicate visits, including candidates rejected by the
        ;; used-prefix check before comparing their matching signature.
        ;; This bounds candidate scans, not the complete assignment algorithm.
        (cl-letf (((symbol-function 'cl-find-if)
                   (lambda (predicate sequence &rest options)
                     (apply find-if
                            (lambda (mount)
                              (cl-incf visits)
                              (funcall predicate mount))
                            sequence options))))
          (funcall assign prepared))
        (should (equal (mapcar (lambda (spec) (plist-get spec :mount-id))
                              (tp--prepared-surface-mount-specs prepared))
                       (number-sequence 1 count)))
        (should (= tp--mount-id-counter 1000))
        (push (cons count visits) samples)))
    (ert-info ((format "mount count / candidate visits: %S" (reverse samples)))
      (dolist (sample samples)
        (should (<= (cdr sample) (* 2 (car sample))))))))

(ert-deftest tp-surface-test-disjoint-mount-index-rolls-back-atomically ()
  "Failed publication restores every mount of a retained logical object."
  (tp-surface-test--with-buffer
    (let ((value "A"))
      (let* ((producer
              (lambda (context)
                (let* ((root (tp-object-ensure context nil 'root 'group))
                       (logical
                        (tp-object-ensure context root 'logical 'item))
                       (left
                        (tp-object-ensure context root 'left 'fragment))
                       (right
                        (tp-object-ensure context root 'right 'fragment)))
                  (tp-object-retain context logical)
                  (tp-object-attach-fragment context logical left 'left)
                  (tp-object-attach-fragment context logical right 'right))
                (tp-surface-plan-create
                 :key 'root :kind 'group :capability 'content
                 :children
                 (list (tp-surface-test--leaf 'left value)
                       (tp-surface-test--leaf 'right value)))))
             (surface (tp-surface-mount
                       buffer producer '(:capability content)))
             (logical (tp-object-resolve surface '(root logical)))
             (mounts (tp-object-mounts logical))
             (live (tp--surface-mounts surface))
             (index (tp--surface-mount-index surface))
             (bucket (gethash logical index))
             (mount-ids (mapcar #'tp--surface-mount-id live))
             (revision (tp-surface-revision surface)))
        (setq value "LONG")
        (let ((tp--surface-publication-step-function
               (lambda (step _surface)
                 (when (eq step 'client-state)
                   (error "Injected mount-index failure")))))
          (should-error (tp-surface-update surface producer)))
        (should (= (tp-surface-revision surface) revision))
        (should (equal (buffer-string) "AA"))
        (should (eq logical (tp-object-resolve surface '(root logical))))
        (should (equal (tp-object-mounts logical) mounts))
        (should (eq live (tp--surface-mounts surface)))
        (should (eq index (tp--surface-mount-index surface)))
        (should (eq bucket (gethash logical index)))
        (should (equal mount-ids (mapcar #'tp--surface-mount-id live)))
        (tp-surface-update surface producer)
        (should (= (tp-surface-revision surface) (1+ revision)))
        (should (equal (buffer-string) "LONGLONG"))
        (should (eq logical (tp-object-resolve surface '(root logical))))
        (should (equal mount-ids
                       (mapcar #'tp--surface-mount-id (tp--surface-mounts surface))))
        (should (equal (tp-object-mounts logical)
                       '((:start 1 :end 5 :tags left)
                         (:start 5 :end 9 :tags right))))))))

(ert-deftest tp-surface-test-properties-capability-rejects-text ()
  "A properties-only mount cannot replace host text."
  (tp-surface-test--with-buffer
    (insert "host")
    (should-error
     (tp-surface-mount buffer (tp-surface-test--leaf 'root "replacement")
                       '(:capability properties))
     :type 'tp-capability-error)
    (should (equal (buffer-string) "host"))))

(ert-deftest tp-surface-test-range-anchor-follows-edits-before-it ()
  "A host insertion before an anchor moves its property contribution."
  (tp-surface-test--with-buffer
    (insert "012345")
    (let* ((anchor (tp-range-anchor-create buffer 3 5))
           (value "A")
           (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 'help-echo value)
               :capability 'properties)))
           (surface (tp-surface-mount
                     buffer producer '(:capability properties))))
      (should (equal (get-text-property 3 'help-echo) "A"))
      (goto-char 1)
      (insert "X")
      (setq value "B")
      (tp-surface-update surface producer)
      (should (equal (get-text-property 4 'help-echo) "B"))
      (should-not (get-text-property 3 'help-echo)))))

(ert-deftest tp-surface-test-property-conflict-needs-explicit-rebase ()
  "TP preserves an external property write until the anchor is rebased."
  (tp-surface-test--with-buffer
    (insert "host")
    (let* ((anchor (tp-range-anchor-create buffer 1 5))
           (value "A")
           (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 'help-echo value)
               :capability 'properties)))
           (surface (tp-surface-mount
                     buffer producer '(:capability properties)))
           (revision (tp-surface-revision surface)))
      (put-text-property 1 5 'help-echo "external")
      (setq value "B")
      (should-error (tp-surface-update surface producer)
                    :type 'tp-property-conflict)
      (should (= (tp-surface-revision surface) revision))
      (should (equal (get-text-property 2 'help-echo) "external"))
      (tp-range-rebase anchor)
      (tp-surface-update surface producer)
      (should (equal (get-text-property 2 'help-echo) "B"))
      (tp-surface-unmount surface)
      (should (equal (get-text-property 2 'help-echo) "external")))))

(ert-deftest tp-surface-test-property-update-uses-policy-equality ()
  "Retained property comparison uses the registered text-property policy."
  (tp-surface-test--with-buffer
    (insert "host")
    (let* ((old-policy (tp-property-policy 'text/help-echo))
           (anchor (tp-range-anchor-create buffer 1 5))
           (value "A")
           surface)
      (unwind-protect
          (progn
            (tp-define-property-policy
             'text/help-echo
             :equality (lambda (left right)
                         (string-equal (downcase left) (downcase right)))
             :merge (lambda (_old new) new)
             :projector (lambda (v) (list 'help-echo v)))
            (setq surface
                  (tp-surface-mount
                   buffer
                   (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 'help-echo value)
                      :capability 'properties))
                   '(:capability properties)))
            (let ((revision (tp-surface-revision surface)))
              (setq value "a")
              (tp-surface-update surface (tp--surface-producer surface))
              (should (= (tp-surface-revision surface) revision))
              (should (= (plist-get (tp-surface-report surface)
                                    :property-operations)
                         1))
              (should (equal (get-text-property 2 'help-echo) "A"))))
        (when old-policy
          (puthash 'text/help-echo old-policy tp--property-policies))
        (when (and surface (tp-surface-live-p surface))
          (tp-surface-unmount surface))))))

(ert-deftest tp-surface-test-content-property-diff-uses-policy-equality ()
  "Content publication skips policy-equal property writes."
  (tp-surface-test--with-buffer
    (let ((old-policy (tp-property-policy 'text/help-echo))
          (value "A")
          (client-state 1)
          surface producer)
      (unwind-protect
          (progn
            (tp-define-property-policy
             'text/help-echo
             :equality (lambda (left right)
                         (string-equal (downcase left) (downcase right)))
             :merge (lambda (_old new) new)
             :projector (lambda (current) (list 'help-echo current)))
            (setq producer
                  (lambda (context)
                    (tp-object-ensure context nil 'root 'text)
                    (tp-surface-result-create
                     (tp-surface-test--leaf
                      'root "text" (list 'help-echo value))
                     (list :state client-state)))
                  surface (tp-surface-mount
                           buffer producer '(:capability content)))
            (let ((revision (tp-surface-revision surface)))
              (setq value "a" client-state 2)
              (let ((report (tp-surface-update surface producer)))
                (should (= (tp-surface-revision surface) (1+ revision)))
                (should (= (plist-get report :property-operations) 0))
                (should (equal (get-text-property 1 'help-echo) "A")))))
        (when old-policy
          (puthash 'text/help-echo old-policy tp--property-policies))
        (when (and surface (tp-surface-live-p surface))
          (tp-surface-unmount surface))))))

(ert-deftest tp-surface-test-content-property-diff-detects-interior-boundary ()
  "Content property diffing notices a mismatch after a matching first char."
  (tp-surface-test--with-buffer
    (insert "abc")
    (put-text-property 1 2 'face 'bold)
    (let ((rendered (copy-sequence "abc")))
      (put-text-property 0 3 'face 'bold rendered)
      (should (tp--string-property-run-diff-p
               buffer 1 rendered 0 3)))))

(ert-deftest tp-surface-test-unmount-preserves-conflicting-host-value ()
  "Unmount removes only TP's still-current property contribution."
  (tp-surface-test--with-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 '(help-echo "tp")
               :capability 'properties)))
           (surface (tp-surface-mount
                     buffer producer '(:capability properties))))
      (put-text-property 1 5 'help-echo "external")
      (let ((report (tp-surface-unmount surface)))
        (should (plist-get report :property-conflicts)))
      (should (equal (get-text-property 2 'help-echo) "external"))
      (should-not (tp-surface-live-p surface))
      (should-not (tp-range-anchor-live-p anchor)))))

(ert-deftest tp-surface-test-complete-anchor-deletion-applies-boundary-policy ()
  "Deleting an entire anchor span applies stale, shorten, and remove policy."
  (dolist (case '((stale . t) (shorten . nil) (remove . remove)))
    (tp-surface-test--with-buffer
      (insert "abcd")
      (let* ((policy (car case))
             (expected (cdr case))
             (anchor (tp-range-anchor-create
                      buffer 2 4 :boundary-policy policy))
             (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 '(help-echo "tp")
                 :capability 'properties)))
             (surface
              (tp-surface-mount buffer producer '(:capability properties))))
        (delete-region 2 4)
        (should (eq (tp--anchor-stale anchor) expected))
        (when expected
          (should-error (tp-surface-update surface producer)
                        :type 'tp-stale-mount))))))

(ert-deftest tp-surface-test-complete-content-deletion-marks-surface-stale ()
  "Deleting a content surface's full span makes the mount stale."
  (tp-surface-test--with-buffer
    (let ((surface
           (tp-surface-mount buffer (tp-surface-test--leaf 'root "abc")
                             '(:capability content))))
      (delete-region 1 4)
      (should (tp--surface-stale surface))
      (should-error
       (tp-surface-update surface (tp-surface-test--leaf 'root "next"))
       :type 'tp-stale-mount))))

(ert-deftest tp-surface-test-failed-prepare-rolls-back-direct-buffer-mutation ()
  "Producer buffer edits during prepare roll back when preparation fails."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
                              '(:capability content)))
           (revision (tp-surface-revision surface)))
      (should-error
       (tp-surface-update
        surface
        (lambda (context)
          (goto-char (point-min))
          (insert "BAD")
          (tp-object-ensure context nil 'other 'text)
          (tp-surface-test--leaf 'root "new")))
       :type 'tp-surface-error)
      (should (equal (buffer-string) "old"))
      (should-not (tp--surface-stale surface))
      (should (= (tp-surface-revision surface) revision)))))

(ert-deftest tp-surface-test-successful-prepare-rejects-direct-buffer-mutation ()
  "Producers cannot commit live surface buffers outside TP publication."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
                              '(:capability content)))
           (revision (tp-surface-revision surface)))
      (should-error
       (tp-surface-update
        surface
        (lambda (context)
          (tp-object-ensure context nil 'root 'text)
          (goto-char (point-min))
          (insert "BAD")
          (tp-surface-test--leaf 'root "new")))
       :type 'tp-surface-error)
      (should (equal (buffer-string) "old"))
      (should-not (tp--surface-stale surface))
      (should (= (tp-surface-revision surface) revision)))))

(ert-deftest tp-surface-test-prepare-rejects-direct-property-mutation ()
  "Producers cannot write live surface properties during prepare."
  (tp-surface-test--with-buffer
    (let* ((surface
            (tp-surface-mount
             buffer (tp-surface-test--leaf 'root "old" '(help-echo "old"))
             '(:capability content)))
           (revision (tp-surface-revision surface)))
      (should-error
       (tp-surface-update
        surface
        (lambda (context)
          (tp-object-ensure context nil 'root 'text)
          (put-text-property (point-min) (1+ (point-min))
                             'help-echo "BAD")
          (tp-surface-test--leaf 'root "new" '(help-echo "new"))))
       :type 'tp-producer-buffer-mutation)
      (should (equal (buffer-string) "old"))
      (should (equal (get-text-property 1 'help-echo) "old"))
      (should-not (tp--surface-stale surface))
      (should (= (tp-surface-revision surface) revision)))))

(ert-deftest tp-surface-test-boundary-crossing-uses-pre-edit-ranges ()
  "A deletion crossing the old right boundary marks retained ranges stale."
  (tp-surface-test--with-buffer
    (insert "abcd")
    (let* ((anchor (tp-range-anchor-create buffer 2 4))
           (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 '(help-echo "tp")
               :capability 'properties)))
           (surface (tp-surface-mount
                     buffer producer '(:capability properties))))
      (delete-region 3 5)
      (should (tp--anchor-stale anchor))
      (should-error (tp-surface-update surface producer)
                    :type 'tp-stale-mount))))

(ert-deftest tp-surface-test-content-external-edit-marks-mount-stale ()
  "An external edit inside content-owned text prevents silent overwrite."
  (tp-surface-test--with-buffer
    (let ((surface
           (tp-surface-mount buffer (tp-surface-test--leaf 'root "abc")
                             '(:capability content))))
      (goto-char 2)
      (insert "X")
      (should-error
       (tp-surface-update surface (tp-surface-test--leaf 'root "next"))
       :type 'tp-stale-mount)
      (should (equal (buffer-string) "aXbc")))))

(ert-deftest tp-surface-test-publication-steps-roll-back-exactly ()
  "Failure at each publication step keeps the prior surface revision."
  (dolist (step '(text property marker index client-state))
    (tp-surface-test--with-buffer
      (let* ((surface
              (tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
                                '(:capability content)))
             (revision (tp-surface-revision surface))
             (object (tp-object-resolve surface '(root)))
             (reached nil)
             (producer
              (lambda (context)
                (tp-object-ensure context nil 'root 'text)
                (tp-surface-result-create
                 (tp-surface-test--leaf 'root "new" '(face bold))
                 (list :candidate step))))
             (tp--surface-publication-step-function
              (lambda (current _surface)
                (push current reached)
                (when (eq current step) (error "Injected %s failure" step)))))
        (should-error
         (tp-surface-update surface producer))
        (should (memq step reached))
        (should (equal-including-properties (buffer-string) "old"))
        (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))
         (first-buffer (generate-new-buffer " *tp-surface-first*"))
         (second-buffer (generate-new-buffer " *tp-surface-second*"))
         (producer (tp-surface-test--producer signal))
         first second)
    (unwind-protect
        (progn
          (setq first (tp-surface-mount
                       first-buffer producer '(:capability content))
                second (tp-surface-mount
                        second-buffer producer '(:capability content)))
          (let ((first-revision (tp-surface-revision first))
                (second-revision (tp-surface-revision second))
                (tp--surface-publication-step-function
                 (lambda (step surface)
                   (when (and (eq step 'client-state) (eq surface second))
                     (error "Injected second-surface failure")))))
            (should-error (tp-signal-set signal 2))
            (should (= (tp-signal-peek signal) 1))
            (should (= (tp-surface-revision first) first-revision))
            (should (= (tp-surface-revision second) second-revision))
            (should (equal (tp-surface-client-state first) '(:value 1)))
            (should (equal (tp-surface-client-state second) '(:value 1)))
            (with-current-buffer first-buffer (should (equal (buffer-string) "1")))
            (with-current-buffer second-buffer (should (equal (buffer-string) "1")))))
      (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
      (when (buffer-live-p second-buffer) (kill-buffer second-buffer)))))

(ert-deftest tp-surface-test-two-buffer-identities-are-isolated ()
  "The same keyed producer creates separate object identity per surface."
  (let* ((first-buffer (generate-new-buffer " *tp-surface-first*"))
         (second-buffer (generate-new-buffer " *tp-surface-second*"))
         (producer (lambda (context)
                     (tp-object-ensure context nil 'root 'text)
                     (tp-surface-test--leaf 'root
                                            (buffer-name (current-buffer)))))
         first second)
    (unwind-protect
        (progn
          (setq first (tp-surface-mount
                       first-buffer producer '(:capability content))
                second (tp-surface-mount
                        second-buffer producer '(:capability content)))
          (should-not (eq (tp-object-resolve first '(root))
                          (tp-object-resolve second '(root))))
          (should-error
           (tp-surface-update-scoped
            first (list (tp-object-resolve second '(root))) producer)
           :type 'tp-cross-surface-object))
      (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
      (when (buffer-live-p second-buffer) (kill-buffer second-buffer)))))

(ert-deftest tp-surface-test-unmount-cleans-weak-registry-and-markers ()
  "Unmount releases weak surface registration and marker-backed state."
  (tp-surface-test--with-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 '(help-echo "tp")
               :capability 'properties)))
           (surface (tp-surface-mount
                     buffer producer
                     (list :capability 'properties
                           :observers (list #'ignore))))
           (id (tp--surface-id surface))
           (ledger (tp--surface-ledger surface))
           (mounts (tp--surface-mounts surface)))
      (should (eq (gethash id tp--surfaces) surface))
      (tp-surface-unmount surface)
      (should-not (gethash id tp--surfaces))
      (should-not (tp--surface-observers surface))
      (should-not (tp-range-anchor-live-p anchor))
      (dolist (entry ledger)
        (should-not (marker-position (tp--property-ledger-start entry)))
        (should-not (marker-position (tp--property-ledger-end entry))))
      (dolist (mount mounts)
        (should-not (marker-position (tp--surface-mount-start mount)))
        (should-not (marker-position (tp--surface-mount-end mount)))))))

(ert-deftest tp-surface-test-materialize-matches-first-content-mount ()
  "Pure and live publication produce identical propertized text."
  (tp-surface-test--with-buffer
    (let* ((child (tp-surface-test--leaf
                   'child "text" '(face (:foreground "white"))))
           (plan (tp-surface-plan-create
                  :key 'root :kind 'group :children (list child)
                  :props '(help-echo "root") :capability 'content))
           (materialized (tp-surface-materialize-string plan)))
      (tp-surface-mount buffer plan '(:capability content))
      (should (equal-including-properties materialized (buffer-string))))))

(ert-deftest tp-surface-test-index-diagnostics-use-side-state ()
  "Point queries and reports resolve through the retained side index."
  (tp-surface-test--with-buffer
    (let* ((child (tp-surface-test--leaf 'child "x"))
           (plan (tp-surface-plan-create
                  :key 'root :kind 'group :children (list child)
                  :tags '(:role root) :capability 'content))
           (surface (tp-surface-mount buffer plan '(:capability content)))
           (objects (tp-surface-at-point 1 buffer))
           (inspection (tp-surface-inspect surface)))
      (should (= (length objects) 2))
      (should (eq (plist-get inspection :surface) surface))
      (should (= (plist-get inspection :revision) 1))
      (should (equal (plist-get (tp-surface-report surface) :surface-id)
                     (plist-get inspection :id))))))

(ert-deftest tp-surface-test-kill-buffer-disposes-runtime ()
  "Killing the lifecycle owner releases its surface and objects."
  (let* ((buffer (generate-new-buffer " *tp-surface-kill*"))
         (surface (tp-surface-mount
                   buffer (tp-surface-test--leaf 'root "x")
                   (list :capability 'content
                         :observers (list #'ignore))))
         (object (tp-object-resolve surface '(root))))
    (kill-buffer buffer)
    (should-not (tp-surface-live-p surface))
    (should-not (tp--surface-observers surface))
    (should-not (tp-object-live-p object))))

(ert-deftest tp-surface-test-omitted-binding-defaults-to-deletion ()
  "A surviving object does not retain an omitted binding by accident."
  (tp-surface-test--with-buffer
    (let ((signal (tp-signal-create 1))
          (include t)
          binding)
      (let* ((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 signal))))
                    (tp-binding-read binding)))
                (tp-surface-test--leaf 'root "value")))
             (surface (tp-surface-mount
                       buffer producer '(:capability content))))
        (should (= (tp-signal-subscriber-count signal) 1))
        (setq include nil)
        (tp-surface-update surface producer)
        (should-not (tp-binding-live-p binding))
        (should (= (tp-signal-subscriber-count signal) 0))))))

(ert-deftest tp-surface-test-explicit-retain-keeps-omitted-binding ()
  "An explicit retain lifecycle keeps an omitted computation subscribed."
  (tp-surface-test--with-buffer
    (let ((signal (tp-signal-create 1))
          (include t)
          binding)
      (let* ((producer
              (lambda (context)
                (let ((object (tp-object-ensure context nil 'root 'text)))
                  (when include
                    (setq binding
                          (tp-bind object '(test . retained)
                                   (lambda () (tp-signal-read signal))
                                   :lifecycle 'retain))
                    (tp-binding-read binding)))
                (tp-surface-test--leaf 'root "value")))
             (surface (tp-surface-mount
                       buffer producer '(:capability content))))
        (setq include nil)
        (tp-surface-update surface producer)
        (should (tp-binding-live-p binding))
        (should (= (tp-signal-subscriber-count signal) 1))))))

(ert-deftest tp-surface-test-read-only-and-narrowing-policy-is-explicit ()
  "Content publication requires opt-in for read-only buffers and preserves narrowing."
  (tp-surface-test--with-buffer
    (insert "012345")
    (narrow-to-region 2 5)
    (setq buffer-read-only t)
    (should-error
     (tp-surface-mount buffer (tp-surface-test--leaf 'root "x")
                       '(:capability content :start 2 :end 5))
     :type 'buffer-read-only)
    (let ((surface
           (tp-surface-mount
            buffer (tp-surface-test--leaf 'root "x")
            '(:capability content :start 2 :end 5 :inhibit-read-only t))))
      (should buffer-read-only)
      (should (buffer-narrowed-p))
      (should (equal (buffer-substring-no-properties (point-min) (point-max))
                     "x"))
      (tp-surface-unmount surface))))

(ert-deftest tp-surface-test-no-observer-skips-report-snapshot ()
  "A surface without observers constructs no observation event or timing."
  (tp-surface-test--with-buffer
    (let ((copies 0)
          (clock-calls 0)
          surface
          (original (symbol-function 'tp-surface-report)))
      (cl-letf (((symbol-function 'tp-surface-report)
                 (lambda (&rest arguments)
                   (cl-incf copies)
                   (apply original arguments)))
                ((symbol-function 'tp--surface-observation-clock)
                 (lambda ()
                   (cl-incf clock-calls)
                   1.0)))
        (setq surface
              (tp-surface-mount
               buffer (tp-surface-test--leaf 'root "committed")
               '(:capability content))))
      (should (= copies 0))
      (should (= clock-calls 0))
      (let ((report (tp-surface-report surface)))
        (should-not (plist-get report :provider))
        (should-not (plist-get report :stage))
        (should-not (plist-get report :duration-ms))
        (should-not (plist-get report :timing))))))

(ert-deftest tp-surface-test-observer-registration-is-public-and-idempotent ()
  "Observers can be added and removed without duplicates."
  (tp-surface-test--with-buffer
    (let* ((calls 0)
           (observer (lambda (_surface _report) (cl-incf calls)))
           (surface
            (tp-surface-mount
             buffer (tp-surface-test--leaf 'root "one")
             '(:capability content))))
      (should-error (tp-surface-add-observer surface 'not-a-function)
                    :type 'wrong-type-argument)
      (should-error (tp-surface-remove-observer surface 'not-a-function)
                    :type 'wrong-type-argument)
      (should (eq (tp-surface-add-observer surface observer) surface))
      (should (eq (tp-surface-add-observer surface observer) surface))
      (should (= (length (tp--surface-observers surface)) 1))
      (tp-surface-update surface (tp-surface-test--leaf 'root "two"))
      (should (= calls 1))
      (should (eq (tp-surface-remove-observer surface observer) surface))
      (tp-surface-update surface (tp-surface-test--leaf 'root "three"))
      (should (= calls 1)))))

(ert-deftest tp-surface-test-observer-report-has-publication-metadata ()
  "An enabled observer receives provider, stage, and duration metadata."
  (tp-surface-test--with-buffer
    (let ((clock-values '(10.0 10.025))
          observed-report)
      (cl-letf (((symbol-function 'tp--surface-observation-clock)
                 (lambda () (pop clock-values))))
        (tp-surface-mount
         buffer (tp-surface-test--leaf 'root "committed")
         (list :capability 'content
               :observers
               (list (lambda (_surface report)
                       (setq observed-report report))))))
      (should (eq (plist-get observed-report :provider) 'tp))
      (should (eq (plist-get observed-report :stage) 'publication))
      (should (< (abs (- (plist-get observed-report :duration-ms) 25.0))
                 0.001))
      (should (plist-member observed-report :transaction-id))
      (should (plist-member observed-report :scope-count))
      (should (plist-member observed-report :text-operations)))))

(ert-deftest tp-surface-test-observation-does-not-change-committed-state ()
  "Observed and unobserved surfaces commit equivalent text and state."
  (let ((plain-buffer (generate-new-buffer " *tp-plain*"))
        (observed-buffer (generate-new-buffer " *tp-observed*")))
    (unwind-protect
        (let* ((plan (tp-surface-test--leaf
                      'root "same" '(face bold help-echo "same")))
               (plain (tp-surface-mount
                       plain-buffer plan '(:capability content)))
               (observed (tp-surface-mount
                          observed-buffer plan
                          (list :capability 'content
                                :observers (list #'ignore)))))
          (should (equal-including-properties
                   (with-current-buffer plain-buffer
                     (buffer-substring (point-min) (point-max)))
                   (with-current-buffer observed-buffer
                     (buffer-substring (point-min) (point-max)))))
          (should (= (tp-surface-revision plain)
                     (tp-surface-revision observed)))
          (should (equal (tp-surface-client-state plain)
                         (tp-surface-client-state observed)))
          (let ((next (tp-surface-test--leaf
                       'root "updated"
                       '(face italic help-echo "updated"))))
            (tp-surface-update plain next)
            (tp-surface-update observed next))
          (should (equal-including-properties
                   (with-current-buffer plain-buffer
                     (buffer-substring (point-min) (point-max)))
                   (with-current-buffer observed-buffer
                     (buffer-substring (point-min) (point-max)))))
          (should (= (tp-surface-revision plain)
                     (tp-surface-revision observed)))
          (should (equal (tp-surface-client-state plain)
                         (tp-surface-client-state observed))))
      (when (buffer-live-p plain-buffer) (kill-buffer plain-buffer))
      (when (buffer-live-p observed-buffer) (kill-buffer observed-buffer)))))

(ert-deftest tp-surface-test-observer-failure-does-not-roll-back ()
  "Observer errors are recorded after a successful publication."
  (tp-surface-test--with-buffer
    (let ((surface
           (tp-surface-mount
            buffer (tp-surface-test--leaf 'root "committed")
            (list :capability 'content
                  :observers (list (lambda (_surface _report)
                                     (error "Observer failure")))))))
      (should (equal (buffer-string) "committed"))
      (should (= (tp-surface-revision surface) 1))
      (should (= (length (plist-get (tp-surface-report surface)
                                    :observer-errors))
                 1)))))

(ert-deftest tp-surface-test-observer-runs-only-after-accepted-publication ()
  "A rolled-back publication emits no observation; a retry emits one."
  (tp-surface-test--with-buffer
    (let* ((calls 0)
           (observer (lambda (_surface _report) (cl-incf calls)))
           (surface
            (tp-surface-mount
             buffer
             (tp-surface-test--leaf
              'root "old" '(face bold help-echo "old"))
             (list :capability 'content :observers (list observer))))
           (revision (tp-surface-revision surface))
           (old (buffer-substring (point-min) (point-max)))
           (next (tp-surface-test--leaf
                  'root "new" '(face italic help-echo "new"))))
      (setq calls 0)
      (cl-letf (((symbol-function 'accept-change-group)
                 (lambda (_group) (error "Injected final-accept failure"))))
        (should-error (tp-surface-update surface next)))
      (should (= calls 0))
      (should (= (tp-surface-revision surface) revision))
      (should (equal-including-properties
               old (buffer-substring (point-min) (point-max))))
      (tp-surface-update surface next)
      (should (= calls 1))
      (should (= (tp-surface-revision surface) (1+ revision)))
      (should (equal-including-properties
               (buffer-substring (point-min) (point-max))
               (propertize "new" 'face 'italic 'help-echo "new"))))))

(ert-deftest tp-surface-test-observer-write-starts-a-new-transaction ()
  "An observer signal write runs after the publishing transaction exits."
  (tp-surface-test--with-buffer
    (let* ((signal (tp-signal-create 1))
           (write-once t)
           (producer (tp-surface-test--producer signal))
           (surface
            (tp-surface-mount
             buffer producer
             (list :capability 'content
                   :observers
                   (list (lambda (_surface _report)
                           (when write-once
                             (setq write-once nil)
                             (tp-signal-set signal 2))))))))
      (should (= (tp-signal-peek signal) 2))
      (should (equal (buffer-string) "2"))
      (should (= (tp-surface-revision surface) 2)))))

(ert-deftest tp-surface-test-transaction-participant-sees-published-state ()
  "A participant promotes side state before observers run."
  (tp-surface-test--with-buffer
    (let (surface events)
      (setq surface
            (tp-surface-mount
             buffer (tp-surface-test--leaf 'root "old")
             (list :capability 'content
                   :observers
                   (list (lambda (_surface _report)
                           (push (list 'observer (buffer-string)) events))))))
      (setq events nil)
      (tp-with-transaction
        (tp-transaction-participate-v2
         :key '(test . promotion)
         :stage (lambda ()
           (push (list 'participant
                       (buffer-string)
                       (tp-surface-client-state surface))
                 events))
         :rollback (lambda () (push '(rollback) events)))
        (tp-surface-update
         surface
         (lambda (context)
           (tp-object-ensure context nil 'root 'text)
           (tp-surface-result-create
            (tp-surface-test--leaf 'root "new") '(:generation 2)))))
      (should (equal (nreverse events)
                     '((participant "new" (:generation 2))
                       (observer "new")))))))

(ert-deftest tp-surface-test-failing-participant-rolls-back-every-owner ()
  "A participant failure restores surface, source, and external state."
  (tp-surface-test--with-buffer
    (let* ((signal (tp-signal-create 1))
           (producer (tp-surface-test--producer signal))
           (surface (tp-surface-mount
                     buffer producer '(:capability content)))
           (revision (tp-surface-revision surface))
           (external 'old)
           rollback-ran)
      (should-error
       (tp-with-transaction
         (tp-transaction-participate-v2
          :key '(test . failure)
          :stage (lambda ()
            (setq external 'candidate)
            (error "Participant failure"))
          :rollback (lambda ()
            (setq external 'old
                  rollback-ran t)))
         (tp-signal-set signal 2)))
      (should rollback-ran)
      (should (eq external 'old))
      (should (= (tp-signal-peek signal) 1))
      (should (= (tp-surface-revision surface) revision))
      (should (equal (buffer-string) "1")))))

(ert-deftest tp-surface-test-transaction-participant-key-is-unique ()
  "Participant keys are unique within the outer transaction."
  (should-error
   (tp-with-transaction
     (tp-transaction-participate-v2
      :key 'same :stage #'ignore :rollback #'ignore)
     (tp-transaction-participate-v2
      :key 'same :stage #'ignore :rollback #'ignore))
   :type 'tp-reactive-error))

(ert-deftest tp-surface-test-equal-reactive-plan-skips-surface-publication ()
  "An equal producer result leaves the surface revision unchanged."
  (tp-surface-test--with-buffer
    (let* ((signal (tp-signal-create 10))
           (producer
            (lambda (context)
              (tp-object-ensure context nil 'root 'text)
              (tp-surface-test--leaf
               'root (number-to-string (/ (tp-signal-read signal) 10)))))
           (surface (tp-surface-mount
                     buffer producer '(:capability content)))
           (revision (tp-surface-revision surface)))
      (tp-signal-set signal 11)
      (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
    (let* ((first
            (tp-surface-plan-create
             :key 'root :kind 'group
             :children (list (tp-surface-test--leaf 'a "A")
                             (tp-surface-test--leaf 'b "B"))
             :capability 'content))
           (surface (tp-surface-mount buffer first '(:capability content)))
           (a (tp-object-resolve surface '(root a)))
           (b (tp-object-resolve surface '(root b)))
           (second
            (tp-surface-plan-create
             :key 'root :kind 'group
             :children (list (tp-surface-test--leaf 'b "B")
                             (tp-surface-test--leaf 'a "A"))
             :capability 'content)))
      (tp-surface-update surface second)
      (should (equal (buffer-string) "BA"))
      (should (eq a (tp-object-resolve surface '(root a))))
      (should (eq b (tp-object-resolve surface '(root b))))
      (should (= (plist-get (tp-surface-report surface) :moved-objects) 2)))))

(ert-deftest tp-surface-test-overlapping-range-contributions-are-ordered ()
  "Overlapping property mounts combine deterministically by plan order."
  (tp-surface-test--with-buffer
    (insert "abcd")
    (let* ((left (tp-range-anchor-create buffer 1 4))
           (right (tp-range-anchor-create buffer 2 5))
           (producer
            (lambda (context)
              (let* ((root (tp-object-ensure context nil 'root 'group))
                     (a (tp-object-ensure context root 'a 'range))
                     (b (tp-object-ensure context root 'b 'range)))
                (tp-object-attach-range context a left)
                (tp-object-attach-range context b right))
              (tp-surface-plan-create
               :key 'root :kind 'group :capability 'properties
               :children
               (list (tp-surface-plan-create
                      :key 'a :kind 'range :props '(help-echo "A")
                      :capability 'properties)
                     (tp-surface-plan-create
                      :key 'b :kind 'range :props '(help-echo "B")
                      :capability 'properties)))))
           (surface (tp-surface-mount
                     buffer producer '(:capability properties))))
      (should (equal (get-text-property 1 'help-echo) "A"))
      (should (equal (get-text-property 2 'help-echo) "B"))
      (should (equal (get-text-property 4 'help-echo) "B"))
      (tp-surface-unmount surface)
      (should-not (get-text-property 2 'help-echo)))))

(ert-deftest tp-surface-test-explicit-nil-is-a-property-contribution ()
  "A present nil contribution hides and later restores its host baseline."
  (tp-surface-test--with-buffer
    (insert "host")
    (put-text-property 1 5 'help-echo "baseline")
    (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 '(help-echo nil)
               :capability 'properties)))
           (surface (tp-surface-mount
                     buffer producer '(:capability properties))))
      (should (equal (tp--property-state-at buffer 2 'help-echo)
                     '(t)))
      (tp-surface-unmount surface)
      (should (equal (get-text-property 2 'help-echo) "baseline")))))

(ert-deftest tp-surface-test-unmount-preserves-only-conflicting-subranges ()
  "Unmount restores owned runs without clobbering a partial host override."
  (tp-surface-test--with-buffer
    (insert "abcd")
    (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 '(help-echo "tp")
               :capability 'properties)))
           (surface (tp-surface-mount
                     buffer producer '(:capability properties))))
      (put-text-property 2 3 'help-echo "external")
      (tp-surface-unmount surface)
      (should-not (get-text-property 1 'help-echo))
      (should (equal (get-text-property 2 'help-echo) "external"))
      (should-not (get-text-property 3 'help-echo)))))

(ert-deftest tp-surface-test-cross-surface-overlap-is-rejected ()
  "Independent surfaces cannot silently claim the same character range."
  (tp-surface-test--with-buffer
    (let ((first (tp-surface-mount
                  buffer (tp-surface-test--leaf 'first "owned")
                  '(:capability content))))
      (should-error
       (tp-surface-mount
        buffer (tp-surface-test--leaf 'second "overlap")
        '(:capability content))
       :type 'tp-capability-error)
      (should (tp-surface-live-p first))
      (should (equal (buffer-string) "owned")))))

(ert-deftest tp-surface-test-kill-during-publication-is-authoritative ()
  "A killed target stays dead while other surfaces and sources roll back."
  (let* ((signal (tp-signal-create 1))
         (first-buffer (generate-new-buffer " *tp-surface-survivor*"))
         (victim-buffer (generate-new-buffer " *tp-surface-victim*"))
         (producer (tp-surface-test--producer signal))
         first victim victim-object)
    (unwind-protect
        (progn
          (setq first (tp-surface-mount
                       first-buffer producer '(:capability content))
                victim (tp-surface-mount
                        victim-buffer producer '(:capability content))
                victim-object (tp-object-resolve victim '(root)))
          (let ((revision (tp-surface-revision first))
                (tp--surface-publication-step-function
                 (lambda (step surface)
                   (when (and (eq step 'text) (eq surface victim))
                     (kill-buffer victim-buffer)))))
            (should-error (tp-signal-set signal 2))
            (should (= (tp-signal-peek signal) 1))
            (should (tp-surface-live-p first))
            (should (= (tp-surface-revision first) revision))
            (with-current-buffer first-buffer
              (should (equal (buffer-string) "1")))
            (should-not (buffer-live-p victim-buffer))
            (should-not (tp-surface-live-p victim))
            (should-not (tp-object-live-p victim-object))))
      (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
      (when (buffer-live-p victim-buffer) (kill-buffer victim-buffer)))))

(provide 'tp-surface-tests)
;;; tp-surface-tests.el ends here