geekinney/ebox
1
0
Fork 0
Code Issues Pull Requests Actions 21 Packages Projects Releases Wiki Activity
main
ebox/tests/ebox-child-range-tests.el
Kinneyzhang 79f5bc23d1 feat: add CSS sizing and native text interaction capabilities 
Normalize size units and intrinsic sizing across Elisp and native layout. Add help, pointer, hover-style and keymap support with reusable interaction adapters.

Keep content updates local, preserve scroll caches and hover borders, and avoid rebuilding retained plans and ownership metadata for stable geometry.

Validation: make check and native-rust-tests passed; targeted native interaction and scroll publication regressions passed.
2026-09-09 22:25:18 +08:00

2507 lines
128 KiB
EmacsLisp
Raw Permalink Blame History

;;; ebox-child-range-tests.el --- Persistent child sequence tests -*- lexical-binding: t; -*-
(require 'ert)
(require 'ebox-child-range)
(require 'ebox)
;; This suite locks child-range and Elisp projection semantics. Native frame
;; execution is verified separately and must not replace the named fallback
;; strategies merely because a developer has built the optional module.
(defvar ebox-native-reflow-module-path)
(setq ebox-native-reflow-module-path nil)
(defconst ebox-child-range-test--root
(expand-file-name ".." (file-name-directory (or load-file-name buffer-file-name)))
"Ebox repository root for source audits.")
(defun ebox-child-range-test--item (key)
"Return one declarative test item for KEY."
(list :key key :value key))
(defun ebox-child-range-test--node-key (item &optional source-index)
"Return ITEM's key from SOURCE-INDEX or its low-level fixture field."
(or (and (ebox-canonical-input-p item)
(ebox-tree-node-author-key
(ebox-test-source-index item) (ebox-test-root item)))
(and source-index
(ebox-tree-node-source-handle item)
(ebox-tree-node-author-key source-index item))
(plist-get item :key)))
(defalias 'ebox-child-range-test--key
#'ebox-child-range-test--node-key)
(defun ebox-child-range-test--input (items)
"Combine canonical fixture ITEMS into one Range replacement input."
(apply #'ebox-test-forest-input items))
(defun ebox-child-range-test--host-ref-table (state)
"Return STATE's source-owned Host reference index."
(ebox-source--index-host-ref-table-view (plist-get state :source-index)))
(defun ebox-child-range-test--build (segments &optional hash-function)
"Build low-level SEGMENTS with the fixture key contract."
(ebox-child-range--build
segments #'ebox-child-range-test--key hash-function))
(defun ebox-child-range-test--replace (sequence ref items)
"Replace REF ITEMS using the fixture key contract."
(ebox-child-range--replace
sequence ref items #'ebox-child-range-test--key))
(defun ebox-child-range-test--fixture (static-count range-items &optional hash)
"Build STATIC-COUNT static segments followed by RANGE-ITEMS."
(ebox-child-range-test--build
(append
(cl-loop for index below static-count
collect (cons nil (list (ebox-child-range-test--item
(list 'static index)))))
(list (cons 'range
(mapcar #'ebox-child-range-test--item range-items))))
hash))
(ert-deftest ebox-child-range-reuse-map-rebinds-published-objects ()
"Stable slots use published objects; moved slots re-enter normal indexing."
(let* ((sequence (ebox-child-range-test--fixture 0 '(one two)))
(segment (ebox-child-range--lookup-ref sequence 'range))
(payload (ebox-child-range--segment-payload segment))
(first (aref payload 0))
(second (aref payload 1)))
(plist-put first :node-id 1)
(plist-put second :node-id 2)
(plist-put first :ebox-sequence-location
'(:parent-node-id 99 :segment-index 0 :offset 0))
(plist-put second :ebox-sequence-location
'(:parent-node-id 99 :segment-index 0 :offset 1))
(pcase-let
((`(,items ,reuse-map)
(ebox-incremental--candidate-canonical-range-reuse
sequence 'range (list (copy-tree first) (copy-tree second))
'((0 . 0) (1 . 1)) 99 0)))
(should (eq (nth 0 items) first))
(should (eq (nth 1 items) second))
(should (equal reuse-map '((0 . 0) (1 . 1)))))
(pcase-let
((`(,items ,reuse-map)
(ebox-incremental--candidate-canonical-range-reuse
sequence 'range (list second first)
'((0 . 1) (1 . 0)) 99 0)))
(should-not (eq (nth 0 items) second))
(should-not (eq (nth 1 items) first))
(should-not (plist-get (nth 0 items) :node-id))
(should-not (plist-get (nth 1 items) :node-id))
(should-not reuse-map))
(should-error
(ebox-incremental--candidate-canonical-range-reuse
sequence 'range (list (copy-tree first)) '((1 . 0)) 99 0))))
(ert-deftest ebox-child-range-render-signature-snapshots-item-identities ()
"A cached Range signature must not follow later runtime identity mutation."
(let* ((item-input (ebox-test-box (ebox-test-text "item") :key 'item))
(item (ebox-test-root item-input))
(source-index (ebox-test-source-index item-input))
(sequence
(ebox-child-range--build
(list (cons 'range (list item)))
(lambda (node)
(ebox-tree-node-author-key source-index node))))
(published
(aref (ebox-child-range--segment-payload
(ebox-child-range--lookup-ref sequence 'range))
0))
(signature (ebox--render-cache-value-signature sequence)))
(plist-put published :node-id 1)
(plist-put published :region-id 10)
(setq signature (ebox--render-cache-value-signature sequence))
(plist-put published :region-id 20)
(should-not
(equal signature (ebox--render-cache-value-signature sequence)))
(should (equal 10 (plist-get (cadr signature) :region-id)))))
(ert-deftest ebox-child-range-gate-a-exact-segment-and-payload-costs ()
"Point replacement cost follows trie height, never parent child count."
(dolist (case '((0 0 1) (10 1 2) (100 2 3) (500 2 3)))
(pcase-let* ((`(,static-count ,height ,bound) case)
(old (ebox-child-range-test--fixture static-count '(old)))
(old-flat (ebox-child-range--flatten old))
(result (ebox-child-range-test--replace
old 'range
(mapcar #'ebox-child-range-test--item
'(new-a new-b))))
(new (car result))
(metrics (cdr result)))
(should (= (ebox-child-range--sequence-count old) (1+ static-count)))
(should (= (ebox-child-range--sequence-height old) height))
(should (= (ebox-child-range--segment-node-segment-count
(ebox-child-range--sequence-root old))
(1+ static-count)))
(should (= (ebox-child-range--segment-node-weight
(ebox-child-range--sequence-root old))
(1+ static-count)))
(should (= (ebox-child-range--prefix-weight old static-count)
static-count))
(should (= (ebox-child-range--rank old static-count) static-count))
(pcase-let ((`(,nodes . ,edges)
(ebox-child-range--segment-memory old)))
(should (<= nodes (1+ (* (1+ static-count) (1+ height)))))
(should (= edges (1- nodes))))
(pcase-let ((`(,vectors . ,slots)
(ebox-child-range--segment-vector-memory old)))
(should (= slots (* vectors 32)))
(should (<= vectors (1+ (ceiling (/ (float (1+ static-count)) 32))))))
(should (<= (ebox-child-range--metrics-segment-visits metrics) bound))
(should (<= (ebox-child-range--metrics-segment-copies metrics) bound))
(should (= (ebox-child-range--metrics-old-affected-payload-visits metrics)
1))
(should (= (ebox-child-range--metrics-new-payload-visits metrics) 2))
(should (= (ebox-child-range--metrics-new-payload-validations metrics) 2))
(should (= (ebox-child-range--metrics-new-payload-copies metrics) 2))
(should (= (ebox-child-range--segment-node-weight
(ebox-child-range--sequence-root new))
(+ static-count 2)))
(should (= (ebox-child-range--rank new static-count) static-count))
(should (= (ebox-child-range--metrics-ref-index-visits metrics) 1))
(should (= (ebox-child-range--metrics-ref-index-copies metrics) 0))
(dolist (accessor
'(ebox-child-range--metrics-unaffected-payload-visits
ebox-child-range--metrics-unaffected-payload-validations
ebox-child-range--metrics-unaffected-payload-copies))
(should (zerop (funcall accessor metrics))))
(should (equal (ebox-child-range--flatten old) old-flat))
(should (equal (mapcar (lambda (item) (plist-get item :key))
(ebox-child-range--flatten new))
(append
(cl-loop for index below static-count
collect (list 'static index))
'(new-a new-b)))))))
(ert-deftest ebox-child-range-gate-a-key-bound-collisions-and-sharing ()
"Sparse hash work is bounded and unaffected segment branches remain shared."
(let* ((old (ebox-child-range-test--fixture 100 '(old-a old-b)
(lambda (_key) 0)))
(result (ebox-child-range-test--replace
old 'range
(mapcar #'ebox-child-range-test--item
'(new-a new-b new-c))))
(new (car result))
(metrics (cdr result))
(affected 2) (replacement 3)
(old-key-root (ebox-child-range--sequence-key-root old))
(old-first (aref (ebox-child-range--segment-node-children
(ebox-child-range--sequence-root old)) 0))
(new-first (aref (ebox-child-range--segment-node-children
(ebox-child-range--sequence-root new)) 0)))
(should (= (ebox-child-range--metrics-key-visits metrics) 35))
(should (= (ebox-child-range--metrics-key-copies metrics) 35))
(should (= (ebox-child-range--metrics-collision-visits metrics) 506))
(should (= (ebox-child-range--metrics-collision-copies metrics) 506))
(should (= (+ (ebox-child-range--metrics-key-visits metrics)
(ebox-child-range--metrics-collision-visits metrics))
(+ 35 506)))
(should (= (+ (ebox-child-range--metrics-key-copies metrics)
(ebox-child-range--metrics-collision-copies metrics))
(+ 35 506)))
(should (<= (+ (ebox-child-range--metrics-key-visits metrics)
(ebox-child-range--metrics-collision-visits metrics))
(+ (* (+ affected replacement) 7) 506)))
(should (<= (+ (ebox-child-range--metrics-key-copies metrics)
(ebox-child-range--metrics-collision-copies metrics))
(+ (* (+ affected replacement) 7) 506)))
(should (<= (ebox-child-range--metrics-key-visits metrics)
(+ (* (+ affected replacement) 7) 506)))
(should (<= (ebox-child-range--metrics-key-copies metrics)
(+ (* (+ affected replacement) 7) 506)))
(should (eq old-first new-first))
(should (eq (ebox-child-range--sequence-ref-index old)
(ebox-child-range--sequence-ref-index new)))
(should (eq (ebox-child-range--sequence-key-root old) old-key-root))
(should (equal (ebox-child-range--hash-lookup
(ebox-child-range--sequence-key-root new) 'new-b 0)
'(100 . 1)))
(should-not (ebox-child-range--hash-lookup
(ebox-child-range--sequence-key-root new) 'old-a 0))
(should (ebox-child-range--hash-lookup old-key-root 'old-a 0))
(pcase-let ((`(,nodes . ,edges)
(ebox-child-range--hash-memory
(ebox-child-range--sequence-key-root old))))
(should (<= nodes (1+ (* 7 102))))
(should (= edges (1- nodes))))))
(ert-deftest ebox-child-range-gate-a-empty-order-and-duplicates ()
"Empty ranges stay addressable and global ref/key uniqueness is exact."
(let* ((empty (ebox-child-range-test--fixture 1 nil))
(one (car (ebox-child-range-test--replace
empty 'range (list (ebox-child-range-test--item 'one)))))
(many (car (ebox-child-range-test--replace
one 'range
(mapcar #'ebox-child-range-test--item '(two three)))))
(empty-again (car (ebox-child-range-test--replace many 'range nil))))
(should (= (length (ebox-child-range--segment-payload
(ebox-child-range--segment-at empty 1))) 0))
(should (equal (mapcar (lambda (item) (plist-get item :key))
(ebox-child-range--flatten many))
'((static 0) two three)))
(should-not (cdr (ebox-child-range--flatten empty-again)))
(should-error
(ebox-child-range-test--build
(list (cons 'same nil) (cons 'same nil))))
(should-error (ebox-child-range-test--build (list (cons nil nil))))
(should-error (ebox-child-range-test--build nil))
(should-error
(ebox-child-range-test--build
(list (cons nil (list (ebox-child-range-test--item 'a)
(ebox-child-range-test--item 'b))))))
(should-error
(ebox-child-range-test--build
(list (cons nil (list (ebox-child-range-test--item 'duplicate)))
(cons 'range (list (ebox-child-range-test--item 'duplicate))))))
(should-error
(ebox-child-range-test--build
(list (cons 'left (list (ebox-child-range-test--item 'duplicate)))
(cons 'right (list (ebox-child-range-test--item 'duplicate))))))
(should-error
(ebox-child-range-test--replace
empty 'range
(list (ebox-child-range--descriptor-create 'nested nil))))
(should-error (ebox-child-range--descriptor-create nil nil))
(should-error (ebox-child-range--descriptor-create 'bad '(one . two)))
(should-error (ebox-child-range-test--replace empty 'range '(one . two)))
(should-error
(ebox-child-range-test--build (list (cons 'bad '(one . two)))))
(should-error (ebox-child-range-test--replace empty 'missing nil))))
(ert-deftest ebox-child-range-gate-a-adjacent-refs-and-unkeyed-items ()
"First, middle, and last Range refs stay O(1)-addressed and accept no key."
(let* ((segments
(list
(cons 'first (list (list :value 'unkeyed-first)))
(cons nil (list (ebox-child-range-test--item 'static-a)))
(cons 'middle (list (ebox-child-range-test--item 'middle-old)))
(cons 'adjacent (list (ebox-child-range-test--item 'adjacent)))
(cons nil (list (list :value 'unkeyed-static)))
(cons 'last nil)))
(base (ebox-child-range-test--build segments)))
(dolist (entry '((first first-new) (middle middle-new) (last last-new)))
(let* ((result
(ebox-child-range-test--replace
base (car entry)
(list (ebox-child-range-test--item (cadr entry)))))
(new (car result))
(metrics (cdr result)))
(should (= (ebox-child-range--metrics-ref-index-visits metrics) 1))
(should (= (ebox-child-range--metrics-ref-index-copies metrics) 0))
(should (eq (ebox-child-range--sequence-ref-index base)
(ebox-child-range--sequence-ref-index new)))
(should (equal
(ebox-child-range--hash-lookup
(ebox-child-range--sequence-key-root new)
(cadr entry)
(ebox-child-range--stable-hash (cadr entry)))
(cons (gethash (car entry)
(ebox-child-range--sequence-ref-index base))
0)))))
(should (equal (plist-get (car (ebox-child-range--flatten base)) :value)
'unkeyed-first))
(should (eq (ebox-child-range--segment-ref
(ebox-child-range--lookup-ref base 'middle))
'middle))))
(ert-deftest ebox-child-range-integration-is-transparent-and-indexed ()
"Compiled Range segments render as direct children and retain empty refs."
(let* ((static (ebox-test-box :key 'a :class "a" (ebox-test-text "A") :width '(40)))
(one (ebox-test-box :key 'b :class "b" (ebox-test-text "B") :width '(40)))
(two (ebox-test-box :key 'c :class "c" (ebox-test-text "C") :width '(40)))
(descriptor (ebox-child-range--descriptor-create 'items (list one two)))
(empty (ebox-child-range--descriptor-create 'empty nil))
(raw-items (ebox-child-range--descriptor-items descriptor))
(ranged (ebox-test-column static empty descriptor))
(direct (ebox-test-column
(ebox-test-box :key 'a :class "a" (ebox-test-text "A") :width '(40))
(ebox-test-box :key 'b :class "b" (ebox-test-text "B") :width '(40))
(ebox-test-box :key 'c :class "c" (ebox-test-text "C") :width '(40))))
(left (generate-new-buffer " *ebox-range-direct*"))
(right (generate-new-buffer " *ebox-range-compiled*")))
(unwind-protect
(progn
(ebox-render-to-buffer left direct)
(ebox-render-to-buffer right ranged)
(should (equal
(with-current-buffer left
(substring-no-properties (buffer-string)))
(with-current-buffer right
(substring-no-properties (buffer-string)))))
(should (equal
(mapcar #'ebox-string-pixel-width
(ebox-string-lines
(with-current-buffer left (buffer-string))))
(mapcar #'ebox-string-pixel-width
(ebox-string-lines
(with-current-buffer right (buffer-string))))))
(should (eq raw-items (ebox-child-range--descriptor-items descriptor)))
(should (equal (mapcar #'ebox-child-range-test--node-key raw-items)
'(b c)))
(let* ((direct-state (ebox--buffer-render-state left))
(state (ebox--buffer-render-state right))
(range-table (plist-get state :range-ref-table))
(empty-record (gethash 'empty range-table))
(items-record (gethash 'items range-table))
(empty-resolved
(ebox-incremental--range-ref-resolve state 'empty))
(items-resolved
(ebox-incremental--range-ref-resolve state 'items)))
(should empty-record)
(should items-record)
(should-not (plist-member empty-record :rank))
(should-not (plist-member empty-record :sequence))
(should (= (plist-get empty-resolved :rank) 1))
(should (= (plist-get items-resolved :rank) 1))
(should (= (ebox-runtime-index-size (plist-get state :node-table))
(ebox-runtime-index-size (plist-get direct-state :node-table))))
(should (= (hash-table-count (plist-get state :region-id-set))
(hash-table-count
(plist-get direct-state :region-id-set))))
(should (= (hash-table-count
(plist-get state :surface-node-object-table))
(hash-table-count
(plist-get direct-state :surface-node-object-table))))
(should (equal (plist-get empty-record :parent-node-id)
(plist-get (plist-get state :root-node) :node-id))))
(should (= (length (ebox-selector-query-buffer right ".a + .b")) 1))
(should (= (length (ebox-selector-query-buffer right ".a ~ .c")) 1)))
(dolist (buffer (list left right))
(when (buffer-live-p buffer) (kill-buffer buffer))))))
(ert-deftest ebox-child-range-integration-rejects-invalid-placement-atomically ()
"Range refs, keys, nesting, roots, and scalar slots fail before publication."
(should-error
(ebox-test-column
(ebox-child-range--descriptor-create
'outer (list (ebox-child-range--descriptor-create 'nested nil)))))
(should-error
(ebox-test-column
(ebox-test-box :key 'duplicate (ebox-test-text "a"))
(ebox-child-range--descriptor-create
'range (list (ebox-test-box :key 'duplicate (ebox-test-text "b"))))))
(let ((buffer (generate-new-buffer " *ebox-range-invalid*")))
(unwind-protect
(progn
(ebox-render-to-buffer buffer (ebox-test-box :key 'root (ebox-test-text "old")))
(let ((before (with-current-buffer buffer (buffer-string)))
(state (ebox--buffer-render-state buffer)))
(dolist
(root
(list
(ebox-child-range--descriptor-create
'root (list (ebox-test-box :key 'x (ebox-test-text "x"))))
(list :ebox-type 'box
:ebox-content-node
(ebox-child-range--descriptor-create 'scalar nil))
(ebox-test-column
(ebox-child-range--descriptor-create 'same nil)
(ebox-test-column
(ebox-child-range--descriptor-create 'same nil)))))
(should-error (ebox-commit buffer root))
(should (eq (ebox--buffer-render-state buffer) state))
(should (equal (with-current-buffer buffer (buffer-string))
before)))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-production-readers-use-tree-accessor ()
"Range-capable production consumers do not read node `:children' directly."
(dolist (file '("ebox.el" "ebox-layout.el" "ebox-flex.el" "ebox-grid.el"
"ebox-incremental.el" "ebox-native-reflow.el"
"ebox-surface.el"))
(with-temp-buffer
(insert-file-contents
(expand-file-name file ebox-child-range-test--root))
(should-not (re-search-forward
"plist-get[[:space:]\n]+\\(?:node\\|flex-node\\)[[:space:]\n]+:children"
nil t)))))
(ert-deftest ebox-child-range-ecss-subjects-and-inheritance-are-transparent ()
"Ranges add no ECSS subject and preserve child/sibling cascade semantics."
(let* ((ebox-style-stylesheet (ecss-stylesheet-create))
(direct-left
(ebox-test-box :key 'left :source-identity 'left :class "left"
(ebox-test-text "L") :width '(40)))
(direct-right
(ebox-test-box :key 'right :source-identity 'right :class "right"
(ebox-test-text "R") :width '(40)))
(range-left
(ebox-test-box :key 'left :source-identity 'left :class "left"
(ebox-test-text "L") :width '(40)))
(range-right
(ebox-test-box :key 'right :source-identity 'right :class "right"
(ebox-test-text "R") :width '(40)))
(left-range
(ebox-child-range--descriptor-create 'left-range (list range-left)))
(right-range
(ebox-child-range--descriptor-create 'right-range (list range-right)))
(direct (ebox-test-column
:class "parent" direct-left direct-right))
(ranged (ebox-test-column
:class "parent" left-range right-range))
(direct-buffer (generate-new-buffer " *ebox-range-ecss-direct*"))
(range-buffer (generate-new-buffer " *ebox-range-ecss-range*"))
(original (symbol-function 'ebox-style-compute-subject))
direct-subjects range-subjects)
(ebox-style-add-rule ".parent > .left" '(:color "#123456"))
(ebox-style-add-rule ".left + .right" '(:background-color "#ABCDEF"))
(unwind-protect
(progn
(cl-letf (((symbol-function 'ebox-style-compute-subject)
(lambda (&rest arguments)
(cl-incf direct-subjects)
(apply original arguments))))
(setq direct-subjects 0)
(ebox-render-to-buffer direct-buffer direct))
(cl-letf (((symbol-function 'ebox-style-compute-subject)
(lambda (&rest arguments)
(cl-incf range-subjects)
(apply original arguments))))
(setq range-subjects 0)
(ebox-render-to-buffer range-buffer ranged))
(should (= direct-subjects range-subjects))
(should (= (length (ebox-selector-query-buffer
range-buffer ".left + .right")) 1))
(let ((direct-faces
(with-current-buffer direct-buffer
(cl-loop for position from (point-min) below (point-max)
collect (get-text-property position 'face))))
(range-faces
(with-current-buffer range-buffer
(cl-loop for position from (point-min) below (point-max)
collect (get-text-property position 'face)))))
(should (equal direct-faces range-faces)))
(dolist (node (list range-left range-right))
(should-not (plist-get node :node-id))
(should-not (plist-get node :region-id))
(should-not (plist-get node :surface-object)))
(dolist (ref '(left right))
(let* ((state (ebox--buffer-render-state range-buffer))
(node-id
(gethash ref
(ebox-child-range-test--host-ref-table state)))
(node
(ebox-runtime-index-get
node-id (plist-get state :node-table))))
(should node-id)
(should (equal
(ebox-child-range-test--node-key
node (plist-get state :source-index))
ref)))))
(dolist (buffer (list direct-buffer range-buffer))
(when (buffer-live-p buffer) (kill-buffer buffer))))))
(ert-deftest ebox-child-range-path-copy-replaces-compiled-material-child ()
"Tree path copying cannot ignore a child stored in a compiled sequence."
(let* ((source
(ebox-test-column
(ebox-test-box :key 'static (ebox-test-text "static"))
(ebox-test-child-range
'items (ebox-test-box :key 'old (ebox-test-text "old")))))
(compiled (ebox-tree-copy-node-structure (ebox-test-root source)))
(old-child (cadr (ebox-tree-layout-children compiled)))
(new-input (ebox-test-box :key 'new (ebox-test-text "new")))
(new-child (ebox-test-root new-input))
(source-index
(ebox-test-source-index
(ebox-test-forest-input source new-input)))
(unchanged (ebox-tree-copy-with-direct-child-replacements compiled nil))
(copy (ebox-tree-copy-with-direct-child-replacements
compiled (list (cons old-child new-child))
(lambda (node)
(ebox-child-range-test--node-key node source-index)))))
(should (eq (plist-get unchanged :ebox-child-sequence)
(plist-get compiled :ebox-child-sequence)))
(should (equal (mapcar (lambda (node)
(ebox-child-range-test--node-key
node source-index))
(ebox-tree-layout-children copy))
'(static new)))
(should (equal (mapcar (lambda (node)
(ebox-child-range-test--node-key
node source-index))
(ebox-tree-layout-children compiled))
'(static old)))
(let* ((original (ebox-test-text "old"))
(range (ebox-test-child-range 'typed original))
(typed-input (ebox-test-column range))
(typed (ebox-test-root typed-input))
(owned (car (ebox-box-node-children typed)))
(replacement-input (ebox-test-text "new"))
(replacement (ebox-test-root replacement-input))
(replaced
(ebox-tree-copy-with-direct-child-replacements
typed (list (cons owned replacement))))
(builder (ebox-source-builder-create))
(_typed-sources
(ebox-source-builder-import
builder (ebox-test-source-index typed-input)))
(_replacement-sources
(ebox-source-builder-import
builder (ebox-test-source-index replacement-input)))
(replaced-index
(ebox-tree-source-builder-snapshot builder (list replaced)))
direct)
(ebox-tree-for-each-direct-child
replaced (lambda (child) (push child direct)))
(setq direct (nreverse direct))
(dolist (view (list (ebox-box-node-children replaced)
direct
(ebox-tree-layout-children replaced)
(ebox-tree-semantic-children replaced)))
(should (= (length view) 1))
(should (eq (car view) replacement)))
(should (eq (ebox-tree-validate-declarative-root
replaced nil nil replaced-index)
replaced))
(should-error
(ebox-tree-copy-with-direct-child-replacements
typed (list (cons owned nil)))
:type 'error))))
(ert-deftest ebox-child-range-empty-sequence-is-authoritative ()
"An all-empty sequence cannot fall through to legacy alias children."
(let* ((sequence (ebox-child-range-test--build (list (cons 'empty nil))))
(legacy (ebox-test-box :key 'legacy (ebox-test-text "legacy")))
(node (list :ebox-type 'stack :ebox-child-sequence sequence
:top legacy :bottom legacy)))
(should-not (ebox-tree-layout-children node))))
(ert-deftest ebox-child-range-validator-covers-wrapper-and-scalar-slots ()
"Flat Range compilation cannot hide wrappers or admit scalar descriptors."
(let* ((wrapper-input
(ebox-test-box :key 'wrapper :source-identity 'wrapper (ebox-test-text "W")))
(item-input
(ebox-test-box :key 'item :source-identity 'item (ebox-test-text "I")))
(wrapper (ebox-test-root wrapper-input))
(item (ebox-test-root item-input))
(descriptor (ebox-test-child-range 'items item-input))
(source (list :ebox-type 'flex :display '(block flex)
:box wrapper :children (list descriptor)))
(typed-input (ebox-test-column descriptor))
(typed (ebox-test-root typed-input)))
(should-error (ebox-tree-copy-node-structure source) :type 'error)
(ebox-tree-validate-declarative-root
typed nil nil (ebox-test-source-index typed-input))
(let* ((copy (ebox-tree-copy-node-structure typed))
(copy-wrapper (car (ebox-tree-layout-children copy)))
(copy-item (car (ebox-tree-layout-children copy))))
(should-not (eq item copy-wrapper))
(should-not (eq item copy-item))
(dolist (node (list wrapper item))
(should-not (plist-get node :node-id))
(should-not (plist-get node :region-id))
(should-not (plist-get node :surface-object))))
(should-error
(ebox-tree-validate-declarative-root
(list :ebox-type 'stack :display '(block column)
:top (ebox-child-range--descriptor-create 'bad nil)
:bottom (ebox-test-box :key 'bottom (ebox-test-text "B")))))
(should-error
(ebox-tree-validate-declarative-root
(list :ebox-type 'flex :display '(block flex)
:box (ebox-test-box :key 'same :source-identity 'same (ebox-test-text "W"))
:children
(list (ebox-child-range--descriptor-create
'items
(list (ebox-test-box :key 'item :source-identity 'same
(ebox-test-text "I"))))))))))
(ert-deftest ebox-child-range-public-candidate-splices-and-reports ()
"Public child Ranges support empty and repeated last-wins candidate splices."
(let* ((buffer (generate-new-buffer " *ebox-public-range*"))
(source
(ebox-test-column
(ebox-test-box :key 'static (ebox-test-text "S"))
(ebox-test-child-range 'items)))
report)
(unwind-protect
(progn
(ebox-render-to-buffer buffer source)
(dolist (items
(list
(list (ebox-test-box :key 'one (ebox-test-text "1")))
(list (ebox-test-box :key 'two (ebox-test-text "2"))
(ebox-test-box :key 'three (ebox-test-text "3")))
(list (ebox-test-box :key 'final (ebox-test-text "F")))
nil))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items (ebox-child-range-test--input items))
(when items
(ebox-candidate-replace-range-ref
candidate 'items (ebox-child-range-test--input items)))
(setq report (ebox-commit buffer candidate))
(should (plist-get report :range-metrics))))
(should (gethash 'items
(plist-get (ebox--buffer-render-state buffer)
:range-ref-table))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-candidate-retains-proven-owned-items ()
"A fresh candidate-owned Range item is not copied twice before commit."
(let* ((buffer (generate-new-buffer " *ebox-range-retained-items*"))
(input
(ebox-child-range-test--input
(list (ebox-test-box :key 'new (ebox-test-text "new")))))
(item (ebox-test-root input)))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-box :key 'static (ebox-test-text "static"))
(ebox-test-child-range
'items (ebox-test-box :key 'old (ebox-test-text "old")))))
(let* ((candidate (ebox-candidate-begin buffer))
entry)
(ebox-candidate-replace-range-ref
candidate 'items input nil t)
(setq entry (car (ebox-candidate--range-replacements candidate)))
(should
(ebox-incremental--candidate-range-replacement-retain-item-identities-p
entry))
(should (eq item
(car
(ebox-incremental--candidate-range-replacement-items
entry))))
(ebox-commit buffer candidate))
(let* ((state (ebox--buffer-render-state buffer))
(record (gethash 'items (plist-get state :range-ref-table)))
(parent (ebox-runtime-index-get (plist-get record :parent-node-id)
(plist-get state :node-table)))
(segment
(ebox-child-range--lookup-ref
(plist-get parent :ebox-child-sequence) 'items))
(published (aref (ebox-child-range--segment-payload segment) 0)))
(should (eq published item))
(should (plist-get published :node-id))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-candidate-retention-falls-back-on-runtime-identity ()
"A retention proof miss uses the ordinary identity-clearing copy path."
(let* ((buffer (generate-new-buffer " *ebox-range-retention-fallback*"))
(input
(ebox-child-range-test--input
(list (ebox-test-box :key 'new (ebox-test-text "new")))))
(item (ebox-test-root input)))
(plist-put item :node-id 999)
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-child-range
'items (ebox-test-box :key 'old (ebox-test-text "old")))))
(let* ((candidate (ebox-candidate-begin buffer))
entry retained)
(ebox-candidate-replace-range-ref
candidate 'items input nil t)
(setq entry (car (ebox-candidate--range-replacements candidate))
retained
(ebox-incremental--candidate-range-replacement-items entry))
(should-not
(ebox-incremental--candidate-range-replacement-retain-item-identities-p
entry))
(should-not (eq item (car retained)))
(should-not (plist-get (car retained) :node-id))
(ebox-commit buffer candidate))
(should (string-match-p "new" (with-current-buffer buffer
(buffer-string)))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-candidate-retains-fresh-slots-around-reuse ()
"Mixed Range updates retain fresh slots while preserving reused slots."
(let* ((buffer (generate-new-buffer " *ebox-range-mixed-retention*"))
(input
(ebox-child-range-test--input
(list (ebox-test-box :key 'old-one (ebox-test-text "old-one"))
(ebox-test-box :key 'new-two (ebox-test-text "new-two")))))
(fresh (nth 1 (ebox-test-forest input))))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-child-range
'items
(ebox-test-box :key 'old-one (ebox-test-text "old-one"))
(ebox-test-box :key 'old-two (ebox-test-text "old-two")))))
(let* ((candidate (ebox-candidate-begin buffer))
entry)
(ebox-candidate-replace-range-ref
candidate 'items input '((0 . 0)) t)
(setq entry (car (ebox-candidate--range-replacements candidate)))
(should
(ebox-incremental--candidate-range-replacement-retain-item-identities-p
entry))
(should (eq fresh
(nth 1
(ebox-incremental--candidate-range-replacement-items
entry))))
(ebox-commit buffer candidate))
(let* ((state (ebox--buffer-render-state buffer))
(record (gethash 'items (plist-get state :range-ref-table)))
(parent (ebox-runtime-index-get (plist-get record :parent-node-id)
(plist-get state :node-table)))
(segment
(ebox-child-range--lookup-ref
(plist-get parent :ebox-child-sequence) 'items))
(payload (ebox-child-range--segment-payload segment)))
(should (eq fresh (aref payload 1)))
(should (plist-get (aref payload 1) :node-id))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-stable-keyed-refresh-is-not-structural ()
"Stable keyed Range refreshes must not become root structure updates."
(let ((buffer (generate-new-buffer " *ebox-stable-range-dirty*")))
(cl-labels
((rows (selected)
(cl-loop for id from 1 to 12
for content = (ebox-test-text (format "row-%02d" id))
collect
(if (= id selected)
(ebox-test-box
:key id :width '(420) :color "#2F6B43" content)
(ebox-test-box :key id :width '(420) content))))
(root ()
(ebox-test-box
:width '(900) :color "#172033" :wrap-mode 'none
(ebox-test-flex
:width '(900)
(ebox-test-box
:key 'list :width 'stretch :min-width 0 :wrap-mode 'none
:min-height 24 :padding '(2 2) :border "#687386"
:flex-grow 2 :flex-shrink 1 :flex-basis '(600)
(ebox-test-column
(apply #'ebox-test-child-range 'items (rows 1))))
(ebox-test-box :key 'detail :source-identity 'detail
:width 'stretch :min-width 0
:min-height 24 :padding '(2 2) :border "#687386"
:flex-grow 1 :flex-shrink 1 :flex-basis '(300)
(ebox-test-text "detail-1"))))))
(unwind-protect
(progn
(ebox-render-to-buffer buffer (root))
(dolist (selected '(2 1 2))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input (rows selected)))
(ebox-candidate-replace-host-ref
candidate 'detail
(ebox-test-box :key 'detail :source-identity 'detail
:width 'stretch :min-width 0
:min-height 24 :padding '(2 2)
:border "#687386"
:flex-grow 1 :flex-shrink 1 :flex-basis '(300)
(ebox-test-text (format "detail-%d" selected))))
(let ((report (ebox-commit buffer candidate)))
(ert-info ((format "selected=%S report=%S"
selected report))
(should-not (memq 'structure
(plist-get report :dirty-kinds)))
(should (memq 'paint
(plist-get report :dirty-kinds)))
(should (memq (plist-get report :strategy)
'(span-patch owner-rerender
mixed-owner-reflow)))
(should (> (plist-get report :tp-scope-count) 0))
(should-not (plist-get report :tp-full-root))
(should (= (plist-get report :created-objects) 0))
(should (= (plist-get report :removed-objects) 0))
(with-current-buffer buffer
(should (string-match-p
(format "detail-%d" selected)
(buffer-string)))))))))
(when (buffer-live-p buffer) (kill-buffer buffer))))))
(defun ebox-child-range-test--snapshot-detail (expanded &optional title)
"Return a retained detail root, with TITLE and status when EXPANDED."
(if expanded
(ebox-test-column :key 'detail :source-identity 'detail :overflow 'scroll
:bgcolor "#E8DED1"
(ebox-test-text (propertize (or title "title-1") 'face '(:weight bold))
:key 'title :source-identity 'title)
(ebox-test-text "status" :key 'status :source-identity 'status))
(ebox-test-text "placeholder" :key 'detail :source-identity 'detail)))
(defun ebox-child-range-test--snapshot-replacement-root ()
"Return a detail Range beside painted rows and an active scroll sibling."
(ebox-test-column :width '(200) :bgcolor "#FFFDF8"
(ebox-test-box :key 'row-1 :source-identity 'row-1 :color "#123456"
(ebox-test-text "row-1"))
(ebox-test-box :key 'row-2 :source-identity 'row-2 :color "#654321"
(ebox-test-text "row-2"))
(ebox-test-column :bgcolor "#DDE7EF"
:surface-properties '(help-echo "retained detail help")
(ebox-test-child-range
'details (ebox-child-range-test--snapshot-detail nil)))
(ebox-test-box :key 'scroll :source-identity 'scroll
:height 2 :width '(80) :overflow 'scroll
(ebox-test-text "line-a\nline-b\nline-c\nline-d"))))
(defun ebox-child-range-test--replace-snapshot-detail (buffer expanded)
"Return a BUFFER candidate replacing its detail Range with EXPANDED content."
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'details (ebox-child-range-test--snapshot-detail expanded))
candidate))
(defun ebox-child-range-test--assert-current-snapshot (buffer node-id)
"Assert BUFFER's NODE-ID snapshot reflects its current structural/style facts."
(let* ((node (ebox--buffer-runtime-node buffer node-id))
(expected (ebox--node-layout-snapshot buffer node))
(actual (ebox--layout-snapshot buffer node-id)))
(dolist (key '(:type :display :region-ids :style-signature :child-ids))
(ert-info ((format "current snapshot field %S" key))
(should (equal (plist-get expected key) (plist-get actual key)))))))
(defun ebox-child-range-test--assert-full-render-equivalent (buffer)
"Assert BUFFER exactly matches a full render of its published root."
(with-current-buffer buffer
(let* ((state (ebox--buffer-render-state buffer))
(expected (ebox--render-node (plist-get state :root-node)
(plist-get state :source-index))))
(should (equal-including-properties expected (buffer-string))))))
(ert-deftest ebox-child-range-retained-kind-replacement-refreshes-snapshots ()
"Text/Column roundtrips refresh facts only after successful publication."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(let* ((owner-id (plist-get (ebox--host-ref-node (current-buffer) 'detail)
:node-id))
(sibling-id (plist-get (ebox--host-ref-node (current-buffer) 'row-1)
:node-id))
(ancestors
(let ((node-id owner-id)
(parents (plist-get (ebox--buffer-render-state (current-buffer))
:parent-table))
result)
(while (setq node-id (ebox-runtime-index-get node-id parents))
(push node-id result))
result)))
(dolist (expanded '(t nil t))
(ert-info ((format "detail expanded=%S" expanded))
(dolist (ancestor ancestors)
(ebox--layout-snapshot (current-buffer) ancestor))
(ebox--ensure-layout-snapshot-details (current-buffer) sibling-id)
(let* ((old (ebox--ensure-layout-snapshot-details (current-buffer) owner-id))
(old-facts (copy-tree old))
(state (ebox--buffer-render-state (current-buffer)))
(snapshots (plist-get state :layout-snapshots))
(runtime-revision (plist-get state :runtime-revision))
(surface-revision (tp-surface-revision ebox-surface--buffer-surface))
(scroll-id (car (plist-get state :scroll-region-ids)))
(scroll (gethash scroll-id ebox--scroll-global-state))
(before (buffer-string))
sibling-seed sibling-seed-facts
(seed-observer
(lambda (candidate-state)
(setq sibling-seed
(gethash sibling-id (plist-get candidate-state
:layout-snapshots))
sibling-seed-facts (copy-tree sibling-seed)))))
(should (equal (if expanded '(inline flow) '(block column))
(plist-get old :display)))
(should (eq (if expanded 'visible 'scroll)
(plist-get (plist-get old :style-signature) :overflow)))
(cl-letf (((symbol-function 'accept-change-group)
(lambda (_) (error "Reject retained kind replacement"))))
(should (equal
(should-error
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail
(current-buffer) expanded)))
'(error "Reject retained kind replacement"))))
(should (eq state (ebox--buffer-render-state (current-buffer))))
(should (eq snapshots (plist-get state :layout-snapshots)))
(should (eq old (gethash owner-id snapshots)))
(should (equal old-facts old))
(should (= runtime-revision (plist-get state :runtime-revision)))
(should (= surface-revision
(tp-surface-revision ebox-surface--buffer-surface)))
(should (eq scroll (gethash scroll-id ebox--scroll-global-state)))
(should (equal-including-properties before (buffer-string)))
(advice-add 'ebox-surface--render-candidate :before seed-observer)
(unwind-protect
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail
(current-buffer) expanded))
(advice-remove 'ebox-surface--render-candidate seed-observer))
(should (ebox--layout-snapshot-detailed-p sibling-seed))
(should (eq sibling-seed
(gethash sibling-id
(plist-get (ebox--buffer-render-state (current-buffer))
:layout-snapshots))))
(should (equal sibling-seed-facts sibling-seed))
(should (= owner-id
(plist-get (ebox--host-ref-node (current-buffer) 'detail)
:node-id)))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(ebox-child-range-test--assert-current-snapshot
(current-buffer) owner-id)
(dolist (ancestor ancestors)
(ebox-child-range-test--assert-current-snapshot
(current-buffer) ancestor))))))))
(ert-deftest ebox-child-range-owner-scoped-followup-retains-proven-mounts ()
"Repeated single-owner text updates retain published properties and mounts."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let* ((surface ebox-surface--buffer-surface)
(state (ebox--buffer-render-state (current-buffer)))
(mounts (tp--surface-mounts surface))
(mount-ids (mapcar #'tp--surface-mount-id mounts))
(mount-index (tp--surface-mount-index surface))
(index (tp--surface-index surface))
(ranges (plist-get state :surface-owned-ranges))
(title-id (plist-get (ebox--host-ref-node (current-buffer) 'title) :node-id))
retained)
(dolist (title '("title-2" "title-3" "title-1"))
(let ((candidate (ebox-candidate-begin (current-buffer))))
(ebox-candidate-replace-host-ref
candidate 'title
(ebox-test-text (propertize title 'face '(:weight bold))
:key 'title :source-identity 'title))
(let* ((report (ebox-commit (current-buffer) candidate))
(next-state (ebox--buffer-render-state (current-buffer)))
(tp-report (tp-surface-report surface)))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should (eq (plist-get report :projection-kind) 'owner-scoped))
(should (= (plist-get report :dirty-count) 1))
(should (= title-id
(plist-get (ebox--host-ref-node (current-buffer) 'title) :node-id)))
(should-not (plist-get report :tp-full-root))
(should-not (plist-member next-state :span-patch-retained-owned-ranges))
(should-not (plist-member next-state :paint-property-contributions))
;; Exercise every semantic update before checking the new reuse claim.
(push (list :title title :batch (plist-get tp-report :commit-batch)
:retained (plist-get tp-report :retained-mount-state)
:mounts (eq mounts (tp--surface-mounts surface))
:ids (equal mount-ids
(mapcar #'tp--surface-mount-id
(tp--surface-mounts surface)))
:mount-index (eq mount-index (tp--surface-mount-index surface))
:index (eq index (tp--surface-index surface))
:snapshot (eq ranges (plist-get next-state :surface-owned-ranges)))
retained))))
(dolist (sample (nreverse retained))
(ert-info ((format "owner-scoped reuse sample %S" sample))
(dolist (key '(:batch :retained :mounts :ids :mount-index :index :snapshot))
(should (plist-get sample key))))))))
(ert-deftest ebox-child-range-span-followup-retains-proven-mounts ()
"A span projection consumes the same exact single-owner authority."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let* ((surface ebox-surface--buffer-surface)
(mounts (tp--surface-mounts surface))
(mount-index (tp--surface-mount-index surface))
(ranges (plist-get (ebox--buffer-render-state (current-buffer))
:surface-owned-ranges))
(candidate (ebox-candidate-begin (current-buffer)))
observed
(observer
(lambda (original &rest arguments)
(setq observed t)
(let* ((state (nth 2 arguments))
(proofs (plist-get state :owner-scoped-proofs)))
(should (eq (nth 4 arguments) 'owner-scoped))
(should (= (length proofs) 1))
(should-not (plist-get (car proofs) :range-splice-p))
(should (eq ranges (plist-get state :span-patch-retained-owned-ranges)))
(setcar (nthcdr 4 arguments) 'span-patch)
(plist-put state :projection-kind 'span-patch)
(apply original arguments)))))
(ebox-candidate-replace-host-ref
candidate 'title
(ebox-test-text (propertize "title-2" 'face '(:weight bold))
:key 'title :source-identity 'title))
(advice-add 'ebox-surface--projection-result :around observer)
(unwind-protect
(ebox-commit (current-buffer) candidate)
(advice-remove 'ebox-surface--projection-result observer))
(should observed)
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should (plist-get (tp-surface-report surface) :commit-batch))
(should (plist-get (tp-surface-report surface) :retained-mount-state))
(should (eq mounts (tp--surface-mounts surface)))
(should (eq mount-index (tp--surface-mount-index surface)))
(should (eq ranges (plist-get (ebox--buffer-render-state (current-buffer))
:surface-owned-ranges))))))
(ert-deftest ebox-child-range-owner-scoped-followup-rolls-back-and-retries ()
"A rejected single-owner publication restores the exact prior generation."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(cl-labels
((candidate ()
(let ((value (ebox-candidate-begin (current-buffer))))
(ebox-candidate-replace-host-ref
value 'title
(ebox-test-text (propertize "title-2" 'face '(:weight bold))
:key 'title :source-identity 'title))
value)))
(let* ((surface ebox-surface--buffer-surface)
(state (ebox--buffer-render-state (current-buffer)))
(revision (tp-surface-revision surface))
(runtime-revision (plist-get state :runtime-revision))
(previous-report (tp-surface-report surface))
(mounts (tp--surface-mounts surface))
(mount-ids (mapcar #'tp--surface-mount-id mounts))
(mount-index (tp--surface-mount-index surface))
(index (tp--surface-index surface))
(ranges (plist-get state :surface-owned-ranges))
(snapshots (plist-get state :layout-snapshots))
(scroll-id (car (plist-get state :scroll-region-ids)))
(scroll (gethash scroll-id ebox--scroll-global-state))
(before (buffer-string)) trace)
(should-error
(ebox-commit
(current-buffer) (candidate)
(lambda (_report) (push 'publish trace) (error "reject owner publication"))
(lambda (_report) (push 'rollback trace))))
(should (equal trace '(rollback publish)))
(should (eq state (ebox--buffer-render-state (current-buffer))))
(should (eq state (tp-surface-client-state surface)))
(should (= revision (tp-surface-revision surface)))
(should (= runtime-revision (plist-get state :runtime-revision)))
(should (equal previous-report (tp-surface-report surface)))
(should (eq ranges (plist-get state :surface-owned-ranges)))
(should (eq snapshots (plist-get state :layout-snapshots)))
(should (eq mounts (tp--surface-mounts surface)))
(should (equal mount-ids (mapcar #'tp--surface-mount-id mounts)))
(should (eq mount-index (tp--surface-mount-index surface)))
(should (eq index (tp--surface-index surface)))
(should (eq scroll (gethash scroll-id ebox--scroll-global-state)))
(should (equal-including-properties before (buffer-string)))
(let* ((report (ebox-commit (current-buffer) (candidate)))
(next-state (ebox--buffer-render-state (current-buffer))))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should (= (1+ revision) (tp-surface-revision surface)))
(should (= (1+ runtime-revision) (plist-get next-state :runtime-revision)))
(should (eq (plist-get report :projection-kind) 'owner-scoped))
(should-not (plist-member next-state :span-patch-retained-owned-ranges))
(should-not (plist-member next-state :paint-property-contributions))
(should (plist-get (tp-surface-report surface) :commit-batch))
(should (plist-get (tp-surface-report surface) :retained-mount-state))
(should (eq mounts (tp--surface-mounts surface)))
(should (equal mount-ids (mapcar #'tp--surface-mount-id mounts)))
(should (eq mount-index (tp--surface-mount-index surface)))
(should (eq index (tp--surface-index surface)))
(should (eq ranges (plist-get next-state :surface-owned-ranges))))))))
(ert-deftest ebox-child-range-owner-scoped-followup-proof-misses-keep-fallback ()
"Each absent strict authority keeps a single-owner update on its fallback."
(dolist (miss '(projection no-proof multi-owner range paint
no-witness copied-witness coordinates))
(ert-info ((format "owner-scoped proof miss %S" miss))
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let* ((candidate (ebox-candidate-begin (current-buffer)))
(extent (buffer-size)) observed
(observer
(lambda (original &rest arguments)
(setq observed t)
(let* ((state (nth 2 arguments))
(proofs (plist-get state :owner-scoped-proofs))
(witness (plist-get state :span-patch-retained-owned-ranges)))
(unless (eq miss 'coordinates)
(should (eq (nth 4 arguments) 'owner-scoped))
(should (= (length proofs) 1))
(should witness)
(should (eq witness (plist-get state :previous-surface-owned-ranges))))
(pcase miss
('projection
;; Both owner-scoped and span-patch now consume this
;; exact ownership proof. Ordinary projection has no
;; retained-span authority and must take the fallback.
(setcar (nthcdr 4 arguments) nil)
(plist-put state :projection-kind nil))
('no-proof (plist-put state :owner-scoped-proofs nil))
('multi-owner
(plist-put state :owner-scoped-proofs
(append proofs (list (copy-sequence (car proofs))))))
('range
(plist-put state :owner-scoped-proofs
(list (plist-put (copy-sequence (car proofs))
:range-splice-p t))))
('paint
(plist-put state :paint-property-contributions
'((:start 0 :end 0 :props nil))))
('no-witness (cl-remf state :span-patch-retained-owned-ranges))
('copied-witness
(let ((copy (copy-tree witness)))
(should (equal copy witness))
(should-not (eq copy witness))
(plist-put state :span-patch-retained-owned-ranges copy))))
(apply original arguments)))))
(ebox-candidate-replace-host-ref
candidate 'title
(ebox-test-text
(propertize (if (eq miss 'coordinates) "title-2 with a longer extent" "title-2")
'face '(:weight bold))
:key 'title :source-identity 'title))
(advice-add 'ebox-surface--projection-result :around observer)
(unwind-protect
(ebox-commit (current-buffer) candidate)
(advice-remove 'ebox-surface--projection-result observer))
(should observed)
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(when (eq miss 'coordinates) (should-not (= extent (buffer-size))))
(should-not (plist-member (ebox--buffer-render-state (current-buffer))
:span-patch-retained-owned-ranges))
(should-not (plist-member (ebox--buffer-render-state (current-buffer))
:paint-property-contributions))
(should-not (plist-get (tp-surface-report ebox-surface--buffer-surface)
:retained-mount-state)))))))
(defun ebox-child-range-test--mixed-followup-candidate (buffer selected &optional title)
"Return BUFFER's title and row-paint candidate for SELECTED, using TITLE."
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-host-ref
candidate 'title
(ebox-test-text (propertize (or title (format "title-%d" selected))
'face '(:weight bold))
:key 'title :source-identity 'title))
(dolist (row '(1 2))
(let ((ref (intern (format "row-%d" row))))
(ebox-candidate-replace-host-ref
candidate ref
(ebox-test-box :key ref :source-identity ref
:color (if (= row selected) "#123456" "#654321")
(ebox-test-text (format "row-%d" row))))))
candidate))
(ert-deftest ebox-child-range-paint-marker-consumption-preserves-input-baselines ()
"Layering consumes transient markers without changing input or permanent facts."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(let* ((state (copy-sequence (ebox--buffer-render-state (current-buffer))))
(template (car (ebox-surface--materialized-fragment-ledger state)))
(roles (plist-get template :paint-role-ids))
(fragments
(cl-loop for text in '("A" "B" "")
for marker in (list roles nil nil)
for baseline in '((:slant italic) nil nil)
collect
(let ((fragment (copy-sequence template)))
(plist-put fragment :text (propertize text 'face 'bold))
(plist-put fragment :text-source-p nil)
(plist-put fragment :face-baseline baseline)
(plist-put fragment :face-baseline-known-p t)
(plist-put fragment :old-paint-role-ids marker))))
(before (copy-tree fragments))
(before-text (mapcar (lambda (fragment)
(copy-sequence (plist-get fragment :text)))
fragments))
(result (ebox-surface--layer-paint-contributions "" fragments state)))
(should roles)
(should (equal-including-properties fragments before))
(should (plist-get state :paint-property-contributions))
(cl-mapc
(lambda (input output text)
(should (equal-including-properties (plist-get input :text) text))
(should (plist-member input :old-paint-role-ids))
(should-not (eq input output))
(dolist (key '(:paint-role-ids :paint-address :paint-node-chain))
(should (eq (plist-get input key) (plist-get output key))))
(should (equal (plist-get input :face-baseline)
(plist-get output :face-baseline)))
(should (plist-get output :face-baseline-known-p))
(when (> (length (plist-get output :text)) 0)
(should (equal (get-text-property 0 'face (plist-get output :text))
(plist-get input :face-baseline)))))
fragments result before-text)
(dolist (fragment result)
(should-not (plist-member fragment :old-paint-role-ids))))))
(defun ebox-child-range-test--paint-owner-candidate (buffer title &optional ref color)
"Return BUFFER's TITLE update and optional disjoint REF paint COLOR."
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-host-ref
candidate 'title
(ebox-test-text (propertize title 'face '(:weight bold))
:key 'title :source-identity 'title))
(when ref
(ebox-candidate-replace-host-ref
candidate ref
(ebox-test-box :key ref :source-identity ref :color color
(ebox-test-text (symbol-name ref)))))
candidate))
(ert-deftest ebox-child-range-paint-marker-consumption-isolates-disjoint-history ()
"Mixed A, retained text, mixed B, and A publish only their current paint work."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let* ((surface ebox-surface--buffer-surface)
(state (ebox--buffer-render-state (current-buffer)))
(mounts (tp--surface-mounts surface))
(mount-ids (mapcar #'tp--surface-mount-id mounts))
(mount-index (tp--surface-mount-index surface))
(ranges (plist-get state :surface-owned-ranges)))
(dolist (step '(("title-2" row-1 "#224466") ("title-3")
("title-4" row-2 "#446688") ("title-5" row-1 "#6688AA")))
(let* ((ref (nth 1 step))
(paint-object
(and ref
(gethash (plist-get (ebox--host-ref-node (current-buffer) ref) :node-id)
(plist-get state :surface-node-object-table))))
layers report
(observer
(lambda (_context _projection candidate-state _output &optional _kind)
(setq layers (copy-tree (plist-get candidate-state
:paint-property-contributions))))))
(advice-add 'ebox-surface--projection-result :before observer)
(unwind-protect
(setq report
(ebox-commit
(current-buffer)
(apply #'ebox-child-range-test--paint-owner-candidate
(current-buffer) step)))
(advice-remove 'ebox-surface--projection-result observer))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should (eq (plist-get report :projection-kind)
(if ref 'mixed-owner-reflow 'owner-scoped)))
(if (not ref)
(should-not layers)
(should layers)
(let ((owned (tp-object-mounts paint-object)))
(dolist (layer layers)
(ert-info ((format "current owner %S layer %S mounts %S" ref layer owned))
(should
(cl-loop for offset from (plist-get layer :start)
below (plist-get layer :end)
always (cl-some
(lambda (mount)
(and (<= (plist-get mount :start) (1+ offset))
(< (1+ offset) (plist-get mount :end))))
owned)))))))
(let ((next-state (ebox--buffer-render-state (current-buffer))))
(dolist (fragment (ebox-surface--materialized-fragment-ledger next-state))
(should-not (plist-member fragment :old-paint-role-ids)))
(should (eq ranges (plist-get next-state :surface-owned-ranges))))
(should (plist-get (tp-surface-report surface) :commit-batch))
(should (plist-get (tp-surface-report surface) :retained-mount-state))
(should (eq mounts (tp--surface-mounts surface)))
(should (eq mount-index (tp--surface-mount-index surface)))
(should (equal mount-ids (mapcar #'tp--surface-mount-id mounts))))))))
(ert-deftest ebox-child-range-paint-marker-consumption-rolls-back-and-retries ()
"Rejected layering preserves its prior ledger exactly before a fresh retry."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(dolist (step '(("title-2" row-1 "#224466") ("title-3")))
(ebox-commit
(current-buffer)
(apply #'ebox-child-range-test--paint-owner-candidate (current-buffer) step)))
(let* ((surface ebox-surface--buffer-surface)
(state (ebox--buffer-render-state (current-buffer)))
(revision (tp-surface-revision surface))
(runtime-revision (plist-get state :runtime-revision))
(ledger (plist-get state :surface-fragments))
(ledger-before (copy-tree ledger))
(ranges (plist-get state :surface-owned-ranges))
(mounts (tp--surface-mounts surface))
(mount-ids (mapcar #'tp--surface-mount-id mounts))
(mount-index (tp--surface-mount-index surface))
(index (tp--surface-index surface))
(before (buffer-string)) (layer-calls 0) trace
(observer (lambda (&rest _arguments) (cl-incf layer-calls))))
(advice-add 'ebox-surface--layer-paint-contributions :after observer)
(unwind-protect
(should-error
(ebox-commit
(current-buffer)
(ebox-child-range-test--paint-owner-candidate
(current-buffer) "title-4" 'row-2 "#446688")
(lambda (_report)
(should (= layer-calls 1))
(push 'publish trace)
(error "reject consumed paint markers"))
(lambda (_report) (push 'rollback trace))))
(advice-remove 'ebox-surface--layer-paint-contributions observer))
(should (= layer-calls 1))
(should (equal trace '(rollback publish)))
(should (eq state (ebox--buffer-render-state (current-buffer))))
(should (eq state (tp-surface-client-state surface)))
(should (= revision (tp-surface-revision surface)))
(should (= runtime-revision (plist-get state :runtime-revision)))
(should (eq ledger (plist-get state :surface-fragments)))
(should (equal-including-properties ledger-before ledger))
(should (eq ranges (plist-get state :surface-owned-ranges)))
(should (eq mounts (tp--surface-mounts surface)))
(should (eq mount-index (tp--surface-mount-index surface)))
(should (eq index (tp--surface-index surface)))
(should (equal mount-ids (mapcar #'tp--surface-mount-id mounts)))
(should (equal-including-properties before (buffer-string)))
(ebox-commit
(current-buffer)
(ebox-child-range-test--paint-owner-candidate
(current-buffer) "title-4" 'row-2 "#446688"))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should (= (1+ revision) (tp-surface-revision surface)))
(should (plist-get (tp-surface-report surface) :retained-mount-state))
(should (eq mounts (tp--surface-mounts surface)))
(should (eq mount-index (tp--surface-mount-index surface)))
(dolist (fragment (ebox-surface--materialized-fragment-ledger
(ebox--buffer-render-state (current-buffer))))
(should-not (plist-member fragment :old-paint-role-ids))))))
(ert-deftest ebox-child-range-retained-kind-replacement-allows-mixed-followups ()
"Later title and row paint edits remain local beside disjoint scrolling."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox--ensure-layout-snapshot-details
(current-buffer)
(plist-get (ebox--host-ref-node (current-buffer) 'detail) :node-id))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let* ((state (ebox--buffer-render-state (current-buffer)))
(surface ebox-surface--buffer-surface)
(mounts (tp--surface-mounts surface))
(mount-ids (mapcar #'tp--surface-mount-id mounts))
(mount-index (tp--surface-mount-index surface))
(index (tp--surface-index surface))
(ranges (plist-get state :surface-owned-ranges))
(scroll-id (car (plist-get state :scroll-region-ids)))
(scroll (gethash scroll-id ebox--scroll-global-state))
(raw (plist-get scroll :content-lines))
(rendered (plist-get scroll :rendered-content-lines))
(identities
(mapcar (lambda (ref)
(cons ref (plist-get (ebox--host-ref-node (current-buffer) ref)
:node-id)))
'(row-1 row-2 detail title status scroll))))
(should scroll-id)
(should (= (length (plist-get state :scroll-region-ids)) 1))
(dolist (selected '(2 1 2))
(let* ((candidate
(ebox-child-range-test--mixed-followup-candidate
(current-buffer) selected))
(root-renders 0)
(observer (lambda (&rest _arguments) (cl-incf root-renders)))
report)
(advice-add 'ebox-surface--render-candidate :before observer)
(unwind-protect
(setq report (ebox-commit (current-buffer) candidate))
(advice-remove 'ebox-surface--render-candidate observer))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(dolist (entry identities)
(should (= (cdr entry)
(plist-get (ebox--host-ref-node (current-buffer) (car entry))
:node-id))))
(ert-info ((format "selected=%S root-renders=%S report=%S"
selected root-renders report))
(should (eq (plist-get report :projection-kind) 'mixed-owner-reflow))
(should (zerop root-renders))
(should-not (plist-get report :tp-full-root))
(should (plist-get (tp-surface-report surface) :commit-batch))
(should (plist-get (tp-surface-report surface) :retained-mount-state))
(should (eq mounts (tp--surface-mounts surface)))
(should (equal mount-ids
(mapcar #'tp--surface-mount-id
(tp--surface-mounts surface))))
(should (eq mount-index (tp--surface-mount-index surface)))
(should (eq index (tp--surface-index surface)))
(should (eq ranges
(plist-get (ebox--buffer-render-state (current-buffer))
:surface-owned-ranges))))
(let ((next-scroll (gethash scroll-id ebox--scroll-global-state)))
(should (eq raw (plist-get next-scroll :content-lines)))
(should (eq rendered (plist-get next-scroll :rendered-content-lines)))))))))
(ert-deftest ebox-child-range-mixed-followup-publish-failure-restores-and-retries ()
"A failed public mixed commit restores the old generation before retry."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox--ensure-layout-snapshot-details
(current-buffer)
(plist-get (ebox--host-ref-node (current-buffer) 'detail) :node-id))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let* ((state (ebox--buffer-render-state (current-buffer)))
(surface ebox-surface--buffer-surface)
(revision (tp-surface-revision surface))
(previous-report (tp-surface-report surface))
(before (buffer-string))
(mounts (tp--surface-mounts surface))
(mount-ids (mapcar #'tp--surface-mount-id mounts))
(mount-index (tp--surface-mount-index surface))
(index (tp--surface-index surface))
(ranges (plist-get state :surface-owned-ranges))
(scroll-id (car (plist-get state :scroll-region-ids)))
(scroll (gethash scroll-id ebox--scroll-global-state))
trace)
(should-error
(ebox-commit
(current-buffer)
(ebox-child-range-test--mixed-followup-candidate (current-buffer) 2)
(lambda (_report) (push 'publish trace) (error "reject mixed publication"))
(lambda (_report) (push 'rollback trace))))
(should (equal trace '(rollback publish)))
(should (eq state (ebox--buffer-render-state (current-buffer))))
(should (eq state (tp-surface-client-state surface)))
(should (= revision (tp-surface-revision surface)))
(should (eq ranges (plist-get state :surface-owned-ranges)))
(should (eq mounts (tp--surface-mounts surface)))
(should (equal mount-ids (mapcar #'tp--surface-mount-id mounts)))
(should (eq mount-index (tp--surface-mount-index surface)))
(should (eq index (tp--surface-index surface)))
(should (eq scroll (gethash scroll-id ebox--scroll-global-state)))
(should (equal-including-properties before (buffer-string)))
(should (equal previous-report (tp-surface-report surface)))
(let ((report
(ebox-commit
(current-buffer)
(ebox-child-range-test--mixed-followup-candidate
(current-buffer) 2))))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should (= (1+ revision) (tp-surface-revision surface)))
(should (eq (plist-get report :projection-kind) 'mixed-owner-reflow))
(should-not (plist-get report :tp-full-root))
(should (plist-get (tp-surface-report surface) :commit-batch))
(should (plist-get (tp-surface-report surface) :retained-mount-state))
(should (eq mounts (tp--surface-mounts surface)))
(should (equal mount-ids (mapcar #'tp--surface-mount-id mounts)))
(should (eq mount-index (tp--surface-mount-index surface)))
(should (eq index (tp--surface-index surface)))
(should (eq (plist-get scroll :content-lines)
(plist-get (gethash scroll-id ebox--scroll-global-state)
:content-lines)))))))
(ert-deftest ebox-child-range-mixed-followup-removes-face-without-contribution ()
"A paint owner with no new face still publishes its baseline-only removal."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer)
(ebox-test-column :width '(200)
(ebox-test-column :bgcolor "#DDE7EF"
(ebox-test-text (propertize "title-1" 'face '(:weight bold))
:key 'title :source-identity 'title))
(ebox-test-box :key 'row-1 :source-identity 'row-1 :color "#123456"
(ebox-test-text (propertize "row-1" 'face '(:slant italic))))))
(let* ((surface ebox-surface--buffer-surface)
(mounts (tp--surface-mounts surface))
(mount-index (tp--surface-mount-index surface))
(candidate (ebox-candidate-begin (current-buffer)))
(observed nil) (contributions 'not-observed)
(observer
(lambda (_context _projection state _output &optional kind)
(when (eq kind 'mixed-owner-reflow)
(setq observed t
contributions (plist-get state :paint-property-contributions)))))
report)
(ebox-candidate-replace-host-ref
candidate 'title
(ebox-test-text (propertize "title-2" 'face '(:weight bold))
:key 'title :source-identity 'title))
(ebox-candidate-replace-host-ref
candidate 'row-1
(ebox-test-box :key 'row-1 :source-identity 'row-1
(ebox-test-text (propertize "row-1" 'face '(:slant italic)))))
(advice-add 'ebox-surface--projection-result :before observer)
(unwind-protect
(setq report (ebox-commit (current-buffer) candidate))
(advice-remove 'ebox-surface--projection-result observer))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should observed)
(should-not contributions)
(should (eq (plist-get report :projection-kind) 'mixed-owner-reflow))
(should (equal (get-text-property (string-match "row-1" (buffer-string))
'face (buffer-string))
'(:slant italic)))
(should (plist-get (tp-surface-report surface) :commit-batch))
(should (plist-get (tp-surface-report surface) :retained-mount-state))
(should (eq mounts (tp--surface-mounts surface)))
(should (eq mount-index (tp--surface-mount-index surface))))))
(ert-deftest ebox-child-range-mixed-followup-coordinate-change-keeps-fallback ()
"A longer title cannot claim the stable-coordinate mount-reuse proof."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let ((extent (buffer-size)))
(ebox-commit
(current-buffer)
(ebox-child-range-test--mixed-followup-candidate
(current-buffer) 2 "title-2 with a longer extent"))
(should-not (= extent (buffer-size))))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should-not (plist-get (tp-surface-report ebox-surface--buffer-surface)
:retained-mount-state))))
(ert-deftest ebox-child-range-mixed-followup-patch-layers-require-complete-coverage ()
"Ordered paint may cross adjacent patches, but cannot disappear into a gap."
(let* ((baseline (propertize "abcdefgh" 'face 'bold 'help-echo "base"))
(patches
(mapcar (lambda (range)
(list :old-start (car range) :old-end (cdr range)
:new-start (car range) :new-end (cdr range)
:replacement (substring baseline (car range) (cdr range))))
'((0 . 2) (2 . 4) (6 . 8))))
(before (copy-tree patches))
(layers '((:start 0 :end 4 :props (face italic))
(:start 1 :end 3 :props (face nil help-echo nil))
(:start 6 :end 8 :props (face (:foreground "red")))))
(mapped (ebox-surface--patch-property-contributions patches layers 8))
(batch (tp-commit-batch-create
:base-revision 1 :target-revision 2 :base-extent 8 :target-extent 8
:patches mapped))
(stored (tp-commit-batch-patches batch))
(actual (concat (plist-get (nth 0 stored) :replacement)
(plist-get (nth 1 stored) :replacement)
(substring baseline 4 6)
(plist-get (nth 2 stored) :replacement))))
(should (equal-including-properties
actual (tp--compose-relative-property-contributions baseline layers)))
(should (equal-including-properties before patches))
(should-not (eq (car patches) (car mapped)))
(should-not
(ebox-surface--patch-property-contributions
patches '((:start 1 :end 7 :props (face italic))) 8))
(dolist (invalid '((:start -1 :end 1 :props (face bold))
(:start 0 :end 9 :props (face bold))
(:start 0 :end 1 :props (face))))
(should-not
(ebox-surface--patch-property-contributions patches (list invalid) 8)))
(should
(ebox-surface--patch-property-contributions
patches '((:start 5 :end 5 :props (face bold))) 8))))
(ert-deftest ebox-child-range-mixed-followup-proof-misses-preserve-fallback ()
"Missing ownership or paint coverage returns to exact retained-content work."
(dolist (miss '(ownership coverage))
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let* ((function (if (eq miss 'ownership)
'ebox-surface--span-patch-output
'ebox-surface--patch-property-contributions))
observed
(observer
(lambda (original &rest arguments)
(setq observed t)
(when (eq miss 'ownership)
(prog1 (apply original arguments)
(cl-remf (nth 2 arguments) :span-patch-retained-owned-ranges))))))
(advice-add function :around observer)
(unwind-protect
(ebox-commit
(current-buffer)
(ebox-child-range-test--mixed-followup-candidate (current-buffer) 2))
(advice-remove function observer))
(should observed)
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should-not (plist-get (tp-surface-report ebox-surface--buffer-surface)
:retained-mount-state))))))
(ert-deftest ebox-child-range-mixed-followup-merger-errors-escape-proof-fallback ()
"Even a constructor-like merger error propagates once and preserves state."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let* ((surface ebox-surface--buffer-surface)
(state (ebox--buffer-render-state (current-buffer)))
(revision (tp-surface-revision surface))
(mounts (tp--surface-mounts surface))
(index (tp--surface-mount-index surface))
(before (buffer-string))
(merge-calls 0) (contributed-batches 0) contributed-face
(observer
(lambda (original &rest arguments)
(let* ((patches (mapcar #'copy-sequence (plist-get arguments :patches)))
(patch (cl-find-if
(lambda (entry) (plist-get entry :property-contributions))
patches)))
(when patch
;; Exception-boundary fixture: TP merges only over a present
;; baseline property. Keep Ebox's actual generated layers,
;; adding a baseline only to a detached constructor argument.
;; Inline row faces would change the fixture's geometry proof.
(let* ((layer (car (plist-get patch :property-contributions)))
(start (plist-get layer :start))
(replacement (copy-sequence (plist-get patch :replacement))))
(should (< start (plist-get layer :end)))
(setq contributed-face (plist-get (plist-get layer :props) 'face))
(should contributed-face)
(put-text-property start (1+ start) 'face '(:slant italic) replacement)
(plist-put patch :replacement replacement)
(setq arguments (plist-put (copy-sequence arguments) :patches patches))
(cl-incf contributed-batches)))
(apply original arguments)))))
(let ((tp--property-policies (copy-hash-table tp--property-policies))
(tp--property-policy-order (copy-sequence tp--property-policy-order)))
(tp-define-property-policy
(tp-text-property-id 'face)
:projector (tp-property-policy-projector
(tp-property-policy (tp-text-property-id 'face)))
:merge (lambda (old new)
(should (equal old '(:slant italic)))
(should (equal new contributed-face))
(cl-incf merge-calls)
(signal 'tp-surface-error '(:commit-patch merger-failure))))
(advice-add 'tp-commit-batch-create :around observer)
(unwind-protect
(let ((condition
(should-error
(ebox-commit
(current-buffer)
(ebox-child-range-test--mixed-followup-candidate
(current-buffer) 2))
:type 'tp-surface-error)))
(should (equal (seq-take condition 3)
'(tp-surface-error :commit-patch merger-failure))))
(advice-remove 'tp-commit-batch-create observer)))
(should (= contributed-batches 1))
(should (= merge-calls 1))
(should (= revision (tp-surface-revision surface)))
(should (eq state (tp-surface-client-state surface)))
(should (eq state (ebox--buffer-render-state (current-buffer))))
(should (eq mounts (tp--surface-mounts surface)))
(should (eq index (tp--surface-mount-index surface)))
(should (equal-including-properties before (buffer-string)))
(ebox-commit
(current-buffer)
(ebox-child-range-test--mixed-followup-candidate (current-buffer) 2))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should (plist-get (tp-surface-report surface) :retained-mount-state)))))
(ert-deftest ebox-child-range-mixed-followup-role-change-keeps-fallback ()
"Replacing text with a new box role cannot reuse the old mount topology."
(with-temp-buffer
(ebox-render-to-buffer
(current-buffer) (ebox-child-range-test--snapshot-replacement-root))
(ebox-commit
(current-buffer)
(ebox-child-range-test--replace-snapshot-detail (current-buffer) t))
(let ((candidate
(ebox-child-range-test--mixed-followup-candidate (current-buffer) 2)))
(ebox-candidate-replace-host-ref
candidate 'title
(ebox-test-box :key 'title :source-identity 'title
(ebox-test-text (propertize "title-2" 'face '(:weight bold)))))
(ebox-commit (current-buffer) candidate))
(ebox-child-range-test--assert-full-render-equivalent (current-buffer))
(should-not (plist-get (tp-surface-report ebox-surface--buffer-surface)
:retained-mount-state))))
(ert-deftest ebox-child-range-does-not-reuse-disappeared-key-positionally ()
"A new keyed item must not inherit a removed peer's runtime identity."
(let ((buffer (generate-new-buffer " *ebox-range-key-reentry*")))
(cl-labels
((rows (keys)
(mapcar (lambda (key)
(ebox-test-box :key key
(ebox-test-text (format "row-%s" key))))
keys))
(row-id (key)
(let* ((state (ebox--buffer-render-state buffer))
(resolved (ebox-incremental--range-ref-resolve
state 'items))
(segment (ebox-child-range--segment-at
(plist-get resolved :sequence)
(plist-get resolved :segment-index)))
(node (cl-find key
(append
(ebox-child-range--segment-payload segment)
nil)
:key (lambda (item)
(ebox-child-range-test--node-key
item
(plist-get state
:source-index))))))
(plist-get node :node-id))))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(apply #'ebox-test-child-range 'items (rows '(1 2 3 4)))))
(let ((initial-1 (row-id 1))
(initial-4 (row-id 4)))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input (rows '(1 4))))
(ebox-commit buffer candidate))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input (rows '(1 2 3 4))))
(ebox-commit buffer candidate))
(should (= initial-1 (row-id 1)))
(should (= initial-4 (row-id 4)))
(should-not (= initial-4 (row-id 2)))))
(when (buffer-live-p buffer) (kill-buffer buffer))))))
(ert-deftest ebox-child-range-sole-child-keeps-public-layout-parent ()
"Keep row/column material parents for one empty or populated Range."
(dolist (case '((ebox-test-row row) (ebox-test-column column)))
(dolist (items (list nil (list (ebox-test-box :key 'one (ebox-test-text "1")))))
(let* ((range (apply #'ebox-test-child-range 'items items))
(parent-input (funcall (car case) range))
(parent (ebox-test-root parent-input)))
(should-not (ebox-child-range--descriptor-p parent))
(should (ebox-box-node-p parent))
(should (eq (ebox-layout-config-kind (ebox-box-node-layout parent))
(cadr case)))
(should (equal (ebox-box-node-children parent)
(mapcar #'ebox-test-root items)))
(should (equal (ebox-box-node-range-anchors parent)
(list (list :ref 'items :before 0
:after (length items)))))
(should (stringp (ebox-render parent-input)))))))
(ert-deftest ebox-child-range-typed-box-preserves-transparent-range ()
"Typed Box should retain Range identity outside its visual child model."
(let* ((before (ebox-test-text "before" :key 'before))
(first (ebox-test-text "A" :key 'first))
(second (ebox-test-text "B" :key 'second))
(after (ebox-test-text "after" :key 'after))
(range (ebox-test-child-range 'items first second))
(range-items (ebox-child-range--descriptor-items range))
(box-input (ebox-test-column before range after))
(box (ebox-test-root box-input))
(buffer (generate-new-buffer " *ebox-typed-range*")))
(unwind-protect
(progn
(should (equal (ebox-box-node-children box)
(mapcar #'ebox-test-root
(list before first second after))))
(cl-mapc (lambda (actual expected)
(should (eq actual expected)))
(ebox-box-node-children box)
(mapcar #'ebox-test-root
(list before (car range-items)
(cadr range-items) after)))
(should (equal (ebox-box-node-range-anchors box)
'((:ref items :before 1 :after 3))))
(let* ((empty (ebox-test-child-range 'empty))
(empty-input (ebox-test-column before empty after))
(empty-box (ebox-test-root empty-input)))
(should (equal (ebox-box-node-children empty-box)
(mapcar #'ebox-test-root (list before after))))
(should (equal (ebox-box-node-range-anchors empty-box)
'((:ref empty :before 1 :after 1)))))
(should
(equal
(mapcar (lambda (line)
(string-trim-right (substring-no-properties line)))
(ebox-string-lines (ebox-render box-input)))
'("before" "A" "B" "after")))
(ebox-render-to-buffer buffer box-input)
(let* ((runtime-root (ebox--buffer-root-node buffer))
(snapshot
(ebox-tree-runtime-identity-snapshot runtime-root)))
(should (= (plist-get snapshot :node-count) 5))
(should (= (length (plist-get
(plist-get snapshot :root) :children))
4)))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-text "C" :key 'replacement))))
(ebox-commit buffer candidate))
(should
(equal
(with-current-buffer buffer
(mapcar (lambda (line)
(string-trim-right
(substring-no-properties line)))
(ebox-string-lines (buffer-string))))
'("before" "C" "after")))
(let ((before-style-state (ebox--buffer-render-state buffer))
(before-style-text
(with-current-buffer buffer (buffer-string)))
(candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-text "B" :color "red"))))
(cl-letf (((symbol-function 'accept-change-group)
(lambda (_group) (error "reject styled Range"))))
(should-error (ebox-commit buffer candidate) :type 'error))
(should (eq before-style-state
(ebox--buffer-render-state buffer)))
(should (equal before-style-text
(with-current-buffer buffer (buffer-string)))))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-text "B" :color "red"))))
(ebox-commit buffer candidate))
(let* ((state (ebox--buffer-render-state buffer))
(root (plist-get state :root-node))
(rendered (with-current-buffer buffer (buffer-string)))
(position (let ((case-fold-search nil))
(string-match "B" rendered)))
(face (and position
(get-text-property position 'face rendered))))
(should (zerop (ebox-tree-author-style-count root)))
(should-not (plist-get state :cascade-required-p))
(should
(or (and (listp face)
(keywordp (car face))
(equal (plist-get face :foreground) "red"))
(cl-some (lambda (entry)
(and (listp entry)
(equal (plist-get entry :foreground) "red")))
face))))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-text "D" :key 'unstyled))))
(ebox-commit buffer candidate))
(let* ((state (ebox--buffer-render-state buffer))
(root (plist-get state :root-node))
(rendered (with-current-buffer buffer (buffer-string)))
(position (string-match "D" rendered))
(face (and position
(get-text-property position 'face rendered))))
(should (zerop (ebox-tree-author-style-count root)))
(should-not
(or (and (listp face)
(keywordp (car face))
(equal (plist-get face :foreground) "red"))
(cl-some (lambda (entry)
(and (listp entry)
(equal (plist-get entry :foreground) "red")))
face))))
(let ((before-invalid
(with-current-buffer buffer (buffer-string)))
(candidate (ebox-candidate-begin buffer)))
(should-error
(ebox-candidate-replace-range-ref
candidate 'items
(list (list :ebox-type 'box :content "legacy")))
:type 'error)
(should (equal before-invalid
(with-current-buffer buffer (buffer-string))))))
(when (buffer-live-p buffer)
(kill-buffer buffer)))))
(ert-deftest ebox-child-range-typed-render-reuses-material-child-list ()
"Typed Range rendering should not repeatedly flatten its child sequence."
(let* ((items
(cl-loop for index below 100
collect (ebox-test-text
(number-to-string index) :key index)))
(range (apply #'ebox-test-child-range 'items items))
(box-input (ebox-test-column range))
(box (ebox-test-root box-input))
(original (symbol-function 'ebox-child-range--flatten))
(calls 0))
(cl-letf (((symbol-function 'ebox-child-range--flatten)
(lambda (sequence)
(cl-incf calls)
(funcall original sequence))))
(ebox-render box-input))
(should (zerop calls))
(let* ((replacement-input
(ebox-test-text "replacement" :key 'new))
(replacement (ebox-test-root replacement-input))
(source-index
(ebox-test-source-index
(ebox-test-forest-input box-input replacement-input)))
(updated
(car
(ebox-child-range--replace
(plist-get box :ebox-child-sequence)
'items (list replacement)
(lambda (node)
(ebox-child-range-test--node-key node source-index)))))
(candidate (copy-sequence box)))
(ebox-tree--put-child-sequence candidate updated)
(setq calls 0)
(cl-letf (((symbol-function 'ebox-child-range--flatten)
(lambda (sequence)
(cl-incf calls)
(funcall original sequence))))
(ebox-tree-subject-index candidate source-index)
(ebox-tree-layout-children candidate))
(should (= calls 1)))))
(ert-deftest ebox-child-range-empty-owner-falls-back-atomically ()
"Publish empty sole Range through full surface fallback and rollback safely."
(let ((buffer (generate-new-buffer " *ebox-empty-range-owner*")))
(unwind-protect
(progn
(ebox-render-to-buffer buffer
(ebox-test-column (ebox-test-child-range 'items)))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'one (ebox-test-text "1")))))
(cl-letf (((symbol-function 'accept-change-group)
(lambda (&rest _) (error "injected empty accept"))))
(should-error (ebox-commit buffer candidate) :type 'error)))
(should (equal "" (with-current-buffer buffer (buffer-string))))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'one (ebox-test-text "1")))))
(let ((report (ebox-commit buffer candidate)))
(should (plist-get report :empty-range-owner-fallback))))
(should (string-match-p "1" (with-current-buffer buffer
(buffer-string))))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items (ebox-test-forest-input))
(ebox-commit buffer candidate))
(should (equal "" (with-current-buffer buffer (buffer-string)))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-candidate-derivation-never-flattens-parent ()
"Range logical-root and local-index derivation never flatten parent payloads."
(let* ((buffer (generate-new-buffer " *ebox-range-no-flatten*"))
(static
(cl-loop for index below 100
collect (ebox-test-box :key (format "static-%d" index)
(ebox-test-text (number-to-string index)))))
(root (apply #'ebox-test-column
(append static
(list (ebox-test-child-range
'items
(ebox-test-box :key 'old (ebox-test-text "old")))))))
candidate logical trace deltas)
(unwind-protect
(progn
(ebox-render-to-buffer buffer root)
(setq candidate (ebox-candidate-begin buffer))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'new (ebox-test-text "new")))))
(setq trace (make-hash-table :test 'equal))
(cl-letf (((symbol-function 'ebox-child-range--flatten)
(lambda (&rest _) (error "candidate flattened Range"))))
(let ((ebox-incremental--candidate-path-copy-trace trace)
(ebox-incremental--candidate-range-index-deltas nil)
(ebox-incremental--candidate-incoming-source-indexes
(ebox-incremental--candidate-source-input-map candidate)))
(setq logical
(ebox-incremental--candidate-logical-root candidate nil)
deltas ebox-incremental--candidate-range-index-deltas)
(ebox-incremental--candidate-local-index-delta
(ebox-candidate--base-state candidate) logical trace deltas)))
(let ((metrics (car (ebox-candidate--range-metrics candidate))))
(should (= (plist-get metrics :segment-visits) 3))
(should (= (plist-get metrics :unaffected-payload-visits) 0))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-adjacent-key-move-is-two-phase ()
"A key can move between adjacent Ranges in one logical candidate."
(let ((buffer (generate-new-buffer " *ebox-range-key-move*")))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-child-range
'left (ebox-test-box :key 'move (ebox-test-text "L")))
(ebox-test-child-range
'right (ebox-test-box :key 'stay (ebox-test-text "R")))))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'left (ebox-test-forest-input))
(ebox-candidate-replace-range-ref
candidate 'right
(ebox-child-range-test--input
(list (ebox-test-box :key 'move (ebox-test-text "M"))
(ebox-test-box :key 'stay (ebox-test-text "R")))))
(ebox-commit buffer candidate))
(should (string-match-p "M" (with-current-buffer buffer
(buffer-string)))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-public-gate-a-and-prepared-index ()
"Public Range commits retain logarithmic metrics and a prepared local index."
(dolist (static-count '(10 100 500))
(let* ((buffer (generate-new-buffer " *ebox-range-public-gate*"))
(root
(apply #'ebox-test-column
(append
(cl-loop for index below static-count
collect (ebox-test-box :key (format "static-%d" index)
(ebox-test-text "s")))
(list (ebox-test-child-range
'items (ebox-test-box :key 'old (ebox-test-text "o"))))))))
(unwind-protect
(progn
(ebox-render-to-buffer buffer root)
(let* ((old-state (ebox--buffer-render-state buffer))
(old-table (plist-get old-state :range-ref-table))
(surface (with-current-buffer
buffer ebox-surface--buffer-surface))
(revision (tp-surface-revision surface))
(candidate (ebox-candidate-begin buffer))
report)
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'new-a (ebox-test-text "a"))
(ebox-test-box :key 'new-b (ebox-test-text "b")))))
(cl-letf (((symbol-function 'ebox--runtime-index)
(lambda (&rest _) (error "unexpected full index"))))
(setq report (ebox-commit buffer candidate)))
(let* ((parent-metrics
(car (plist-get (plist-get report :range-metrics)
:parents)))
(bound (if (= static-count 10) 2 3)))
(should (<= (plist-get parent-metrics :segment-visits) bound))
(should (<= (plist-get parent-metrics :segment-copies) bound))
(should (= (plist-get parent-metrics
:unaffected-payload-visits) 0))
(should (= (plist-get parent-metrics :new-payload-visits) 2)))
(should (= (tp-surface-revision surface) (1+ revision)))
(let* ((state (ebox--buffer-render-state buffer))
(resolved
(ebox-incremental--range-ref-resolve state 'items))
(segment
(ebox-child-range--segment-at
(plist-get resolved :sequence)
(plist-get resolved :segment-index))))
(should (eq old-table (plist-get state :range-ref-table)))
(dotimes (offset
(length (ebox-child-range--segment-payload segment)))
(let* ((node (aref
(ebox-child-range--segment-payload segment)
offset))
(node-id (plist-get node :node-id))
(object (gethash
node-id
(plist-get state
:surface-node-object-table))))
(should (eq node (ebox-runtime-index-get node-id
(plist-get state :node-table))))
(should object)
(should (eq object (plist-get node :surface-object))))))))
(when (buffer-live-p buffer) (kill-buffer buffer))))))
(ert-deftest ebox-child-range-candidate-introduced-ref-is-next-turn-only ()
"A node replacement may introduce a Range address only for the next turn."
(let ((buffer (generate-new-buffer " *ebox-range-introduced*")))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column (ebox-test-box :key 'a :source-identity 'a (ebox-test-text "a"))
(ebox-test-box :key 'b (ebox-test-text "b"))))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-host-ref
candidate 'a
(ebox-test-column
(ebox-test-box :key 'a :source-identity 'a (ebox-test-text "a"))
(ebox-test-child-range 'introduced)))
(should-error
(ebox-candidate-replace-range-ref
candidate 'introduced (ebox-test-forest-input)))
(ebox-commit buffer candidate))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'introduced
(ebox-child-range-test--input
(list (ebox-test-box :key 'later (ebox-test-text "later")))))
(ebox-commit buffer candidate))
(should (string-match-p "later" (with-current-buffer buffer
(buffer-string)))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-coalescing-is-order-independent ()
"Host ancestors win Range updates while Ranges win descendant Host updates."
(dolist (order '(host-first range-first))
(let ((buffer (generate-new-buffer " *ebox-range-coalesce*")))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-column
:source-identity 'parent
(ebox-test-box :key 'static (ebox-test-text "s"))
(ebox-test-child-range
'items (ebox-test-box :key 'child :source-identity 'child
(ebox-test-text "old"))))
(ebox-test-box :key 'peer (ebox-test-text "peer"))))
(let ((candidate (ebox-candidate-begin buffer)))
(dolist (operation (if (eq order 'host-first)
'(host range) '(range host)))
(pcase operation
('host
(ebox-candidate-replace-host-ref
candidate 'parent
(ebox-test-box :key 'parent-new (ebox-test-text "HOST-WINS"))))
('range
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'range-new
(ebox-test-text "range-loses"))))))))
(ebox-commit buffer candidate))
(should (string-match-p "HOST-WINS"
(with-current-buffer buffer
(buffer-string)))))
(when (buffer-live-p buffer) (kill-buffer buffer))))))
(ert-deftest ebox-child-range-consecutive-host-updates-keep-point-location ()
"Retained Host identity preserves its sequence point location across turns."
(let ((buffer (generate-new-buffer " *ebox-range-host-location*")) node-id)
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-box :key 'static (ebox-test-text "s"))
(ebox-test-child-range
'items (ebox-test-box :key 'child :source-identity 'child (ebox-test-text "0")))))
(dotimes (turn 2)
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-host-ref
candidate 'child
(ebox-test-box :key 'child :source-identity 'child
(ebox-test-text (number-to-string (1+ turn)))))
(ebox-commit buffer candidate))
(let* ((state (ebox--buffer-render-state buffer))
(current-id
(gethash 'child
(ebox-child-range-test--host-ref-table state)))
(node
(ebox-runtime-index-get
current-id (plist-get state :node-table))))
(when node-id (should (equal node-id current-id)))
(setq node-id current-id)
(should (plist-get node :ebox-sequence-location))))
(should (string-match-p "2" (with-current-buffer buffer
(buffer-string)))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-three-way-coalescing-keeps-host-descendant ()
"A losing Range cannot absorb a descendant Host under its winning ancestor."
(let ((buffer (generate-new-buffer " *ebox-range-three-way*")))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-column
:source-identity 'parent
(ebox-test-box :key 'static (ebox-test-text "s"))
(ebox-test-child-range
'items (ebox-test-box :key 'child :source-identity 'child
(ebox-test-text "old"))))
(ebox-test-box :key 'peer (ebox-test-text "peer"))))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-host-ref
candidate 'parent
(ebox-test-column
:source-identity 'parent
(ebox-test-box :key 'static (ebox-test-text "s2"))
(ebox-test-child-range
'items (ebox-test-box :key 'child :source-identity 'child
(ebox-test-text "ancestor")))))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'range (ebox-test-text "RANGE-LOSES")))))
(ebox-candidate-replace-host-ref
candidate 'child
(ebox-test-box :key 'child :source-identity 'child
(ebox-test-text "DESCENDANT-WINS")))
(ebox-commit buffer candidate))
(let ((text (with-current-buffer buffer (buffer-string))))
(should (string-match-p "DESCENDANT-WINS" text))
(should-not (string-match-p "RANGE-LOSES" text))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-large-payload-never-promotes-to-full-index ()
"M=64 remains an affected-payload local delta under 500 static segments."
(let* ((buffer (generate-new-buffer " *ebox-range-large-payload*"))
(root
(apply #'ebox-test-column
(append
(cl-loop for index below 500
collect (ebox-test-box :key (format "static-%d" index)
(ebox-test-text "s")))
(list (ebox-test-child-range 'items)))))
report)
(unwind-protect
(progn
(ebox-render-to-buffer buffer root)
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(cl-loop for index below 64
collect (ebox-test-box :key (format "new-%d" index)
(ebox-test-text "n")))))
(cl-letf (((symbol-function
'ebox-incremental--candidate-full-index-preparation)
(lambda (&rest _) (error "unexpected full preparation")))
((symbol-function 'ebox--runtime-index)
(lambda (&rest _) (error "unexpected full index"))))
(setq report (ebox-commit buffer candidate))))
(let ((metrics (car (plist-get (plist-get report :range-metrics)
:parents))))
(should (= (plist-get metrics :new-payload-visits) 64))
(should (<= (plist-get metrics :segment-visits) 3))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-wins-descendant-host-in-both-orders ()
"A surviving Range absorbs a descendant Host replacement independent of order."
(dolist (order '(host-first range-first))
(let ((buffer (generate-new-buffer " *ebox-range-wins-host*")))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-box :key 'static (ebox-test-text "s"))
(ebox-test-child-range
'items (ebox-test-box :key 'child :source-identity 'child
(ebox-test-text "old")))))
(let ((candidate (ebox-candidate-begin buffer)))
(dolist (operation (if (eq order 'host-first)
'(host range) '(range host)))
(if (eq operation 'host)
(ebox-candidate-replace-host-ref
candidate 'child
(ebox-test-box :key 'child :source-identity 'child
(ebox-test-text "HOST-LOSES")))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'range
(ebox-test-text "RANGE-WINS")))))))
(ebox-commit buffer candidate))
(let ((text (with-current-buffer buffer (buffer-string))))
(should (string-match-p "RANGE-WINS" text))
(should-not (string-match-p "HOST-LOSES" text))))
(when (buffer-live-p buffer) (kill-buffer buffer))))))
(ert-deftest ebox-child-range-overlay-prunes-descendant-node-anchors ()
"Ancestor/descendant node anchors install nested Range refs exactly once."
(let ((buffer (generate-new-buffer " *ebox-range-overlay-prune*")))
(unwind-protect
(cl-labels
((child (static-text range-ref range-key range-text)
(let ((node
(ebox-test-column
:key 'child :source-identity 'child
(ebox-test-box :key 'child-static (ebox-test-text static-text))
(if range-key
(ebox-test-child-range
range-ref
(ebox-test-box :key range-key (ebox-test-text range-text)))
(ebox-test-child-range range-ref)))))
node))
(ancestor (child-node peer-text)
(let ((node
(ebox-test-column
:key 'ancestor :source-identity 'ancestor
child-node
(ebox-test-box :key 'ancestor-peer (ebox-test-text peer-text)))))
node)))
(ebox-render-to-buffer
buffer
(ebox-test-column
(ancestor (child "s" 'old-ref nil nil) "p")
(ebox-test-box :key 'root-peer (ebox-test-text "r"))))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-host-ref
candidate 'ancestor
(ancestor (child "s2" 'new-ref 'ancestor-range "a") "p2"))
(ebox-candidate-replace-host-ref
candidate 'child
(child "s3" 'new-ref 'descendant-range "d"))
(ebox-commit buffer candidate))
(let* ((state (ebox--buffer-render-state buffer))
(table (plist-get state :range-ref-table))
(record (gethash 'new-ref table))
(child-id
(gethash 'child
(ebox-child-range-test--host-ref-table state))))
(should-not (gethash 'old-ref table))
(should record)
(should (= (hash-table-count table) 1))
(should (equal (plist-get record :parent-node-id) child-id))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-disjoint-host-and-range-publish-once ()
"Disjoint Host and Range changes share one scoped TP publication."
(let ((buffer (generate-new-buffer " *ebox-range-disjoint*")) (callbacks 0))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-box :key 'host :source-identity 'host (ebox-test-text "old-host"))
(ebox-test-child-range
'items (ebox-test-box :key 'old-range (ebox-test-text "old-range")))))
(let* ((surface (with-current-buffer buffer ebox-surface--buffer-surface))
(revision (tp-surface-revision surface))
(candidate (ebox-candidate-begin buffer))
report)
(ebox-candidate-replace-host-ref
candidate 'host
(ebox-test-box :key 'host :source-identity 'host (ebox-test-text "new-host")))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'new-range (ebox-test-text "new-range")))))
(setq report
(ebox-commit buffer candidate
(lambda (_report) (cl-incf callbacks))))
(should (= callbacks 1))
(should (= (tp-surface-revision surface) (1+ revision)))
(should (= (plist-get (plist-get report :range-metrics)
:applied-count) 1))
(should-not (plist-get report :tp-scope-fallback))
(let ((text (with-current-buffer buffer (buffer-string))))
(should (string-match-p "new-host" text))
(should (string-match-p "new-range" text)))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-final-accept-failure-restores-exact-generation ()
"A Range commit rejected by final accept restores all old identities."
(let ((buffer (generate-new-buffer " *ebox-range-final-rollback*")) trace)
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-box :key 'static (ebox-test-text "s"))
(ebox-test-child-range
'items (ebox-test-box :key 'old :source-identity 'old (ebox-test-text "old")))))
(let* ((old-state (ebox--buffer-render-state buffer))
(old-root (plist-get old-state :root-node))
(old-table (plist-get old-state :range-ref-table))
(old-id
(gethash 'old
(ebox-child-range-test--host-ref-table old-state)))
(old-buffer (with-current-buffer buffer (buffer-string)))
(candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'new :source-identity 'new
(ebox-test-text "new"))))
nil t)
(cl-letf (((symbol-function 'accept-change-group)
(lambda (_group) (error "reject final accept"))))
(should-error
(ebox-commit
buffer candidate
(lambda (_report) (push 'publish trace))
(lambda (_report) (push 'rollback trace)))))
(should (equal trace '(rollback publish)))
(should (eq (ebox--buffer-render-state buffer) old-state))
(should (eq (plist-get old-state :root-node) old-root))
(should (eq (plist-get old-state :range-ref-table) old-table))
(should (= (gethash
'old (ebox-child-range-test--host-ref-table old-state))
old-id))
(should (equal (with-current-buffer buffer (buffer-string))
old-buffer)))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'new (ebox-test-text "new")))))
(ebox-commit buffer candidate)))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest ebox-child-range-framework-failure-rolls-back-and-retries ()
"A failed framework publish restores the exact old Range generation."
(let ((buffer (generate-new-buffer " *ebox-range-rollback*")))
(unwind-protect
(progn
(ebox-render-to-buffer
buffer
(ebox-test-column
(ebox-test-box :key 'static (ebox-test-text "s"))
(ebox-test-child-range
'items (ebox-test-box :key 'old (ebox-test-text "old")))))
(let* ((old-state (ebox--buffer-render-state buffer))
(old-root (plist-get old-state :root-node))
(old-range-table (plist-get old-state :range-ref-table))
(old-buffer (with-current-buffer buffer (buffer-string)))
(candidate (ebox-candidate-begin buffer))
trace)
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'new (ebox-test-text "new")))))
(should-error
(ebox-commit
buffer candidate
(lambda (_report) (push 'publish trace) (error "reject"))
(lambda (_report) (push 'rollback trace))))
(should (equal trace '(rollback publish)))
(should (eq (ebox--buffer-render-state buffer) old-state))
(should (eq (plist-get old-state :root-node) old-root))
(should (eq (plist-get old-state :range-ref-table) old-range-table))
(should (equal (with-current-buffer buffer (buffer-string))
old-buffer)))
(let ((candidate (ebox-candidate-begin buffer)))
(ebox-candidate-replace-range-ref
candidate 'items
(ebox-child-range-test--input
(list (ebox-test-box :key 'new (ebox-test-text "new")))))
(ebox-commit buffer candidate))
(should (string-match-p "new" (with-current-buffer buffer
(buffer-string)))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(provide 'ebox-child-range-tests)
;;; ebox-child-range-tests.el ends here
Reference in New Issue View Git Blame Copy Permalink