84ebf0a548
Introduce pure retained plans, stable objects, marker-backed range ownership, side indexes, content/property diffs, and multi-buffer rollback as the generic publication runtime. Verification: 707 ERT tests; 92 doctests; shuffled seed 20260806; compile-all WERROR=t.
555 lines
25 KiB
EmacsLisp
555 lines
25 KiB
EmacsLisp
;;; 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-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-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-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-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-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-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-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
|