2069 lines
97 KiB
EmacsLisp
2069 lines
97 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)))))
|
|
|
|
(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-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-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-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-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-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-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-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
|