;;; 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--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-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-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))
             (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))))))

(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 '(:capability properties)))
           (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-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")
                   '(:capability content)))
         (object (tp-object-resolve surface '(root))))
    (kill-buffer buffer)
    (should-not (tp-surface-live-p 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 does not copy an unused asynchronous report."
  (tp-surface-test--with-buffer
    (let ((copies 0)
          (original (symbol-function 'tp-surface-report)))
      (cl-letf (((symbol-function 'tp-surface-report)
                 (lambda (&rest arguments)
                   (cl-incf copies)
                   (apply original arguments))))
        (tp-surface-mount
         buffer (tp-surface-test--leaf 'root "committed")
         '(:capability content)))
      (should (= copies 0)))))

(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-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
         '(test . promotion)
         (lambda ()
           (push (list 'participant
                       (buffer-string)
                       (tp-surface-client-state surface))
                 events))
         (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
          '(test . failure)
          (lambda ()
            (setq external 'candidate)
            (error "Participant failure"))
          (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 'same #'ignore #'ignore)
     (tp-transaction-participate 'same #'ignore #'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