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

(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-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-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-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-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-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-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-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-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)))
             (tp--surface-publication-step-function
              (lambda (current _surface)
                (when (eq current step) (error "Injected %s failure" step)))))
        (should-error
         (tp-surface-update
          surface
          (tp-surface-result-create
           (tp-surface-test--leaf 'root "new" '(face bold))
           (list :candidate step))))
        (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-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-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-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