07b84b0685
Allow callers to authorize one atomic surface update through generic retained object handles while TP remains the sole owner of mount resolution, buffer publication, and rollback. Verified: byte compilation with warnings as errors; 726 ERT tests; 92 doctests; targeted scoped-update tests; checkdoc; git diff --check.
984 lines
46 KiB
EmacsLisp
984 lines
46 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-scoped-content-update-publishes-one-object ()
|
|
"A scoped update should replace only its retained object's mounted text."
|
|
(tp-surface-test--with-buffer
|
|
(let ((middle "B") middle-object)
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let ((root (tp-object-ensure context nil 'root 'group)))
|
|
(tp-object-ensure context root 'left 'text)
|
|
(setq middle-object
|
|
(tp-object-ensure context root 'middle 'text))
|
|
(tp-object-ensure context root 'right 'text))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list (tp-surface-test--leaf 'left "A")
|
|
(tp-surface-test--leaf 'middle middle)
|
|
(tp-surface-test--leaf 'right "C")))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content)))
|
|
(revision (tp-surface-revision surface)))
|
|
(setq middle "LONG")
|
|
(let ((report
|
|
(tp-surface-update-scoped
|
|
surface (list middle-object) producer)))
|
|
(should (equal (buffer-string) "ALONGC"))
|
|
(should (= (tp-surface-revision surface) (1+ revision)))
|
|
(should-not (plist-get report :full-root))
|
|
(should (= (plist-get report :scope-count) 1))
|
|
(should (= (plist-get report :scope-range-count) 1))
|
|
(should (= (plist-get report :touched-characters) 4)))))))
|
|
|
|
(ert-deftest tp-surface-test-scoped-update-supports-disjoint-object-mounts ()
|
|
"One logical scope should update all of its disjoint mounts atomically."
|
|
(tp-surface-test--with-buffer
|
|
(let ((left "A") (right "C") logical)
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let* ((root (tp-object-ensure context nil 'root 'group))
|
|
(left-object
|
|
(tp-object-ensure context root 'left 'text))
|
|
(gap-object
|
|
(tp-object-ensure context root 'gap 'text))
|
|
(right-object
|
|
(tp-object-ensure context root 'right 'text)))
|
|
(setq logical
|
|
(tp-object-ensure context root 'logical 'item))
|
|
(tp-object-retain context logical)
|
|
(tp-object-attach-fragment context logical left-object 'left)
|
|
(tp-object-attach-fragment context logical right-object 'right)
|
|
(ignore gap-object))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list (tp-surface-test--leaf 'left left)
|
|
(tp-surface-test--leaf 'gap "|")
|
|
(tp-surface-test--leaf 'right right)))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content)))
|
|
(revision (tp-surface-revision surface)))
|
|
(setq left "LEFT" right "RIGHT")
|
|
(let ((report
|
|
(tp-surface-update-scoped surface (list logical) producer)))
|
|
(should (equal (buffer-string) "LEFT|RIGHT"))
|
|
(should (= (tp-surface-revision surface) (1+ revision)))
|
|
(should (= (plist-get report :scope-count) 1))
|
|
(should (= (plist-get report :scope-range-count) 2))
|
|
(should (= (plist-get report :text-operations) 2)))))))
|
|
|
|
(ert-deftest tp-surface-test-scoped-update-adds-and-removes-owned-output ()
|
|
"A retained scope should add or remove its owned output between stable text."
|
|
(tp-surface-test--with-buffer
|
|
(let ((visible nil) logical)
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let* ((root (tp-object-ensure context nil 'root 'group))
|
|
(left (tp-object-ensure context root 'left 'text))
|
|
(middle (and visible
|
|
(tp-object-ensure
|
|
context root 'middle 'text))))
|
|
(tp-object-ensure context root 'gap 'text)
|
|
(tp-object-ensure context root 'right 'text)
|
|
(setq logical
|
|
(tp-object-ensure context root 'logical 'item))
|
|
(tp-object-retain context logical)
|
|
(when middle
|
|
(tp-object-attach-fragment context logical middle 'owned))
|
|
(ignore left))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(delq nil
|
|
(list (tp-surface-test--leaf 'left "A")
|
|
(and visible
|
|
(tp-surface-test--leaf 'middle "B"))
|
|
(tp-surface-test--leaf 'gap "|")
|
|
(tp-surface-test--leaf 'right "C"))))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content))))
|
|
(should (equal (buffer-string) "A|C"))
|
|
(setq visible t)
|
|
(let ((report
|
|
(tp-surface-update-scoped surface (list logical) producer)))
|
|
(should (equal (buffer-string) "AB|C"))
|
|
(should (= (plist-get report :text-operations) 1)))
|
|
(setq visible nil)
|
|
(let ((report
|
|
(tp-surface-update-scoped surface (list logical) producer)))
|
|
(should (equal (buffer-string) "A|C"))
|
|
(should (= (plist-get report :text-operations) 1)))))))
|
|
|
|
(ert-deftest tp-surface-test-scoped-update-survives-outer-transaction ()
|
|
"A scoped request should remain attached until its outer transaction flushes."
|
|
(tp-surface-test--with-buffer
|
|
(let ((middle "B") middle-object)
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let ((root (tp-object-ensure context nil 'root 'group)))
|
|
(tp-object-ensure context root 'left 'text)
|
|
(setq middle-object
|
|
(tp-object-ensure context root 'middle 'text))
|
|
(tp-object-ensure context root 'right 'text))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list (tp-surface-test--leaf 'left "A")
|
|
(tp-surface-test--leaf 'middle middle)
|
|
(tp-surface-test--leaf 'right "C")))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content))))
|
|
(setq middle "LONG")
|
|
(tp-with-transaction
|
|
(tp-surface-update-scoped surface (list middle-object) producer))
|
|
(should (equal (buffer-string) "ALONGC"))
|
|
(should-not (plist-get (tp-surface-report surface) :full-root))
|
|
(setq middle "NEXT")
|
|
(tp-surface-update surface producer)
|
|
(should (equal (buffer-string) "ANEXTC"))
|
|
(should (plist-get (tp-surface-report surface) :full-root))))))
|
|
|
|
(ert-deftest tp-surface-test-scoped-properties-update-publishes-one-object ()
|
|
"A properties scope should leave another retained range untouched."
|
|
(tp-surface-test--with-buffer
|
|
(insert "left|right")
|
|
(let* ((left-anchor (tp-range-anchor-create buffer 1 5))
|
|
(right-anchor (tp-range-anchor-create buffer 6 11))
|
|
(left-face 'bold)
|
|
left-object
|
|
(producer
|
|
(lambda (context)
|
|
(let ((root (tp-object-ensure context nil 'root 'group)))
|
|
(setq left-object
|
|
(tp-object-ensure context root 'left 'range))
|
|
(tp-object-attach-range context left-object left-anchor)
|
|
(let ((right-object
|
|
(tp-object-ensure context root 'right 'range)))
|
|
(tp-object-attach-range context right-object right-anchor)))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'properties
|
|
:children
|
|
(list
|
|
(tp-surface-plan-create
|
|
:key 'left :kind 'range :props (list 'face left-face)
|
|
:capability 'properties)
|
|
(tp-surface-plan-create
|
|
:key 'right :kind 'range :props '(face italic)
|
|
:capability 'properties)))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability properties))))
|
|
(setq left-face 'underline)
|
|
(let ((report
|
|
(tp-surface-update-scoped surface (list left-object) producer)))
|
|
(should (eq (get-text-property 2 'face) 'underline))
|
|
(should (eq (get-text-property 7 'face) 'italic))
|
|
(should-not (plist-get report :full-root))
|
|
(should (= (plist-get report :scope-range-count) 1))
|
|
(should (= (plist-get report :property-operations) 1))))))
|
|
|
|
(ert-deftest tp-surface-test-scoped-update-can-explicitly-fall-back-to-root ()
|
|
"A scoped mismatch should publish the root only when explicitly requested."
|
|
(tp-surface-test--with-buffer
|
|
(let ((middle "B") (right "C") middle-object)
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let ((root (tp-object-ensure context nil 'root 'group)))
|
|
(tp-object-ensure context root 'left 'text)
|
|
(setq middle-object
|
|
(tp-object-ensure context root 'middle 'text))
|
|
(tp-object-ensure context root 'right 'text))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list (tp-surface-test--leaf 'left "A")
|
|
(tp-surface-test--leaf 'middle middle)
|
|
(tp-surface-test--leaf 'right right)))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content))))
|
|
(setq middle "M" right "OUTSIDE")
|
|
(let ((report
|
|
(tp-surface-update-scoped
|
|
surface (list middle-object) producer
|
|
'(:on-mismatch root))))
|
|
(should (equal (buffer-string) "AMOUTSIDE"))
|
|
(should (plist-get report :full-root))
|
|
(should (plist-get report :scope-fallback)))))))
|
|
|
|
(ert-deftest tp-surface-test-scoped-update-rejects-outside-change ()
|
|
"A scoped update should fail before publication when another range changes."
|
|
(tp-surface-test--with-buffer
|
|
(let ((middle "B") (right "C") middle-object)
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let ((root (tp-object-ensure context nil 'root 'group)))
|
|
(tp-object-ensure context root 'left 'text)
|
|
(setq middle-object
|
|
(tp-object-ensure context root 'middle 'text))
|
|
(tp-object-ensure context root 'right 'text))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list (tp-surface-test--leaf 'left "A")
|
|
(tp-surface-test--leaf 'middle middle)
|
|
(tp-surface-test--leaf 'right right)))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content)))
|
|
(revision (tp-surface-revision surface)))
|
|
(setq middle "M" right "OUTSIDE")
|
|
(should-error
|
|
(tp-surface-update-scoped surface (list middle-object) producer)
|
|
:type 'tp-scope-mismatch)
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(should (equal (buffer-string) "ABC"))))))
|
|
|
|
(ert-deftest tp-surface-test-scoped-update-rolls-back-buffer-and-mounts ()
|
|
"A failed scoped publication should restore text, revision, and mounts."
|
|
(tp-surface-test--with-buffer
|
|
(let ((middle "B") middle-object)
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let ((root (tp-object-ensure context nil 'root 'group)))
|
|
(tp-object-ensure context root 'left 'text)
|
|
(setq middle-object
|
|
(tp-object-ensure context root 'middle 'text))
|
|
(tp-object-ensure context root 'right 'text))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list (tp-surface-test--leaf 'left "A")
|
|
(tp-surface-test--leaf 'middle middle)
|
|
(tp-surface-test--leaf 'right "C")))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content)))
|
|
(revision (tp-surface-revision surface))
|
|
(mounts (tp-object-mounts middle-object)))
|
|
(setq middle "LONG")
|
|
(let ((tp--surface-publication-step-function
|
|
(lambda (step _surface)
|
|
(when (eq step 'client-state)
|
|
(error "Injected scoped failure")))))
|
|
(should-error
|
|
(tp-surface-update-scoped surface (list middle-object) producer)))
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(should (equal (buffer-string) "ABC"))
|
|
(should (eq middle-object (tp-object-resolve surface '(root middle))))
|
|
(should (equal (tp-object-mounts middle-object) mounts))))))
|
|
|
|
(ert-deftest tp-surface-test-failed-candidate-does-not-leak-object ()
|
|
"A failed update preserves the live tree and invalidates new handles."
|
|
(tp-surface-test--with-buffer
|
|
(let* ((surface
|
|
(tp-surface-mount buffer (tp-surface-test--leaf 'root "old")
|
|
'(:capability content)))
|
|
(root (tp-object-resolve surface '(root)))
|
|
candidate)
|
|
(should-error
|
|
(tp-surface-update
|
|
surface
|
|
(lambda (context)
|
|
(tp-object-ensure context nil 'root 'text)
|
|
(setq candidate (tp-object-ensure context root 'orphan 'text))
|
|
(tp-surface-test--leaf 'root "new")))
|
|
:type 'tp-orphan-object)
|
|
(should (equal (buffer-string) "old"))
|
|
(should (eq root (tp-object-resolve surface '(root))))
|
|
(should-not (tp-object-live-p candidate)))))
|
|
|
|
(ert-deftest tp-surface-test-logical-object-can-own-disjoint-fragments ()
|
|
"One retained object can resolve several output fragments without scans."
|
|
(tp-surface-test--with-buffer
|
|
(let ((first "A") (second "BC"))
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let* ((root (tp-object-ensure context nil 'root 'group))
|
|
(logical
|
|
(tp-object-ensure context root 'logical 'item))
|
|
(left
|
|
(tp-object-ensure context root 'left 'fragment))
|
|
(right
|
|
(tp-object-ensure context root 'right 'fragment)))
|
|
(tp-object-retain context logical)
|
|
(tp-object-attach-fragment
|
|
context logical left '(:slot left))
|
|
(tp-object-attach-fragment
|
|
context logical right '(:slot right)))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list (tp-surface-test--leaf 'left first)
|
|
(tp-surface-test--leaf 'right second)))))
|
|
(surface (tp-surface-mount
|
|
buffer producer '(:capability content)))
|
|
(logical (tp-object-resolve surface '(root logical))))
|
|
(should (tp-object-live-p logical))
|
|
(should (equal (tp-object-mounts logical)
|
|
'((:start 1 :end 2 :tags (:slot left))
|
|
(:start 2 :end 4 :tags (:slot right)))))
|
|
(should (memq logical (tp-surface-at-point 1 buffer)))
|
|
(should (memq logical (tp-surface-at-point 3 buffer)))
|
|
(setq first "AA" second "BBB")
|
|
(cl-letf (((symbol-function 'buffer-list)
|
|
(lambda (&rest _) (error "Unexpected buffer scan")))
|
|
((symbol-function 'text-property-search-forward)
|
|
(lambda (&rest _) (error "Unexpected property scan"))))
|
|
(tp-surface-update surface producer))
|
|
(should (eq logical (tp-object-resolve surface '(root logical))))
|
|
(should (equal (tp-object-mounts logical)
|
|
'((:start 1 :end 3 :tags (:slot left))
|
|
(:start 3 :end 6 :tags (:slot right)))))))))
|
|
|
|
(ert-deftest tp-surface-test-explicitly-retained-object-may-be-unmounted ()
|
|
"An explicitly retained logical object may have no rendered characters."
|
|
(tp-surface-test--with-buffer
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let* ((root (tp-object-ensure context nil 'root 'group))
|
|
(hidden (tp-object-ensure context root 'hidden 'item)))
|
|
(tp-object-retain context hidden)
|
|
(tp-object-ensure context root 'visible 'text))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children (list (tp-surface-test--leaf 'visible "x")))))
|
|
(surface (tp-surface-mount
|
|
buffer producer '(:capability content)))
|
|
(hidden (tp-object-resolve surface '(root hidden))))
|
|
(should (tp-object-live-p hidden))
|
|
(should-not (tp-object-mounts hidden)))))
|
|
|
|
(ert-deftest tp-surface-test-disjoint-mount-index-rolls-back-atomically ()
|
|
"Failed publication restores every mount of a retained logical object."
|
|
(tp-surface-test--with-buffer
|
|
(let ((value "A"))
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let* ((root (tp-object-ensure context nil 'root 'group))
|
|
(logical
|
|
(tp-object-ensure context root 'logical 'item))
|
|
(left
|
|
(tp-object-ensure context root 'left 'fragment))
|
|
(right
|
|
(tp-object-ensure context root 'right 'fragment)))
|
|
(tp-object-retain context logical)
|
|
(tp-object-attach-fragment context logical left 'left)
|
|
(tp-object-attach-fragment context logical right 'right))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list (tp-surface-test--leaf 'left value)
|
|
(tp-surface-test--leaf 'right value)))))
|
|
(surface (tp-surface-mount
|
|
buffer producer '(:capability content)))
|
|
(logical (tp-object-resolve surface '(root logical)))
|
|
(mounts (tp-object-mounts logical))
|
|
(revision (tp-surface-revision surface)))
|
|
(setq value "LONG")
|
|
(let ((tp--surface-publication-step-function
|
|
(lambda (step _surface)
|
|
(when (eq step 'client-state)
|
|
(error "Injected mount-index failure")))))
|
|
(should-error (tp-surface-update surface producer)))
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(should (equal (buffer-string) "AA"))
|
|
(should (eq logical (tp-object-resolve surface '(root logical))))
|
|
(should (equal (tp-object-mounts logical) mounts))))))
|
|
|
|
(ert-deftest tp-surface-test-properties-capability-rejects-text ()
|
|
"A properties-only mount cannot replace host text."
|
|
(tp-surface-test--with-buffer
|
|
(insert "host")
|
|
(should-error
|
|
(tp-surface-mount buffer (tp-surface-test--leaf 'root "replacement")
|
|
'(:capability properties))
|
|
:type 'tp-capability-error)
|
|
(should (equal (buffer-string) "host"))))
|
|
|
|
(ert-deftest tp-surface-test-range-anchor-follows-edits-before-it ()
|
|
"A host insertion before an anchor moves its property contribution."
|
|
(tp-surface-test--with-buffer
|
|
(insert "012345")
|
|
(let* ((anchor (tp-range-anchor-create buffer 3 5))
|
|
(value "A")
|
|
(producer
|
|
(lambda (context)
|
|
(let ((object (tp-object-ensure context nil 'root 'range)))
|
|
(tp-object-attach-range context object anchor))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'range :props (list 'help-echo value)
|
|
:capability 'properties)))
|
|
(surface (tp-surface-mount
|
|
buffer producer '(:capability properties))))
|
|
(should (equal (get-text-property 3 'help-echo) "A"))
|
|
(goto-char 1)
|
|
(insert "X")
|
|
(setq value "B")
|
|
(tp-surface-update surface producer)
|
|
(should (equal (get-text-property 4 'help-echo) "B"))
|
|
(should-not (get-text-property 3 'help-echo)))))
|
|
|
|
(ert-deftest tp-surface-test-property-conflict-needs-explicit-rebase ()
|
|
"TP preserves an external property write until the anchor is rebased."
|
|
(tp-surface-test--with-buffer
|
|
(insert "host")
|
|
(let* ((anchor (tp-range-anchor-create buffer 1 5))
|
|
(value "A")
|
|
(producer
|
|
(lambda (context)
|
|
(let ((object (tp-object-ensure context nil 'root 'range)))
|
|
(tp-object-attach-range context object anchor))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'range :props (list 'help-echo value)
|
|
:capability 'properties)))
|
|
(surface (tp-surface-mount
|
|
buffer producer '(:capability properties)))
|
|
(revision (tp-surface-revision surface)))
|
|
(put-text-property 1 5 'help-echo "external")
|
|
(setq value "B")
|
|
(should-error (tp-surface-update surface producer)
|
|
:type 'tp-property-conflict)
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(should (equal (get-text-property 2 'help-echo) "external"))
|
|
(tp-range-rebase anchor)
|
|
(tp-surface-update surface producer)
|
|
(should (equal (get-text-property 2 'help-echo) "B"))
|
|
(tp-surface-unmount surface)
|
|
(should (equal (get-text-property 2 'help-echo) "external")))))
|
|
|
|
(ert-deftest tp-surface-test-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-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
|