fix: render allocated owners in their retained slots
This commit is contained in:
Kinneyzhang
parent
2b7ffcb0af
commit
1204746e41
@ -8217,15 +8217,17 @@ because it could address a run whose topology the closure just replaced."
|
||||
owner))
|
||||
|
||||
(defun ebox-incremental--fixed-basis-flex-local-op
|
||||
(buffer render-dirty-set)
|
||||
(buffer render-dirty-set &optional allow-single-p)
|
||||
"Return one tentative Flex-item op for related geometry RENDER-DIRTY-SET.
|
||||
|
||||
Multiple descendant content changes can share a fixed-basis, zero-minimum Flex
|
||||
item without changing its main-axis allocation. This planner only selects the
|
||||
shared owner; grouped proof verifies topology and the retained ancestor slot,
|
||||
then Surface performs the one actual candidate render and complete footprint,
|
||||
role, overflow, and outside-complement validation."
|
||||
(when (and (> (length render-dirty-set) 1)
|
||||
role, overflow, and outside-complement validation. ALLOW-SINGLE-P also selects
|
||||
an owner for one descendant after its narrower projection proof has failed."
|
||||
(when (and (or (> (length render-dirty-set) 1)
|
||||
(and allow-single-p (= (length render-dirty-set) 1)))
|
||||
(cl-every
|
||||
(lambda (entry)
|
||||
(and (eq (plist-get entry :dirty-kind) 'geometry)
|
||||
@ -9615,7 +9617,17 @@ or a retained content-slot certificate. The surface still renders the whole
|
||||
candidate owner into its published slot and verifies exact footprint, overflow,
|
||||
role, and outside-complement compatibility before publication."
|
||||
(when (and (= (length owner-plan) 1)
|
||||
(> (length (plist-get prepared :dirty-set)) 1))
|
||||
(or (> (length (plist-get prepared :dirty-set)) 1)
|
||||
;; A single leaf may need its allocator's filler to change.
|
||||
;; Only a proper, content-independent Flex ancestor closes
|
||||
;; that envelope; the ordinary leaf proof stays stricter.
|
||||
(and (= (length (plist-get prepared :dirty-set)) 1)
|
||||
(not (equal
|
||||
(plist-get (car owner-plan) :owner-id)
|
||||
(plist-get (car (plist-get prepared :dirty-set))
|
||||
:node-id)))
|
||||
(ebox--flex-item-fixed-basis-content-allocation-stable-p
|
||||
buffer (plist-get (car owner-plan) :owner-id)))))
|
||||
(let* ((operation (car owner-plan))
|
||||
(owner-id (plist-get operation :owner-id))
|
||||
(dirty-set (plist-get prepared :dirty-set))
|
||||
@ -9767,6 +9779,7 @@ role, and outside-complement compatibility before publication."
|
||||
dirty-set))
|
||||
:variable-content-max-width allocated-width
|
||||
:role-owned-lines-p t
|
||||
:retain-external-owner-suffix-p t
|
||||
:ancestor-slot-signature ancestor-slot-signature
|
||||
:layout-snapshot-detail-generation
|
||||
(plist-get old-state
|
||||
@ -9863,7 +9876,16 @@ role, and outside-complement compatibility before publication."
|
||||
(ebox-incremental--grouped-owner-span-proof
|
||||
buffer old-state prepared candidate-state owner-plan)
|
||||
(ebox-incremental--range-span-proof
|
||||
buffer old-state prepared candidate-state owner-plan))))
|
||||
buffer old-state prepared candidate-state owner-plan)
|
||||
;; Preserve a successful narrow proof. Only its miss
|
||||
;; justifies trying the complete allocated Flex owner.
|
||||
(when-let* ((operation
|
||||
(and (= (length (plist-get prepared :dirty-set)) 1)
|
||||
(ebox-incremental--fixed-basis-flex-local-op
|
||||
buffer (plist-get prepared :dirty-set) t))))
|
||||
(ebox-incremental--grouped-owner-span-proof
|
||||
buffer old-state prepared candidate-state
|
||||
(list operation))))))
|
||||
(unless (plist-get proof :owner-ids)
|
||||
(setq proof
|
||||
(plist-put proof :owner-ids
|
||||
|
||||
242
ebox-surface.el
242
ebox-surface.el
@ -3630,9 +3630,152 @@ Compare resolved paint and surface properties, preserving opaque identities."
|
||||
new '(bt bb) t)))))))))
|
||||
same-p))
|
||||
|
||||
(defun ebox-surface--owner-slot-render-node
|
||||
(buffer state owner-id snapshot allocated-width variable-content-p
|
||||
role-owned-lines-p changed-keys)
|
||||
"Return STATE's OWNER-ID rendered in its proven slot, or at natural size."
|
||||
(let* ((node (gethash owner-id (plist-get state :node-table)))
|
||||
(parent-id (gethash owner-id (plist-get state :parent-table)))
|
||||
(parent (and parent-id (gethash parent-id (plist-get state :node-table)))))
|
||||
(cond
|
||||
((and role-owned-lines-p parent
|
||||
(eq (ebox-tree-display-inner parent) 'flex))
|
||||
(when (fboundp 'ebox--flex-item-slot-sized-node)
|
||||
(let ((ebox-incremental--buffer-render-state-override (cons buffer state)))
|
||||
(ebox--flex-item-slot-sized-node buffer owner-id snapshot changed-keys))))
|
||||
((and node role-owned-lines-p)
|
||||
;; The ancestor certificate proves a stable allocation, but its
|
||||
;; capacity can include chrome outside this owner's published spans.
|
||||
;; Recreate this owner's margin-box extent with the normal box model.
|
||||
(when-let* ((width (plist-get
|
||||
(plist-get snapshot :external-footprint-signature)
|
||||
:max-line-pixel-width))
|
||||
((numberp width)))
|
||||
(ebox--flex-copy-node-for-size node 'row width nil nil)))
|
||||
((and node allocated-width variable-content-p)
|
||||
(plist-put (copy-sequence node) :width allocated-width))
|
||||
(t node))))
|
||||
|
||||
(defun ebox-surface--retained-slot-owner-text
|
||||
(buffer previous-state spans old-lines new-lines local old-values new-values)
|
||||
"Transport unchanged published properties across proven slot property runs.
|
||||
Direct content runs may change length. Only renderer-owned blank fillers may
|
||||
change their display width. Every other local property and the order of runs
|
||||
must match, and a resized run cannot hide an external property boundary.
|
||||
Return nil on a proof miss. The caller still validates the final footprint."
|
||||
(catch 'slot-property-miss
|
||||
(unless (= (length spans) (length old-lines) (length new-lines))
|
||||
(throw 'slot-property-miss nil))
|
||||
(let ((fragments (ebox-surface--materialized-fragment-ledger previous-state))
|
||||
(origin (with-current-buffer buffer (point-min)))
|
||||
result)
|
||||
(cl-labels
|
||||
((baseline-for
|
||||
(start end published-properties)
|
||||
(while (and fragments (<= (plist-get (car fragments) :end) start))
|
||||
(setq fragments (cdr fragments)))
|
||||
(let ((remaining fragments) (position start) seen baseline)
|
||||
(while (< position end)
|
||||
(let ((fragment (car remaining)))
|
||||
(unless (and fragment
|
||||
(<= (plist-get fragment :start) position)
|
||||
(< position (plist-get fragment :end)))
|
||||
(throw 'slot-property-miss nil))
|
||||
(let ((value
|
||||
(cond
|
||||
((plist-get fragment :face-baseline-known-p)
|
||||
(plist-get fragment :face-baseline))
|
||||
((null (ebox-surface--face-contributions
|
||||
previous-state (plist-get fragment :paint-role-ids)))
|
||||
(plist-get published-properties 'face))
|
||||
(t (throw 'slot-property-miss nil)))))
|
||||
(when (and seen
|
||||
(not (ebox-surface--retained-property-value-equal-p
|
||||
baseline value)))
|
||||
(throw 'slot-property-miss nil))
|
||||
(setq baseline value seen t))
|
||||
(setq position (min end (plist-get fragment :end))
|
||||
remaining (cdr remaining))))
|
||||
baseline))
|
||||
(pixel-filler-p
|
||||
(line start end properties values)
|
||||
(let ((display (plist-get properties 'display)))
|
||||
(and (= (- end start) 1) (= (aref line start) ?\s)
|
||||
(null (plist-get properties 'ebox-content))
|
||||
(cl-some (lambda (id) (gethash id local))
|
||||
(plist-get properties 'ebox-content-owners))
|
||||
(ebox--render-owned-text-value-p 'display display values)
|
||||
(pcase display
|
||||
(`(space :width (,width)) (and (numberp width) (>= width 0))))))))
|
||||
(with-current-buffer buffer
|
||||
(cl-loop
|
||||
for span in spans for old in old-lines for new in new-lines
|
||||
do
|
||||
(let* ((published (buffer-substring (car span) (cdr span)))
|
||||
(old-length (length old)) (new-length (length new))
|
||||
(old-position 0) (new-position 0)
|
||||
(line (substring-no-properties new)))
|
||||
(unless (equal (substring-no-properties old)
|
||||
(substring-no-properties published))
|
||||
(throw 'slot-property-miss nil))
|
||||
(while (and (< old-position old-length) (< new-position new-length))
|
||||
(let* ((old-end (next-property-change old-position old old-length))
|
||||
(new-end (next-property-change new-position new new-length))
|
||||
(old-props (text-properties-at old-position old))
|
||||
(new-props (text-properties-at new-position new))
|
||||
(published-props (text-properties-at old-position published))
|
||||
(old-display (plist-get old-props 'display))
|
||||
(new-display (plist-get new-props 'display))
|
||||
(display-changed-p
|
||||
(not (ebox-surface--retained-property-value-equal-p
|
||||
old-display new-display))))
|
||||
(unless (= old-end (next-property-change old-position published old-end))
|
||||
(throw 'slot-property-miss nil))
|
||||
(when display-changed-p
|
||||
(unless (and (pixel-filler-p old old-position old-end old-props old-values)
|
||||
(pixel-filler-p new new-position new-end new-props new-values)
|
||||
(ebox-surface--retained-property-value-equal-p
|
||||
old-display (plist-get published-props 'display)))
|
||||
(throw 'slot-property-miss nil))
|
||||
(setq old-props (copy-sequence old-props)
|
||||
new-props (copy-sequence new-props))
|
||||
(cl-remf old-props 'display)
|
||||
(cl-remf new-props 'display))
|
||||
(unless (and
|
||||
(ebox-surface--retained-property-value-equal-p old-props new-props)
|
||||
(or (equal (substring-no-properties old old-position old-end)
|
||||
(substring-no-properties new new-position new-end))
|
||||
(and (null old-display) (null new-display)
|
||||
(gethash (plist-get old-props 'ebox-content) local)
|
||||
(not (string-match-p "[\n\r]"
|
||||
(substring old old-position old-end)))
|
||||
(not (string-match-p "[\n\r]"
|
||||
(substring new new-position new-end))))))
|
||||
(throw 'slot-property-miss nil))
|
||||
(set-text-properties new-position new-end published-props line)
|
||||
(when display-changed-p
|
||||
(put-text-property new-position new-end 'display new-display line))
|
||||
;; Changed extents rebuild their fragment ledger. Carry the
|
||||
;; proven caller baseline to that parser instead of reusing
|
||||
;; old fragment coordinates or peeling a composed face.
|
||||
(put-text-property
|
||||
new-position new-end ebox--paint-origin-property
|
||||
(ebox--paint-origin-create
|
||||
:baseline (copy-tree
|
||||
(baseline-for (+ (- (car span) origin) old-position)
|
||||
(+ (- (car span) origin) old-end)
|
||||
published-props)))
|
||||
line)
|
||||
(setq old-position old-end new-position new-end)))
|
||||
(unless (and (= old-position old-length) (= new-position new-length))
|
||||
(throw 'slot-property-miss nil))
|
||||
(push line result)))))
|
||||
(mapconcat #'identity (nreverse result) "\n"))))
|
||||
|
||||
(defun ebox-surface--retained-owner-text
|
||||
(buffer previous-state state owner-id spans replacement allocated-width
|
||||
variable-content-p variable-content-max-width)
|
||||
variable-content-p variable-content-max-width
|
||||
&optional role-owned-lines-p changed-keys snapshot)
|
||||
"Return REPLACEMENT text with proven unchanged published properties.
|
||||
Only direct content characters may change. An isolated old owner render must
|
||||
match the published text and the new render's complete property topology.
|
||||
@ -3642,12 +3785,13 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
(plist-get previous-state :node-table)))
|
||||
(new-node (gethash owner-id (plist-get state :node-table)))
|
||||
(regions (ebox--node-all-region-ids old-node))
|
||||
(root (ebox-surface--candidate-root old-node t))
|
||||
(root (if (and variable-content-p allocated-width)
|
||||
(plist-put root :width allocated-width)
|
||||
root))
|
||||
(render-node
|
||||
(ebox-surface--owner-slot-render-node
|
||||
buffer previous-state owner-id snapshot allocated-width
|
||||
variable-content-p role-owned-lines-p changed-keys))
|
||||
(root (and render-node (ebox-surface--candidate-root render-node t)))
|
||||
(probe
|
||||
(ebox--render-state-install-index
|
||||
(and root (ebox--render-state-install-index
|
||||
(ebox--new-buffer-render-state root)
|
||||
(ebox--runtime-index
|
||||
root t
|
||||
@ -3658,8 +3802,8 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
(parent (gethash parent-id (plist-get previous-state
|
||||
:node-table))))
|
||||
(ebox-tree-display-inner parent))
|
||||
(plist-get previous-state :source-index) t)))))
|
||||
(when (and replacement
|
||||
(plist-get previous-state :source-index) t))))))
|
||||
(when (and probe replacement
|
||||
(equal regions (ebox--node-all-region-ids new-node))
|
||||
(cl-every
|
||||
(lambda (region)
|
||||
@ -3669,9 +3813,23 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
(old (gethash old-id (plist-get previous-state :node-table)))
|
||||
(new (gethash new-id (plist-get state :node-table))))
|
||||
(and (equal old-id new-id)
|
||||
(ebox-surface--retained-property-value-equal-p
|
||||
(ebox-tree-node-source-identity old)
|
||||
(ebox-tree-node-source-identity new)))))
|
||||
(if role-owned-lines-p
|
||||
;; The canonical candidate may replace an
|
||||
;; anonymous source handle while retaining its
|
||||
;; runtime slot. This mode rebuilds fragment
|
||||
;; metadata; verify that slot's full identity
|
||||
;; topology instead of retaining the old handle.
|
||||
(and (eq (plist-get old :ebox-type)
|
||||
(plist-get new :ebox-type))
|
||||
(equal (gethash old-id (plist-get previous-state :parent-table))
|
||||
(gethash new-id (plist-get state :parent-table)))
|
||||
(equal (ebox-tree-node-author-key
|
||||
(plist-get previous-state :source-index) old)
|
||||
(ebox-tree-node-author-key
|
||||
(plist-get state :source-index) new)))
|
||||
(ebox-surface--retained-property-value-equal-p
|
||||
(ebox-tree-node-source-identity old)
|
||||
(ebox-tree-node-source-identity new))))))
|
||||
regions)
|
||||
(cl-every
|
||||
(lambda (key)
|
||||
@ -3683,9 +3841,16 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
(setq probe (plist-put probe key (plist-get previous-state key))))
|
||||
(let* ((ebox--box-content-render-cache (make-hash-table :test #'eq))
|
||||
(old-rendered (ebox-surface--render-candidate-node probe root))
|
||||
(old-shaped (ebox-surface--span-patch-lines
|
||||
buffer spans old-rendered variable-content-p
|
||||
variable-content-max-width))
|
||||
(old-rendered
|
||||
(if role-owned-lines-p
|
||||
(ebox-buffer--rendered-owned-lines old-rendered regions (length spans))
|
||||
old-rendered))
|
||||
(old-shaped
|
||||
(and old-rendered
|
||||
(ebox-surface--span-patch-lines
|
||||
buffer spans old-rendered variable-content-p
|
||||
variable-content-max-width
|
||||
(and role-owned-lines-p (ebox--region-id-set regions)))))
|
||||
(old-lines (and old-shaped (ebox-string-lines old-shaped)))
|
||||
(new-lines (ebox-string-lines replacement))
|
||||
(local (ebox--region-id-set regions))
|
||||
@ -3693,7 +3858,13 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
(= (length spans) (length old-lines))
|
||||
(= (length spans) (length new-lines))))
|
||||
result)
|
||||
(with-current-buffer buffer
|
||||
(if role-owned-lines-p
|
||||
(and valid
|
||||
(ebox-surface--retained-slot-owner-text
|
||||
buffer previous-state spans old-lines new-lines local
|
||||
(plist-get probe :render-owned-text-values)
|
||||
(plist-get state :render-owned-text-values)))
|
||||
(with-current-buffer buffer
|
||||
(cl-loop for span in spans
|
||||
for old in old-lines for new in new-lines
|
||||
while valid
|
||||
@ -3732,7 +3903,7 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
line)
|
||||
(setq position end)))
|
||||
(push line result))))))
|
||||
(and valid (mapconcat #'identity (nreverse result) "\n"))))))
|
||||
(and valid (mapconcat #'identity (nreverse result) "\n")))))))
|
||||
|
||||
(defun ebox-surface--owner-patch-candidate
|
||||
(buffer state owner-id allocated-width
|
||||
@ -3745,34 +3916,11 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
(and owner-id (ebox--ensure-layout-snapshot-details buffer owner-id)))
|
||||
(spans (and old-snapshot (plist-get old-snapshot :buffer-spans)))
|
||||
(node (and owner-id (gethash owner-id (plist-get state :node-table))))
|
||||
(parent-id (and owner-id
|
||||
(gethash owner-id (plist-get state :parent-table))))
|
||||
(parent (and parent-id
|
||||
(gethash parent-id (plist-get state :node-table))))
|
||||
(slot-sized-render-p
|
||||
(and role-owned-lines-p parent
|
||||
(eq (ebox-tree-display-inner parent) 'flex)))
|
||||
(render-node
|
||||
(if slot-sized-render-p
|
||||
;; The planner proved this fixed-basis owner in its published
|
||||
;; Flex slot. Recreate that exact candidate-state witness for
|
||||
;; publication; a natural render can have fewer owned lines and
|
||||
;; would spuriously widen the TP scope to the root.
|
||||
(and (fboundp 'ebox--flex-item-slot-sized-node)
|
||||
(let ((ebox-incremental--buffer-render-state-override
|
||||
(cons buffer state)))
|
||||
(ebox--flex-item-slot-sized-node
|
||||
buffer owner-id old-snapshot changed-keys)))
|
||||
;; Grouped owners and variable content have a proven retained
|
||||
;; allocation. Rendering there does not grant permission for
|
||||
;; the final footprint to vary.
|
||||
;; Ungrouped typography changes render at their natural size so
|
||||
;; the final footprint check observes any intrinsic-width change
|
||||
;; instead of hiding it behind the old allocation.
|
||||
(if (and node allocated-width
|
||||
(or variable-content-p role-owned-lines-p))
|
||||
(plist-put (copy-sequence node) :width allocated-width)
|
||||
node)))
|
||||
(and owner-id
|
||||
(ebox-surface--owner-slot-render-node
|
||||
buffer state owner-id old-snapshot allocated-width
|
||||
variable-content-p role-owned-lines-p changed-keys)))
|
||||
(retain-properties-p
|
||||
(and (memq (plist-get state :projection-kind)
|
||||
'(span-patch owner-scoped mixed-owner-reflow))
|
||||
@ -3783,7 +3931,7 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
;; must also survive its geometry replacement.
|
||||
(or (not retain-properties-p)
|
||||
(and previous-state
|
||||
(not (or role-owned-lines-p allocation-closure-p))
|
||||
(not allocation-closure-p)
|
||||
(ebox-surface--unchanged-enclosing-effects-p
|
||||
previous-state state owner-id))))
|
||||
(let* ((rendered
|
||||
@ -3842,7 +3990,8 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
(if retain-properties-p
|
||||
(ebox-surface--retained-owner-text
|
||||
buffer previous-state state owner-id spans replacement
|
||||
allocated-width variable-content-p variable-content-max-width)
|
||||
allocated-width variable-content-p variable-content-max-width
|
||||
role-owned-lines-p changed-keys old-snapshot)
|
||||
replacement))
|
||||
(details
|
||||
(and replacement
|
||||
@ -3853,7 +4002,8 @@ Proof mismatches return nil; unexpected rendering errors propagate."
|
||||
(and details
|
||||
(list :owner-id owner-id :snapshot old-snapshot
|
||||
:old-spans spans :details details
|
||||
:retained-properties-p retain-properties-p))))))
|
||||
:retained-properties-p
|
||||
(and retain-properties-p (not role-owned-lines-p))))))))
|
||||
|
||||
(defun ebox-surface--range-patch-candidate (buffer state proof)
|
||||
"Return PROOF's exact equal-line Range replacement candidate, or nil."
|
||||
|
||||
@ -2777,6 +2777,714 @@ remain retained identities."
|
||||
(ebox-test-box :key 'row-2 :source-identity 'row-2 (ebox-test-text row-2)))
|
||||
candidate))
|
||||
|
||||
(defun ebox-commit-test--allocated-single-root
|
||||
(content color &optional boundary sibling-content)
|
||||
"Return CONTENT and COLOR beside scroll, with BOUNDARY and SIBLING-CONTENT."
|
||||
(let ((root
|
||||
(ebox-test-column :width '(900)
|
||||
(ebox-commit-test--fixed-basis-selection-root
|
||||
content (or sibling-content "stable") (eq boundary 'scroll))
|
||||
(ebox-test-box :key 'paint :source-identity 'paint :color color
|
||||
(ebox-test-text "paint"))
|
||||
(unless (eq boundary 'scroll)
|
||||
(ebox-commit-test--scroll-sibling-root "untouched")))))
|
||||
(if (eq boundary 'enclosing-paint)
|
||||
(ebox-test-box :bgcolor "#EEEEEE" root)
|
||||
root)))
|
||||
|
||||
(defun ebox-commit-test--allocated-single-candidate (buffer content &optional color)
|
||||
"Return BUFFER candidate replacing one row with CONTENT and optional COLOR."
|
||||
(let ((candidate (ebox-candidate-begin buffer)))
|
||||
(ebox-candidate-replace-host-ref
|
||||
candidate 'row-1
|
||||
(ebox-test-box :key 'row-1 :source-identity 'row-1 (ebox-test-text content)))
|
||||
(when color
|
||||
(ebox-candidate-replace-host-ref
|
||||
candidate 'paint
|
||||
(ebox-test-box :key 'paint :source-identity 'paint :color color
|
||||
(ebox-test-text "paint"))))
|
||||
candidate))
|
||||
|
||||
(defun ebox-commit-test--allocated-single-output (buffer)
|
||||
"Return BUFFER's complete text and public mount coordinates by tree path.
|
||||
Normalize only buffer-local region identifiers; retain every text property."
|
||||
(let* ((state (ebox--buffer-render-state buffer))
|
||||
(objects (plist-get state :surface-node-object-table))
|
||||
(paths (make-hash-table :test #'eql))
|
||||
(regions (make-hash-table :test #'eql))
|
||||
(text (ebox-commit-test--buffer-string buffer))
|
||||
(properties (delete-dups
|
||||
(append (mapcar #'cdr ebox-region-types)
|
||||
'(ebox-scroll-window
|
||||
ebox-overflow-foreground-source))))
|
||||
nodes mounts)
|
||||
(cl-labels ((walk (node path)
|
||||
(push (cons path node) nodes)
|
||||
(puthash (plist-get node :node-id) path paths)
|
||||
(cl-loop for child in (ebox-tree-node-children node)
|
||||
for index from 0
|
||||
do (walk child (append path (list index)))))
|
||||
(region-path (id)
|
||||
(or (gethash id regions)
|
||||
(ert-fail (list :unknown-region id)))))
|
||||
(walk (plist-get state :root-node) '(root))
|
||||
(maphash (lambda (region node-id)
|
||||
(puthash region (gethash node-id paths) regions))
|
||||
(plist-get state :region-node-table))
|
||||
(let ((position 0))
|
||||
(while (< position (length text))
|
||||
(let ((end (or (next-property-change position text) (length text)))
|
||||
(props (text-properties-at position text)))
|
||||
(dolist (property properties)
|
||||
(when-let* ((id (plist-get props property)))
|
||||
(setq props (plist-put props property (region-path id)))))
|
||||
(when-let* ((owners (plist-get props 'ebox-content-owners)))
|
||||
(setq props (plist-put props 'ebox-content-owners
|
||||
(mapcar #'region-path owners))))
|
||||
(set-text-properties position end props text)
|
||||
(setq position end))))
|
||||
(dolist (entry nodes)
|
||||
(let* ((object (gethash (plist-get (cdr entry) :node-id) objects))
|
||||
(ranges (mapcar (lambda (mount)
|
||||
(cons (plist-get mount :start)
|
||||
(plist-get mount :end)))
|
||||
(tp-object-mounts object))))
|
||||
;; Local and full publication can use different role tags, but
|
||||
;; every owner must cover the same complete published coordinates.
|
||||
(push (cons (car entry)
|
||||
(sort ranges (lambda (a b)
|
||||
(if (= (car a) (car b))
|
||||
(< (cdr a) (cdr b))
|
||||
(< (car a) (car b))))))
|
||||
mounts))))
|
||||
(list text mounts)))
|
||||
|
||||
(defun ebox-commit-test--assert-allocated-output (buffer input)
|
||||
"Compare BUFFER with an independent full render of canonical INPUT."
|
||||
(with-temp-buffer
|
||||
(unwind-protect
|
||||
(progn
|
||||
(ebox-render-to-buffer (current-buffer) input)
|
||||
(let ((actual (ebox-commit-test--allocated-single-output buffer))
|
||||
(expected (ebox-commit-test--allocated-single-output (current-buffer))))
|
||||
(should (equal-including-properties (car actual) (car expected)))
|
||||
(should (equal (cadr actual) (cadr expected)))))
|
||||
(when (ebox-surface-buffer-mounted-p (current-buffer))
|
||||
(ebox-unmount-buffer (current-buffer))))))
|
||||
|
||||
(defun ebox-commit-test--assert-allocated-single-fresh
|
||||
(buffer content color &optional sibling-content)
|
||||
"Compare BUFFER with a new full render of CONTENT, COLOR and SIBLING-CONTENT."
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
buffer (ebox-commit-test--allocated-single-root content color nil sibling-content)))
|
||||
|
||||
(defun ebox-commit-test--allocated-single-round-trip (paint-p)
|
||||
"One longer/shorter row promotes its allocated owner, with disjoint paint."
|
||||
(ert-info ((format "allocated single with disjoint paint: %S" paint-p))
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root "short" "#123456"))
|
||||
(let* ((state (ebox--buffer-render-state (current-buffer)))
|
||||
(owner-id
|
||||
(cl-loop for node being the hash-values of (plist-get state :node-table)
|
||||
when (eq (ebox-tree-node-author-key
|
||||
(plist-get state :source-index) node)
|
||||
'selection-panel)
|
||||
return (plist-get node :node-id)))
|
||||
(paint-id (plist-get (ebox--host-ref-node
|
||||
(current-buffer) 'paint) :node-id))
|
||||
(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))
|
||||
(region-count (hash-table-count ebox--region-box-table)))
|
||||
(should (integerp owner-id))
|
||||
(dolist (step '(("a longer row" "#654321") ("short" "#123456")))
|
||||
(let* ((content (car step))
|
||||
(color (if paint-p (cadr step) "#123456"))
|
||||
(result
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) content (and paint-p color))))))
|
||||
(report (car result)))
|
||||
(should (zerop (cdr result)))
|
||||
(should (eq (plist-get report :projection-kind)
|
||||
(if paint-p 'mixed-owner-reflow 'owner-scoped)))
|
||||
(should (equal (plist-get report :owner-ids)
|
||||
(if paint-p (list owner-id paint-id) (list owner-id))))
|
||||
(should-not (plist-get report :tp-full-root))
|
||||
(should-not (plist-get report :tp-scope-fallback))
|
||||
(ebox-commit-test--assert-allocated-single-fresh
|
||||
(current-buffer) content color)
|
||||
(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)))
|
||||
(should (eq (plist-get next-scroll :box)
|
||||
(gethash scroll-id ebox--region-box-table)))
|
||||
(should (= region-count (hash-table-count ebox--region-box-table))))
|
||||
(should (= 1 (ebox--scroll-region-by scroll-id 1)))
|
||||
(should (string-match-p "line-c" (buffer-string)))
|
||||
(should (string-match-p (regexp-quote content) (buffer-string)))
|
||||
(should (= -1 (ebox--scroll-region-by scroll-id -1)))
|
||||
(ebox-commit-test--assert-allocated-single-fresh
|
||||
(current-buffer) content color)))))))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-single-round-trip-retains-disjoint-scroll ()
|
||||
"One content change retains its disjoint scroll through both directions."
|
||||
(ebox-commit-test--allocated-single-round-trip nil))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-single-mixed-round-trip-retains-disjoint-scroll ()
|
||||
"One content change and sibling paint retain scroll in both directions."
|
||||
(ebox-commit-test--allocated-single-round-trip t))
|
||||
|
||||
(defun ebox-commit-test--allocated-single-rollback (paint-p)
|
||||
"Rejected allocated-owner publication restores mounts, scroll and revision."
|
||||
(ert-info ((format "allocated single rollback with paint: %S" paint-p))
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root "short" "#123456"))
|
||||
(let* ((before (ebox--buffer-render-state (current-buffer)))
|
||||
(surface ebox-surface--buffer-surface)
|
||||
(revision (tp-surface-revision surface))
|
||||
(report (tp-surface-report surface))
|
||||
(output (ebox-commit-test--allocated-single-output (current-buffer)))
|
||||
(scroll-id (car (plist-get before :scroll-region-ids)))
|
||||
(scroll (gethash scroll-id ebox--scroll-global-state))
|
||||
(box (gethash scroll-id ebox--region-box-table))
|
||||
(color (if paint-p "#654321" "#123456"))
|
||||
(failures 0)
|
||||
(attempt
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(let ((tp--surface-publication-step-function
|
||||
(lambda (step target)
|
||||
(when (eq step 'client-state)
|
||||
(should (eq target surface))
|
||||
(cl-incf failures)
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should-not (eq before (tp-surface-client-state surface)))
|
||||
(error "Reject allocated single publication")))))
|
||||
(should-error
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) "a longer row" (and paint-p color)))))))))
|
||||
(should (= failures 1))
|
||||
(should (equal (car attempt) '(error "Reject allocated single publication")))
|
||||
(should (eq before (ebox--buffer-render-state (current-buffer))))
|
||||
(should (eq before (tp-surface-client-state surface)))
|
||||
(should (= revision (tp-surface-revision surface)))
|
||||
(should (equal report (tp-surface-report surface)))
|
||||
(should (equal-including-properties
|
||||
output (ebox-commit-test--allocated-single-output (current-buffer))))
|
||||
(should (eq scroll (gethash scroll-id ebox--scroll-global-state)))
|
||||
(should (eq box (gethash scroll-id ebox--region-box-table)))
|
||||
(should (= 1 (ebox--scroll-region-by scroll-id 1)))
|
||||
(should (= -1 (ebox--scroll-region-by scroll-id -1)))
|
||||
(let* ((retry-revision (tp-surface-revision surface))
|
||||
(retry
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) "a longer row" (and paint-p color)))))))
|
||||
(should (zerop (cdr attempt)))
|
||||
(should (zerop (cdr retry)))
|
||||
(should (= (tp-surface-revision surface) (1+ retry-revision)))
|
||||
(should-not (plist-get (car retry) :tp-full-root))
|
||||
(ebox-commit-test--assert-allocated-single-fresh
|
||||
(current-buffer) "a longer row" color))))))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-single-publication-rollback-and-fresh-retry ()
|
||||
"One allocated content change rolls back and accepts a fresh retry."
|
||||
(ebox-commit-test--allocated-single-rollback nil))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-single-mixed-rollback-and-fresh-retry ()
|
||||
"An allocated content and paint transaction rolls back and retries."
|
||||
(ebox-commit-test--allocated-single-rollback t))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-single-unsafe-boundaries-fall-back ()
|
||||
"Changed extent and owner-scroll overlap retain fallback."
|
||||
(dolist (boundary '(extent scroll))
|
||||
(ert-info ((format "allocated single unsafe boundary: %S" boundary))
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root "short" "#123456" boundary))
|
||||
(let* ((content (if (eq boundary 'extent)
|
||||
(mapconcat #'identity (make-list 30 "long row") "\n")
|
||||
"a longer row"))
|
||||
(result
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) content))))))
|
||||
(should (= (cdr result) 1))
|
||||
(should-not (memq (plist-get (car result) :projection-kind)
|
||||
'(span-patch owner-scoped mixed-owner-reflow)))
|
||||
(should (string-match-p "long" (buffer-string))))))))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-single-retains-anonymous-enclosing-paint ()
|
||||
"Unchanged paint on an anonymous ancestor permits allocated publication."
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root "short" "#123456" 'enclosing-paint))
|
||||
(dolist (content '("a longer row" "short"))
|
||||
(let ((result
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) content))))))
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root content "#123456" 'enclosing-paint))
|
||||
(should (zerop (cdr result)))
|
||||
(should (eq (plist-get (car result) :projection-kind) 'owner-scoped))
|
||||
(should-not (plist-get (car result) :tp-full-root))
|
||||
(should-not (plist-get (car result) :tp-scope-fallback))))))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-single-keeps-successful-leaf-proof ()
|
||||
"An existing narrow single-leaf proof stays local without owner promotion."
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer) (ebox-commit-test--scroll-sibling-root "old"))
|
||||
(let* ((leaf-id (plist-get (ebox--host-ref-node (current-buffer) 'label) :node-id))
|
||||
(result
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit-test--replace-scroll-sibling-label
|
||||
(current-buffer) "new")))))
|
||||
(should (zerop (cdr result)))
|
||||
(should (equal (plist-get (car result) :owner-ids) (list leaf-id)))
|
||||
(should-not (plist-get (car result) :tp-full-root))
|
||||
(should (string-match-p "new" (buffer-string))))))
|
||||
|
||||
(ert-deftest ebox-commit-grouped-allocation-retains-ancestor-ownership ()
|
||||
"An existing multiple-descendant allocation preserves every ancestor mount."
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer) (ebox-commit-test--allocated-single-root "short" "#123456"))
|
||||
(let ((result
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--fixed-basis-selection-candidate
|
||||
(current-buffer) "a longer row" "other"))))))
|
||||
(should (zerop (cdr result)))
|
||||
(should (eq (plist-get (car result) :projection-kind) 'owner-scoped))
|
||||
(ebox-commit-test--assert-allocated-single-fresh
|
||||
(current-buffer) "a longer row" "#123456" "other"))))
|
||||
|
||||
(defun ebox-commit-test--padded-grouped-allocation-root
|
||||
(first second color &optional owner-sizing)
|
||||
"Return FIRST and SECOND in a padded panel beside COLOR and scroll.
|
||||
OWNER-SIZING adds asymmetric margins, padding and borders to the inner Column."
|
||||
(ebox-test-column :width '(900)
|
||||
(ebox-test-flex :width '(900) :height 24
|
||||
:flex-flow '(row nowrap) :align-items 'stretch
|
||||
(ebox-test-box :key 'peer :width 'stretch :min-width 0 :min-height 24
|
||||
:flex-grow 0 :flex-shrink 0 :flex-basis '(561)
|
||||
(ebox-test-text "peer"))
|
||||
(ebox-test-column :key 'panel :source-identity 'panel
|
||||
:width 'stretch :min-width 0 :min-height 24
|
||||
:box-sizing 'border-box :padding '(0 (15))
|
||||
:flex-grow 0 :flex-shrink 0 :flex-basis '(339)
|
||||
:bgcolor "#EEEEEE"
|
||||
(apply #'ebox-test-column
|
||||
(append
|
||||
(list :key 'rows :source-identity 'rows :min-width 0
|
||||
(ebox-test-text first :key 'row-1 :source-identity 'row-1)
|
||||
(ebox-test-text second :key 'row-2 :source-identity 'row-2))
|
||||
(and owner-sizing
|
||||
(list :box-sizing owner-sizing
|
||||
:margin-left '(2) :margin-right '(4)
|
||||
:padding-left '(3) :padding-right '(5)
|
||||
:border-left '(1 solid "#223344")
|
||||
:border-right '(2 solid "#445566")))))))
|
||||
(ebox-test-box :key 'paint :source-identity 'paint :color color
|
||||
(ebox-test-text "paint"))
|
||||
(ebox-commit-test--scroll-sibling-root "untouched")))
|
||||
|
||||
(defun ebox-commit-test--padded-grouped-allocation-candidate
|
||||
(buffer first second color)
|
||||
"Return BUFFER candidate replacing both nested rows and sibling COLOR."
|
||||
(let ((candidate (ebox-candidate-begin buffer)))
|
||||
(cl-loop for identity in '(row-1 row-2) for content in (list first second)
|
||||
do (ebox-candidate-replace-host-ref
|
||||
candidate identity
|
||||
(ebox-test-text content :key identity :source-identity identity)))
|
||||
(ebox-candidate-replace-host-ref
|
||||
candidate 'paint
|
||||
(ebox-test-box :key 'paint :source-identity 'paint :color color
|
||||
(ebox-test-text "paint")))
|
||||
candidate))
|
||||
|
||||
(defun ebox-commit-test--padded-grouped-allocation-round-trip (&optional owner-sizing)
|
||||
"Check grouped width and repeated edits with optional OWNER-SIZING."
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer)
|
||||
(ebox-commit-test--padded-grouped-allocation-root
|
||||
"short" "small" "#123456" owner-sizing))
|
||||
(let ((owner-id (plist-get (ebox--host-ref-node (current-buffer) 'rows) :node-id))
|
||||
(grouped-proof (symbol-function 'ebox-incremental--grouped-owner-span-proof)))
|
||||
;; Equal-extent edits coalesce their successful narrow proofs at the
|
||||
;; inner Column. Length changes promote the containing fixed-basis
|
||||
;; panel under the existing scroll guard; both owners must stay local.
|
||||
(dolist (step '(("other" "later" "#654321")
|
||||
("a longer first row" "a longer second row" "#123456")
|
||||
("short" "small" "#654321")))
|
||||
(let ((candidate (apply #'ebox-commit-test--padded-grouped-allocation-candidate
|
||||
(current-buffer) step))
|
||||
proof result)
|
||||
(cl-letf (((symbol-function 'ebox-incremental--grouped-owner-span-proof)
|
||||
(lambda (&rest arguments)
|
||||
(let ((value (apply grouped-proof arguments)))
|
||||
(when value (setq proof value))
|
||||
value))))
|
||||
(setq result (ebox-commit-test--count-root-renders
|
||||
(lambda () (ebox-commit (current-buffer) candidate)))))
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
(current-buffer)
|
||||
(apply #'ebox-commit-test--padded-grouped-allocation-root
|
||||
(append step (list owner-sizing))))
|
||||
(when (equal (car step) "other")
|
||||
(should (equal (plist-get proof :owner-ids) (list owner-id)))
|
||||
(let* ((owner-proof (car (plist-get proof :owner-proofs)))
|
||||
(snapshot (plist-get owner-proof :snapshot))
|
||||
(owner-width
|
||||
(plist-get (plist-get snapshot :external-footprint-signature)
|
||||
:max-line-pixel-width))
|
||||
(capacity (plist-get owner-proof :allocated-width)))
|
||||
(message "Padded grouped Column: sizing=%S owner-width=%S ancestor-capacity=%S root-renders=%S"
|
||||
owner-sizing owner-width capacity (cdr result))
|
||||
(should (= owner-width 309))
|
||||
(should (= capacity 339))))
|
||||
(should (zerop (cdr result)))
|
||||
(should (eq (plist-get (car result) :projection-kind) 'mixed-owner-reflow))
|
||||
(should-not (plist-get (car result) :tp-full-root)))))))
|
||||
|
||||
(ert-deftest ebox-commit-grouped-padded-panel-renders-own-column-width ()
|
||||
"A grouped Column uses its own published width inside a padded Flex item."
|
||||
(ebox-commit-test--padded-grouped-allocation-round-trip))
|
||||
|
||||
(ert-deftest ebox-commit-grouped-padded-panel-preserves-owner-box-model ()
|
||||
"Asymmetric margins, padding and borders preserve both owner box models."
|
||||
(dolist (sizing '(content-box border-box))
|
||||
(ert-info ((format "padded grouped owner sizing: %S" sizing))
|
||||
(ebox-commit-test--padded-grouped-allocation-round-trip sizing))))
|
||||
|
||||
(ert-deftest ebox-commit-grouped-padded-panel-rolls-back-and-retries ()
|
||||
"Rejected nested owner publication restores mounts and both box models."
|
||||
(dolist (sizing '(content-box border-box))
|
||||
(ert-info ((format "padded grouped rollback sizing: %S" sizing))
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer)
|
||||
(ebox-commit-test--padded-grouped-allocation-root
|
||||
"short" "small" "#123456" sizing))
|
||||
(let* ((before (ebox--buffer-render-state (current-buffer)))
|
||||
(surface ebox-surface--buffer-surface)
|
||||
(revision (tp-surface-revision surface))
|
||||
(report (tp-surface-report surface))
|
||||
(output (ebox-commit-test--allocated-single-output (current-buffer)))
|
||||
(owner-id (plist-get (ebox--host-ref-node (current-buffer) 'rows) :node-id))
|
||||
(paint-id (plist-get (ebox--host-ref-node (current-buffer) 'paint) :node-id))
|
||||
(scroll-id (car (plist-get before :scroll-region-ids)))
|
||||
(scroll (gethash scroll-id ebox--scroll-global-state))
|
||||
(failures 0)
|
||||
(rejected
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(let ((tp--surface-publication-step-function
|
||||
(lambda (step target)
|
||||
(when (eq step 'client-state)
|
||||
(should (eq target surface))
|
||||
(cl-incf failures)
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should-not (eq before (tp-surface-client-state surface)))
|
||||
(error "Reject padded grouped publication")))))
|
||||
(should-error
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--padded-grouped-allocation-candidate
|
||||
(current-buffer) "other" "later" "#654321"))))))))
|
||||
(should (= failures 1))
|
||||
(should (equal (car rejected) '(error "Reject padded grouped publication")))
|
||||
(should (zerop (cdr rejected)))
|
||||
(should (eq before (ebox--buffer-render-state (current-buffer))))
|
||||
(should (eq before (tp-surface-client-state surface)))
|
||||
(should (= revision (tp-surface-revision surface)))
|
||||
(should (equal report (tp-surface-report surface)))
|
||||
(should (eq scroll (gethash scroll-id ebox--scroll-global-state)))
|
||||
(should (equal-including-properties
|
||||
output (ebox-commit-test--allocated-single-output (current-buffer))))
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
(current-buffer)
|
||||
(ebox-commit-test--padded-grouped-allocation-root
|
||||
"short" "small" "#123456" sizing))
|
||||
(let ((retry
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--padded-grouped-allocation-candidate
|
||||
(current-buffer) "other" "later" "#654321"))))))
|
||||
(should (zerop (cdr retry)))
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should (equal (plist-get (car retry) :owner-ids) (list owner-id paint-id)))
|
||||
(should (eq (plist-get (car retry) :projection-kind) 'mixed-owner-reflow))
|
||||
(should-not (plist-get (car retry) :tp-full-root))
|
||||
(let ((next-scroll (gethash scroll-id ebox--scroll-global-state)))
|
||||
(should (eq (plist-get scroll :content-lines)
|
||||
(plist-get next-scroll :content-lines)))
|
||||
(should (eq (plist-get scroll :rendered-content-lines)
|
||||
(plist-get next-scroll :rendered-content-lines)))
|
||||
(should (eq (plist-get next-scroll :box)
|
||||
(gethash scroll-id ebox--region-box-table))))
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
(current-buffer)
|
||||
(ebox-commit-test--padded-grouped-allocation-root
|
||||
"other" "later" "#654321" sizing))))))))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-owner-retains-enclosing-properties ()
|
||||
"Resized text retains caller faces and the baseline for later paint edits."
|
||||
(let ((callback (lambda () 'allocated-action))
|
||||
(payload (make-hash-table :test #'eq))
|
||||
(keymap (make-sparse-keymap))
|
||||
(face '(:weight bold)))
|
||||
(define-key keymap (kbd "RET") callback)
|
||||
(cl-labels
|
||||
((text (content)
|
||||
(propertize content 'face face 'action callback))
|
||||
(parent (content color)
|
||||
(apply #'ebox-test-box
|
||||
(append
|
||||
(list :key 'enclosing :source-identity 'enclosing
|
||||
:surface-properties
|
||||
(list 'help-echo callback 'custom payload 'keymap keymap)
|
||||
(ebox-commit-test--fixed-basis-selection-root
|
||||
(text content) "stable"))
|
||||
(and color (list :bgcolor color)))))
|
||||
(root (content color)
|
||||
(ebox-test-column :width '(900)
|
||||
(ebox-test-box :bgcolor "#FFFDF8" (parent content color))
|
||||
(ebox-commit-test--scroll-sibling-root "untouched")))
|
||||
(assert-content (content background)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(search-forward content)
|
||||
(let ((position (- (point) (length content))))
|
||||
(dotimes (offset (length content))
|
||||
(let ((at (+ position offset)))
|
||||
(should (eq callback (get-text-property at 'help-echo)))
|
||||
(should (eq callback (get-text-property at 'action)))
|
||||
(should (eq payload (get-text-property at 'custom)))
|
||||
(should (eq callback
|
||||
(lookup-key (get-text-property at 'keymap) (kbd "RET"))))
|
||||
(should (eq 'bold (ebox-commit-test--face-value
|
||||
(get-text-property at 'face) :weight)))
|
||||
(should (equal background
|
||||
(ebox-commit-test--face-value
|
||||
(get-text-property at 'face) :background)))))))))
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer (current-buffer) (root "short" "#EEEEEE"))
|
||||
(dolist (content '("a longer row" "short"))
|
||||
(let ((result
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) (text content)))))))
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
(current-buffer) (root content "#EEEEEE"))
|
||||
(assert-content content "#EEEEEE")
|
||||
(should (zerop (cdr result)))
|
||||
(should (eq (plist-get (car result) :projection-kind) 'owner-scoped))))
|
||||
(let ((previous "#EEEEEE"))
|
||||
(dolist (color '("#667788" nil))
|
||||
(let ((candidate (ebox-candidate-begin (current-buffer))))
|
||||
(should (ebox-candidate-patch-host-paint
|
||||
candidate 'enclosing
|
||||
(parent "short" previous) (parent "short" color)))
|
||||
(let ((result (ebox-commit-test--count-root-renders
|
||||
(lambda () (ebox-commit (current-buffer) candidate)))))
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
(current-buffer) (root "short" color))
|
||||
(assert-content "short" (or color "#FFFDF8"))
|
||||
(should (zerop (cdr result)))
|
||||
(should (eq (plist-get (car result) :projection-kind) 'paint))))
|
||||
(setq previous color)))))))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-owner-property-changes-render-current-values ()
|
||||
"Opaque payload and caller display changes cannot retain stale properties."
|
||||
(dolist (change '(callback keymap hash caller-display noncanonical-display))
|
||||
(ert-info ((format "allocated owner changed property: %S" change))
|
||||
(let* ((make-callback (lambda ()
|
||||
(let ((value (vector t))) (lambda () value))))
|
||||
(callback (funcall make-callback))
|
||||
(other-callback (funcall make-callback))
|
||||
(property (pcase change
|
||||
('callback 'action) ('keymap 'keymap) ('hash 'custom)
|
||||
(_ 'display)))
|
||||
(old-value (pcase change
|
||||
('callback callback)
|
||||
('keymap (let ((map (make-sparse-keymap)))
|
||||
(define-key map (kbd "RET") callback) map))
|
||||
('hash (make-hash-table :test #'eq))
|
||||
('caller-display '(space :width (8)))
|
||||
(_ '(raise 0))))
|
||||
(new-value (pcase change
|
||||
('callback other-callback)
|
||||
('keymap (let ((map (make-sparse-keymap)))
|
||||
(define-key map (kbd "RET") other-callback) map))
|
||||
('hash (make-hash-table :test #'eq))
|
||||
('caller-display '(space :width (12)))
|
||||
(_ '(raise 1))))
|
||||
(old (propertize "short" property old-value))
|
||||
(new (propertize "a longer row" property new-value)))
|
||||
(when (memq change '(callback keymap))
|
||||
(should (equal old-value new-value))
|
||||
(should-not (eq old-value new-value)))
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root old "#123456" 'enclosing-paint))
|
||||
(let ((result
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate (current-buffer) new))))))
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root new "#123456" 'enclosing-paint))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(search-forward "a longer row")
|
||||
(let ((actual (get-text-property (1- (point)) property)))
|
||||
(pcase change
|
||||
((or 'callback 'hash) (should (eq new-value actual)))
|
||||
('keymap (should (eq other-callback (lookup-key actual (kbd "RET")))))
|
||||
(_ (should (equal new-value actual))))))
|
||||
(should (> (cdr result) 0))))))))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-owner-interior-property-boundary-declines ()
|
||||
"A published property boundary inside resized content declines transport."
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root "short" "#123456" 'enclosing-paint))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(search-forward "short")
|
||||
(let ((inhibit-read-only t))
|
||||
(put-text-property (- (point) 3) (- (point) 1) 'external-boundary 'published)))
|
||||
(let ((transport (symbol-function 'ebox-surface--retained-slot-owner-text))
|
||||
(declines 0)
|
||||
result)
|
||||
(cl-letf (((symbol-function 'ebox-surface--retained-slot-owner-text)
|
||||
(lambda (&rest arguments)
|
||||
(let ((value (apply transport arguments)))
|
||||
(unless value (cl-incf declines))
|
||||
value))))
|
||||
(setq result
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) "a longer row"))))))
|
||||
(should (> declines 0))
|
||||
(should (> (cdr result) 0))
|
||||
(ebox-commit-test--assert-allocated-output
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-root
|
||||
"a longer row" "#123456" 'enclosing-paint)))))
|
||||
|
||||
(ert-deftest ebox-commit-allocated-owner-enclosing-properties-rollback-and-retry ()
|
||||
"Late rejection restores enclosing properties, mounts and opaque identities."
|
||||
(let ((callback (lambda () 'allocated-action))
|
||||
(payload (make-hash-table :test #'eq))
|
||||
(keymap (make-sparse-keymap)))
|
||||
(define-key keymap (kbd "RET") callback)
|
||||
(cl-labels
|
||||
((text (content) (propertize content 'face '(:weight bold) 'action callback))
|
||||
(root (content)
|
||||
(ebox-test-box :bgcolor "#FFFDF8"
|
||||
(ebox-test-box :bgcolor "#EEEEEE"
|
||||
:surface-properties
|
||||
(list 'help-echo callback 'custom payload 'keymap keymap)
|
||||
(ebox-commit-test--allocated-single-root (text content) "#123456")))))
|
||||
(with-temp-buffer
|
||||
(ebox-render-to-buffer (current-buffer) (root "short"))
|
||||
(let* ((before (ebox--buffer-render-state (current-buffer)))
|
||||
(surface ebox-surface--buffer-surface)
|
||||
(revision (tp-surface-revision surface))
|
||||
(report (tp-surface-report surface))
|
||||
(output (ebox-commit-test--allocated-single-output (current-buffer)))
|
||||
(failures 0)
|
||||
(attempt
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(let ((tp--surface-publication-step-function
|
||||
(lambda (step target)
|
||||
(when (eq step 'client-state)
|
||||
(should (eq target surface))
|
||||
(cl-incf failures)
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should-not (eq before (tp-surface-client-state surface)))
|
||||
(error "Reject allocated enclosing properties")))))
|
||||
(should-error
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) (text "a longer row")))))))))
|
||||
(should (= failures 1))
|
||||
(should (equal (car attempt) '(error "Reject allocated enclosing properties")))
|
||||
(should (zerop (cdr attempt)))
|
||||
(should (eq before (ebox--buffer-render-state (current-buffer))))
|
||||
(should (eq before (tp-surface-client-state surface)))
|
||||
(should (= revision (tp-surface-revision surface)))
|
||||
(should (equal report (tp-surface-report surface)))
|
||||
(should (equal-including-properties
|
||||
output (ebox-commit-test--allocated-single-output (current-buffer))))
|
||||
(ebox-commit-test--assert-allocated-output (current-buffer) (root "short"))
|
||||
(let ((retry
|
||||
(ebox-commit-test--count-root-renders
|
||||
(lambda ()
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-commit-test--allocated-single-candidate
|
||||
(current-buffer) (text "a longer row")))))))
|
||||
(should (zerop (cdr retry)))
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should (eq (plist-get (car retry) :projection-kind) 'owner-scoped))
|
||||
(should-not (plist-get (car retry) :tp-full-root))
|
||||
(ebox-commit-test--assert-allocated-output (current-buffer) (root "a longer row"))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(search-forward "a longer row")
|
||||
(should (eq callback (get-text-property (1- (point)) 'action)))
|
||||
(should (eq callback (get-text-property (1- (point)) 'help-echo)))
|
||||
(should (eq payload (get-text-property (1- (point)) 'custom)))
|
||||
(should (eq callback
|
||||
(lookup-key (get-text-property (1- (point)) 'keymap)
|
||||
(kbd "RET")))))))))))
|
||||
|
||||
(ert-deftest ebox-commit-grouped-owners-retain-disjoint-scroll ()
|
||||
"A stable slot groups two text edits, with optional paint, beside scroll."
|
||||
(dolist (paint-p '(nil t))
|
||||
|
||||
@ -276,11 +276,19 @@
|
||||
(should (= revision (tp-surface-revision surface)))
|
||||
;; The dependency range authorizes the filler, not unrelated
|
||||
;; output elsewhere in the complete candidate.
|
||||
(let ((render (symbol-function 'ebox-surface--render-candidate)))
|
||||
(cl-letf (((symbol-function 'ebox-surface--render-candidate)
|
||||
(let ((render (symbol-function 'ebox-surface--render-candidate))
|
||||
(injections 0))
|
||||
;; Keep the strict full-output dependency-scope check in its
|
||||
;; ordinary lane. Grouped proofs can render locally and
|
||||
;; explicitly permit a root retry after a scope mismatch.
|
||||
(cl-letf (((symbol-function 'ebox-incremental--grouped-owner-span-proof)
|
||||
(lambda (&rest _arguments) nil))
|
||||
((symbol-function 'ebox-surface--render-candidate)
|
||||
(lambda (candidate)
|
||||
(let* ((output (funcall render candidate))
|
||||
(start (string-match "outside" output)))
|
||||
(should start)
|
||||
(cl-incf injections)
|
||||
(put-text-property start (1+ start)
|
||||
'help-echo "unrelated" output)
|
||||
output))))
|
||||
@ -288,7 +296,8 @@
|
||||
(ebox-commit
|
||||
(current-buffer)
|
||||
(ebox-surface-test--filler-root "next" kind))
|
||||
:type 'tp-scope-mismatch)))
|
||||
:type 'tp-scope-mismatch))
|
||||
(should (= injections 1)))
|
||||
(should (equal-including-properties before (buffer-string)))
|
||||
(should (eq state (tp-surface-client-state surface)))
|
||||
(should (= revision (tp-surface-revision surface))))))))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user