feat(tp): add scoped retained surface updates
Allow callers to authorize one atomic surface update through generic retained object handles while TP remains the sole owner of mount resolution, buffer publication, and rollback. Verified: byte compilation with warnings as errors; 726 ERT tests; 92 doctests; targeted scoped-update tests; checkdoc; git diff --check.
This commit is contained in:
Kinneyzhang
parent
fc4a36ba2b
commit
07b84b0685
@ -178,7 +178,7 @@ The TP 1.0 migration has begun with a pure schema-driven cascade kernel. `tp-sty
|
||||
|
||||
`tp-reactive.el` now also provides the TP 1.0 exact dependency runtime: signals invalidate only their subscribed bindings, binding reads form memoized binding→binding edges, conditional computations replace obsolete dependencies, and the outermost `tp-with-transaction` flushes each dirty binding once. Candidate signal writes and binding values/dependencies commit together; compute, cycle, publication, or transaction-participant failures roll them back. `tp-transaction-participate` lets a client promote opaque side state after surfaces publish while supplying its inverse for the same rollback boundary. Global and buffer-local variable adapters reuse this graph without making text properties or buffer scans the runtime database.
|
||||
|
||||
`tp-surface.el` completes the retained publication path from object identity to marker-backed mounts and buffers. A producer receives a short-lived prepare context, ensures candidate objects before computing output, and returns a defensive pure plan plus optional opaque client state. A logical object may be retained without visible output or attached to several disjoint plan fragments; the plan still contains no runtime handle or position, while `tp-object-mounts` resolves its current numeric ranges directly from side state. TP validates the whole candidate before publication, applies common-prefix/suffix text edits and property-run diffs, swaps plans/indexes/client state at one revision, and rolls every affected buffer and signal back together on failure. `content` owns a disjoint text span; `properties` decorates attached host ranges, detects external property conflicts, and requires explicit rebase. Overlap is composable inside one surface and rejected across independent surfaces so ownership cannot silently split.
|
||||
`tp-surface.el` completes the retained publication path from object identity to marker-backed mounts and buffers. A producer receives a short-lived prepare context, ensures candidate objects before computing output, and returns a defensive pure plan plus optional opaque client state. A logical object may be retained without visible output or attached to several disjoint plan fragments; the plan still contains no runtime handle or position, while `tp-object-mounts` resolves its current numeric ranges directly from side state. TP validates the whole candidate before publication, applies common-prefix/suffix text edits and property-run diffs, swaps plans/indexes/client state at one revision, and rolls every affected buffer and signal back together on failure. `tp-surface-update-scoped` authorizes one transaction to publish only the mounted ranges of selected retained objects, including disjoint mounts and properties-only anchors; a candidate that changes output elsewhere fails before publication unless the caller explicitly requests a root fallback. `content` owns a disjoint text span; `properties` decorates attached host ranges, detects external property conflicts, and requires explicit rebase. Overlap is composable inside one surface and rejected across independent surfaces so ownership cannot silently split.
|
||||
|
||||
Ordinary callers can use the same core without manually constructing runtime objects: `tp-propertize` returns a styled string copy, `tp-apply` applies declarations once to an existing buffer range, and `tp-watch` keeps an existing range's properties synchronized with signals. These calls accept native Emacs property declarations; callbacks such as `help-echo` remain literal values, while only explicitly wrapped `tp-computed` sources are evaluated by the cascade.
|
||||
|
||||
@ -545,7 +545,7 @@ A complete overview of all tp.el functions organized by category:
|
||||
| `tp-object-attach-fragment` / `tp-object-mounts` | Give one logical object disjoint output mounts and inspect defensive numeric range/tag snapshots |
|
||||
| `tp-range-anchor-create` / `tp-object-attach-range` / `tp-range-rebase` | Attach host-owned text ranges without putting positions in plans |
|
||||
| `tp-surface-materialize-string` | Render a plan or ephemeral producer without live identity, markers, or subscriptions |
|
||||
| `tp-surface-mount` / `tp-surface-update` / `tp-surface-unmount` | Own the only live publication lifecycle |
|
||||
| `tp-surface-mount` / `tp-surface-update` / `tp-surface-update-scoped` / `tp-surface-unmount` | Own the only live publication lifecycle, including object-scoped atomic updates |
|
||||
| `tp-surface-at-point` / `tp-surface-inspect` / `tp-surface-report` | Query retained side indexes and generic commit diagnostics without scanning text |
|
||||
|
||||
#### Convenience APIs
|
||||
|
||||
@ -200,6 +200,7 @@ tp 不会把外部属性收编成新的匿名层，也不会静默覆盖它。
|
||||
- producer 在 active prepare context 中先用 `tp-object-ensure` 取得 candidate handle，再返回 plan 或 `tp-surface-result-create`。成功 publication 才使新 handle live；失败、materialize 返回或 orphan/cross-surface validation 失败都会释放 candidate bindings、anchors 与 subscriptions。`tp-object-resolve` 只读 live key path，不创建 identity。
|
||||
- `tp-object-retain` 显式声明一个没有可见字符也应随 candidate 晋升的 logical object；未进入 plan、未 retain、也未 attachment 的 touched object 仍以 `tp-orphan-object` 拒绝。content producer 可用 `tp-object-attach-fragment` 把同一 logical object 挂到多个 plan fragment；attachment 只存在 prepare/side state，不进入 pure plan。`tp-object-mounts` 通过 object-keyed index 返回当前数值 start/end 与 opaque tags 的防御性快照，不暴露 live marker。
|
||||
- `content` capability 拥有一个 disjoint text span，使用 character common-prefix/suffix 与 direct-property run diff；外部字符编辑使其 stale。`properties` capability 不能携带 text，只能通过 `tp-object-attach-range` 写 attached anchor。host edit 位于 anchor 前方时 marker 正常移动；跨入 owned range 时按 boundary policy shorten/remove/stale。
|
||||
- `tp-surface-update-scoped` 接受同 surface 的 live object handles 和一个完整 candidate。scope 只在当前 transaction 内有效；TP 通过 object→mount index 得到授权范围，支持一个 logical object 的多个离散 mounts，并在 prepare 阶段证明 candidate 没有改变范围外输出。默认 mismatch 发出 `tp-scope-mismatch` 且零发布；只有显式 `(:on-mismatch root)` 才允许 full-root fallback。后续普通 reactive recompute 或 `tp-surface-update` 不继承这次 scope。
|
||||
- properties ledger 保存 baseline、last-published value 与 contribution anchors。prepare compare-before-write；外部 property override 触发 `tp-property-conflict` 且保持旧 revision。`tp-range-rebase` 显式接受当前 host runs 为新 baseline；unmount 只恢复仍等于 TP last-published value 的子区间，冲突子区间保持外部值并进入 report。
|
||||
- 同一 surface 的 overlapping properties contributions 按 plan order 和 native property schema merge；独立 surfaces 当前不得重叠字符 ownership。这个限制把 journal owner 保持为唯一 surface，避免两套 baseline 静默覆盖。
|
||||
- 最外层 transaction 先完成所有 producer/plan/conflict validation，再按 surface id publish，随后执行 transaction participants，最后提交 source values。multi-buffer change group 负责 text rollback，TP 的精确 property journal 覆盖 `with-silent-modifications`；失败先逆序撤销已经进入 publication 的 participants，再恢复 buffer direct properties、markers/index、objects、plan、client state、revision、bindings 与 signal values。publish 中 killed buffer 不复活，其他 surfaces 与 sources 回滚。
|
||||
|
||||
@ -183,6 +183,8 @@ Stage 2 canonical façade 是内部模型，不改变公开入口和历史返回
|
||||
|
||||
### tp-surface.el：retained publication owner
|
||||
|
||||
该模块拥有 surface/object identity、marker-backed mount index、range anchor、properties ledger、buffer diff、publication journal 与 revision。`tp-surface-update-scoped` 复用同一完整 candidate prepare 和同一事务发布器，只把 live object handles 解析成当前事务的授权范围；它不是子树 renderer，也不接受 Ebox owner、dirty kind、layout patch 或 raw marker。范围外输出变化在 prepare 阶段拒绝，显式 root fallback 除外。
|
||||
|
||||
只依赖 `tp-core`、`tp-style` 与 `tp-reactive`。它集中拥有 prepare context、candidate/live object identity、pure surface plan、content/properties capability、range anchor、logical object→多个 marker-backed mounts、object-keyed mount index、position→object side index、properties contribution ledger、text/property diff、multi-buffer change group、silent-property inverse journal、opaque client state、revision、generic report 和 buffer-kill lifecycle。没有可见字符的 logical object 必须显式 retain；不连续输出通过 prepare-only object→plan-fragment attachment 建立，plan 本身仍没有 handle 或 position。normal update 从 binding owner 直接取得 prepared surface，再从 object 直接取得 mounts；不读取 `buffer-list`，也不按 `tp-name`、`tp-layers` 或显示文本反查 identity。
|
||||
|
||||
`content` mount 可以替换其拥有的 disjoint span；外部字符编辑会使 mount stale。`properties` mount 只能修改 attached anchor 上声明的 direct properties；同一 surface 内重叠 contribution 通过 native property schema 合成。外部值与 TP last-published value 不同时，prepare 报 `tp-property-conflict`，调用者必须 `tp-range-rebase` 或 unmount。独立 surfaces 的字符范围当前必须不重叠，以保持单一、可证明的 ownership journal。
|
||||
@ -582,7 +584,7 @@ insert/copy/yank/stickiness/narrowing/indirect buffer 均不在 tp-query 中封
|
||||
| tp-core | —— | **无可变状态**（仅 `tp-debug-mode`/`tp-debug-echo` 两个用户选项；调试日志写入 *tp-debug* 缓冲区，由 `tp-debug-clear` 清除） | - |
|
||||
| tp-style | schema、named style、stylesheet rule、cascade layer/source order registries | 纯 style definition 和 rule 状态；不保存 object、buffer 或 mount | `tp-style-reset` / `tp-style-reset-rules` |
|
||||
| tp-reactive | signals、owner bindings、dependency subscriber sets、variable adapters、transaction-local scheduler state、public counters | TP 1.0 exact reactive graph；normal update 不扫描 buffer | `tp-reactive-reset`；buffer-scoped signal 随 buffer kill |
|
||||
| tp-surface | buffer-local surfaces、object/mount/index、range anchors、property ledgers、plan/client-state/revision/report | TP 1.0 retained publication；global registry 仅 weak-reference | `tp-surface-unmount`；buffer kill authoritative teardown |
|
||||
| tp-surface | buffer-local surfaces、object/mount/index、range anchors、property ledgers、root/scoped publication、plan/client-state/revision/report | TP 1.0 retained publication；global registry 仅 weak-reference | `tp-surface-unmount`；buffer kill authoritative teardown |
|
||||
| tp-reactive | `tp-reactive-deps` | 变量 → 依赖层 注册表 | `tp-reactive-reset` |
|
||||
| tp-reactive | `tp-layer-watchers` / `tp-layer-computed` / `tp-layer-data` / `tp-reactive-observer-errors` | `:watch` / `:compute` / `:data` 注册表与结构化 observer 错误 | `tp-reactive-reset` |
|
||||
| tp-reactive | `tp--batch-update-pending` | 批量更新队列（0.3.0 起也被 reset 清空，防止残留条目对新定义的层重放） | `tp-reactive-reset` |
|
||||
|
||||
@ -163,10 +163,13 @@ Both use the same schema/cascade/projector core without identity, bindings, or l
|
||||
```elisp
|
||||
(tp-surface-mount buffer plan-or-producer options)
|
||||
(tp-surface-update surface plan-or-producer)
|
||||
(tp-surface-update-scoped surface objects plan-or-producer options)
|
||||
(tp-surface-unmount surface)
|
||||
```
|
||||
|
||||
The full API also includes `tp-computed`, signals, prepare/object operations, bindings, range anchors, transactions, materialize-string, and at-point/inspect/report diagnostics. TP adds no overlapping `tp-mount`/`tp-update` aliases and exposes no raw marker, patch, change-set, or `:impact` API.
|
||||
`tp-surface-update-scoped` is a one-transaction authorization over retained object identity. TP resolves each object through its mount index, supports one object with several disjoint mounts, verifies that the full candidate changes no output outside the authorized ranges, and then publishes text, direct properties, mounts, indexes, client state, and revision in the same rollback boundary. Scope is not stored in text and is not a second reactive runtime. Mismatch signals by default; an explicit option may request a full-root fallback.
|
||||
|
||||
The full API also includes `tp-computed`, signals, prepare/object operations, bindings, range anchors, transactions, materialize-string, and at-point/inspect/report diagnostics. TP adds no overlapping `tp-mount`/`tp-update` aliases and exposes no raw marker, patch, change-set, domain dirty kind, or `:impact` API.
|
||||
|
||||
## 11. Standalone acceptance scenarios
|
||||
|
||||
|
||||
@ -163,10 +163,13 @@ transaction 顺序是：冻结 candidate signal writes；建立 prepare contexts
|
||||
```elisp
|
||||
(tp-surface-mount buffer plan-or-producer options)
|
||||
(tp-surface-update surface plan-or-producer)
|
||||
(tp-surface-update-scoped surface objects plan-or-producer options)
|
||||
(tp-surface-unmount surface)
|
||||
```
|
||||
|
||||
完整 API 还包括 `tp-computed`、signals、prepare/object、bindings、range anchors、transactions、materialize-string、at-point/inspect/report。TP 不增加含义重叠的 `tp-mount`/`tp-update` aliases，也不公开 raw marker/patch/change-set/`:impact` APIs。
|
||||
`tp-surface-update-scoped` 是一次事务内基于 retained object identity 的授权。TP 通过 mount index 解析对象，支持一个对象拥有多个离散 mount，验证完整 candidate 不会修改授权范围之外的输出，然后在同一回滚边界内发布 text、direct properties、mount、index、client state 和 revision。scope 不写入文本，也不会形成第二套响应式 runtime。默认 mismatch 直接报错；调用者可显式选择 full-root fallback。
|
||||
|
||||
完整 API 还包括 `tp-computed`、signals、prepare/object、bindings、range anchors、transactions、materialize-string、at-point/inspect/report。TP 不增加含义重叠的 `tp-mount`/`tp-update` aliases，也不公开 raw marker/patch/change-set、domain dirty kind 或 `:impact` APIs。
|
||||
|
||||
## 11. 独立验收场景
|
||||
|
||||
|
||||
@ -89,6 +89,271 @@
|
||||
(should (eq (get-text-property 1 'face buffer) 'italic))
|
||||
(should (= (plist-get (tp-surface-report surface) :text-operations) 1)))))
|
||||
|
||||
(ert-deftest tp-surface-test-scoped-content-update-publishes-one-object ()
|
||||
"A scoped update should replace only its retained object's mounted text."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((middle "B") middle-object)
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let ((root (tp-object-ensure context nil 'root 'group)))
|
||||
(tp-object-ensure context root 'left 'text)
|
||||
(setq middle-object
|
||||
(tp-object-ensure context root 'middle 'text))
|
||||
(tp-object-ensure context root 'right 'text))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(list (tp-surface-test--leaf 'left "A")
|
||||
(tp-surface-test--leaf 'middle middle)
|
||||
(tp-surface-test--leaf 'right "C")))))
|
||||
(surface
|
||||
(tp-surface-mount buffer producer '(:capability content)))
|
||||
(revision (tp-surface-revision surface)))
|
||||
(setq middle "LONG")
|
||||
(let ((report
|
||||
(tp-surface-update-scoped
|
||||
surface (list middle-object) producer)))
|
||||
(should (equal (buffer-string) "ALONGC"))
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should-not (plist-get report :full-root))
|
||||
(should (= (plist-get report :scope-count) 1))
|
||||
(should (= (plist-get report :scope-range-count) 1))
|
||||
(should (= (plist-get report :touched-characters) 4)))))))
|
||||
|
||||
(ert-deftest tp-surface-test-scoped-update-supports-disjoint-object-mounts ()
|
||||
"One logical scope should update all of its disjoint mounts atomically."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((left "A") (right "C") logical)
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let* ((root (tp-object-ensure context nil 'root 'group))
|
||||
(left-object
|
||||
(tp-object-ensure context root 'left 'text))
|
||||
(gap-object
|
||||
(tp-object-ensure context root 'gap 'text))
|
||||
(right-object
|
||||
(tp-object-ensure context root 'right 'text)))
|
||||
(setq logical
|
||||
(tp-object-ensure context root 'logical 'item))
|
||||
(tp-object-retain context logical)
|
||||
(tp-object-attach-fragment context logical left-object 'left)
|
||||
(tp-object-attach-fragment context logical right-object 'right)
|
||||
(ignore gap-object))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(list (tp-surface-test--leaf 'left left)
|
||||
(tp-surface-test--leaf 'gap "|")
|
||||
(tp-surface-test--leaf 'right right)))))
|
||||
(surface
|
||||
(tp-surface-mount buffer producer '(:capability content)))
|
||||
(revision (tp-surface-revision surface)))
|
||||
(setq left "LEFT" right "RIGHT")
|
||||
(let ((report
|
||||
(tp-surface-update-scoped surface (list logical) producer)))
|
||||
(should (equal (buffer-string) "LEFT|RIGHT"))
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should (= (plist-get report :scope-count) 1))
|
||||
(should (= (plist-get report :scope-range-count) 2))
|
||||
(should (= (plist-get report :text-operations) 2)))))))
|
||||
|
||||
(ert-deftest tp-surface-test-scoped-update-adds-and-removes-owned-output ()
|
||||
"A retained scope should add or remove its owned output between stable text."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((visible nil) logical)
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let* ((root (tp-object-ensure context nil 'root 'group))
|
||||
(left (tp-object-ensure context root 'left 'text))
|
||||
(middle (and visible
|
||||
(tp-object-ensure
|
||||
context root 'middle 'text))))
|
||||
(tp-object-ensure context root 'gap 'text)
|
||||
(tp-object-ensure context root 'right 'text)
|
||||
(setq logical
|
||||
(tp-object-ensure context root 'logical 'item))
|
||||
(tp-object-retain context logical)
|
||||
(when middle
|
||||
(tp-object-attach-fragment context logical middle 'owned))
|
||||
(ignore left))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(delq nil
|
||||
(list (tp-surface-test--leaf 'left "A")
|
||||
(and visible
|
||||
(tp-surface-test--leaf 'middle "B"))
|
||||
(tp-surface-test--leaf 'gap "|")
|
||||
(tp-surface-test--leaf 'right "C"))))))
|
||||
(surface
|
||||
(tp-surface-mount buffer producer '(:capability content))))
|
||||
(should (equal (buffer-string) "A|C"))
|
||||
(setq visible t)
|
||||
(let ((report
|
||||
(tp-surface-update-scoped surface (list logical) producer)))
|
||||
(should (equal (buffer-string) "AB|C"))
|
||||
(should (= (plist-get report :text-operations) 1)))
|
||||
(setq visible nil)
|
||||
(let ((report
|
||||
(tp-surface-update-scoped surface (list logical) producer)))
|
||||
(should (equal (buffer-string) "A|C"))
|
||||
(should (= (plist-get report :text-operations) 1)))))))
|
||||
|
||||
(ert-deftest tp-surface-test-scoped-update-survives-outer-transaction ()
|
||||
"A scoped request should remain attached until its outer transaction flushes."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((middle "B") middle-object)
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let ((root (tp-object-ensure context nil 'root 'group)))
|
||||
(tp-object-ensure context root 'left 'text)
|
||||
(setq middle-object
|
||||
(tp-object-ensure context root 'middle 'text))
|
||||
(tp-object-ensure context root 'right 'text))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(list (tp-surface-test--leaf 'left "A")
|
||||
(tp-surface-test--leaf 'middle middle)
|
||||
(tp-surface-test--leaf 'right "C")))))
|
||||
(surface
|
||||
(tp-surface-mount buffer producer '(:capability content))))
|
||||
(setq middle "LONG")
|
||||
(tp-with-transaction
|
||||
(tp-surface-update-scoped surface (list middle-object) producer))
|
||||
(should (equal (buffer-string) "ALONGC"))
|
||||
(should-not (plist-get (tp-surface-report surface) :full-root))
|
||||
(setq middle "NEXT")
|
||||
(tp-surface-update surface producer)
|
||||
(should (equal (buffer-string) "ANEXTC"))
|
||||
(should (plist-get (tp-surface-report surface) :full-root))))))
|
||||
|
||||
(ert-deftest tp-surface-test-scoped-properties-update-publishes-one-object ()
|
||||
"A properties scope should leave another retained range untouched."
|
||||
(tp-surface-test--with-buffer
|
||||
(insert "left|right")
|
||||
(let* ((left-anchor (tp-range-anchor-create buffer 1 5))
|
||||
(right-anchor (tp-range-anchor-create buffer 6 11))
|
||||
(left-face 'bold)
|
||||
left-object
|
||||
(producer
|
||||
(lambda (context)
|
||||
(let ((root (tp-object-ensure context nil 'root 'group)))
|
||||
(setq left-object
|
||||
(tp-object-ensure context root 'left 'range))
|
||||
(tp-object-attach-range context left-object left-anchor)
|
||||
(let ((right-object
|
||||
(tp-object-ensure context root 'right 'range)))
|
||||
(tp-object-attach-range context right-object right-anchor)))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'properties
|
||||
:children
|
||||
(list
|
||||
(tp-surface-plan-create
|
||||
:key 'left :kind 'range :props (list 'face left-face)
|
||||
:capability 'properties)
|
||||
(tp-surface-plan-create
|
||||
:key 'right :kind 'range :props '(face italic)
|
||||
:capability 'properties)))))
|
||||
(surface
|
||||
(tp-surface-mount buffer producer '(:capability properties))))
|
||||
(setq left-face 'underline)
|
||||
(let ((report
|
||||
(tp-surface-update-scoped surface (list left-object) producer)))
|
||||
(should (eq (get-text-property 2 'face) 'underline))
|
||||
(should (eq (get-text-property 7 'face) 'italic))
|
||||
(should-not (plist-get report :full-root))
|
||||
(should (= (plist-get report :scope-range-count) 1))
|
||||
(should (= (plist-get report :property-operations) 1))))))
|
||||
|
||||
(ert-deftest tp-surface-test-scoped-update-can-explicitly-fall-back-to-root ()
|
||||
"A scoped mismatch should publish the root only when explicitly requested."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((middle "B") (right "C") middle-object)
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let ((root (tp-object-ensure context nil 'root 'group)))
|
||||
(tp-object-ensure context root 'left 'text)
|
||||
(setq middle-object
|
||||
(tp-object-ensure context root 'middle 'text))
|
||||
(tp-object-ensure context root 'right 'text))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(list (tp-surface-test--leaf 'left "A")
|
||||
(tp-surface-test--leaf 'middle middle)
|
||||
(tp-surface-test--leaf 'right right)))))
|
||||
(surface
|
||||
(tp-surface-mount buffer producer '(:capability content))))
|
||||
(setq middle "M" right "OUTSIDE")
|
||||
(let ((report
|
||||
(tp-surface-update-scoped
|
||||
surface (list middle-object) producer
|
||||
'(:on-mismatch root))))
|
||||
(should (equal (buffer-string) "AMOUTSIDE"))
|
||||
(should (plist-get report :full-root))
|
||||
(should (plist-get report :scope-fallback)))))))
|
||||
|
||||
(ert-deftest tp-surface-test-scoped-update-rejects-outside-change ()
|
||||
"A scoped update should fail before publication when another range changes."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((middle "B") (right "C") middle-object)
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let ((root (tp-object-ensure context nil 'root 'group)))
|
||||
(tp-object-ensure context root 'left 'text)
|
||||
(setq middle-object
|
||||
(tp-object-ensure context root 'middle 'text))
|
||||
(tp-object-ensure context root 'right 'text))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(list (tp-surface-test--leaf 'left "A")
|
||||
(tp-surface-test--leaf 'middle middle)
|
||||
(tp-surface-test--leaf 'right right)))))
|
||||
(surface
|
||||
(tp-surface-mount buffer producer '(:capability content)))
|
||||
(revision (tp-surface-revision surface)))
|
||||
(setq middle "M" right "OUTSIDE")
|
||||
(should-error
|
||||
(tp-surface-update-scoped surface (list middle-object) producer)
|
||||
:type 'tp-scope-mismatch)
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(should (equal (buffer-string) "ABC"))))))
|
||||
|
||||
(ert-deftest tp-surface-test-scoped-update-rolls-back-buffer-and-mounts ()
|
||||
"A failed scoped publication should restore text, revision, and mounts."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((middle "B") middle-object)
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let ((root (tp-object-ensure context nil 'root 'group)))
|
||||
(tp-object-ensure context root 'left 'text)
|
||||
(setq middle-object
|
||||
(tp-object-ensure context root 'middle 'text))
|
||||
(tp-object-ensure context root 'right 'text))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(list (tp-surface-test--leaf 'left "A")
|
||||
(tp-surface-test--leaf 'middle middle)
|
||||
(tp-surface-test--leaf 'right "C")))))
|
||||
(surface
|
||||
(tp-surface-mount buffer producer '(:capability content)))
|
||||
(revision (tp-surface-revision surface))
|
||||
(mounts (tp-object-mounts middle-object)))
|
||||
(setq middle "LONG")
|
||||
(let ((tp--surface-publication-step-function
|
||||
(lambda (step _surface)
|
||||
(when (eq step 'client-state)
|
||||
(error "Injected scoped failure")))))
|
||||
(should-error
|
||||
(tp-surface-update-scoped surface (list middle-object) producer)))
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(should (equal (buffer-string) "ABC"))
|
||||
(should (eq middle-object (tp-object-resolve surface '(root middle))))
|
||||
(should (equal (tp-object-mounts middle-object) mounts))))))
|
||||
|
||||
(ert-deftest tp-surface-test-failed-candidate-does-not-leak-object ()
|
||||
"A failed update preserves the live tree and invalidates new handles."
|
||||
(tp-surface-test--with-buffer
|
||||
|
||||
361
tp-surface.el
361
tp-surface.el
@ -42,6 +42,8 @@
|
||||
(define-error 'tp-dead-surface "Dead TP surface" 'tp-surface-error)
|
||||
(define-error 'tp-invalid-range-anchor "Invalid TP range anchor"
|
||||
'tp-surface-error)
|
||||
(define-error 'tp-scope-mismatch "Scoped TP update changed outside its objects"
|
||||
'tp-surface-error)
|
||||
|
||||
(cl-defstruct (tp-surface-plan (:constructor tp--make-surface-plan))
|
||||
"Pure retained node data accepted by a TP surface."
|
||||
@ -89,7 +91,8 @@
|
||||
(cl-defstruct (tp--prepared-surface (:constructor tp--make-prepared-surface))
|
||||
surface context plan rendered mount-specs ledger-specs property-operations
|
||||
objects client-state producer initial created removed moved reconciled
|
||||
live-mounts live-mount-index live-ledger report)
|
||||
scope-objects scope-patches scope-fallback live-mounts live-mount-index
|
||||
live-ledger report)
|
||||
|
||||
(cl-defstruct (tp--surface-snapshot (:constructor tp--make-surface-snapshot))
|
||||
plan objects mounts index mount-index ledger client-state producer revision
|
||||
@ -617,13 +620,198 @@ marker-backed mounts after publication."
|
||||
(tp--ensure-plan-objects context plan)
|
||||
(tp--producer-result plan surface options)))))
|
||||
|
||||
(defun tp--normalize-surface-scopes (surface objects)
|
||||
"Return validated retained OBJECTS owned by SURFACE."
|
||||
(unless (and (proper-list-p objects) objects)
|
||||
(signal 'wrong-type-argument (list 'non-empty-proper-list-p objects)))
|
||||
(setq objects
|
||||
(cl-delete-duplicates (copy-sequence objects) :test #'eq))
|
||||
(dolist (object objects)
|
||||
(unless (tp-object-p object)
|
||||
(signal 'wrong-type-argument (list 'tp-object-p object)))
|
||||
(unless (tp-object-live-p object)
|
||||
(signal 'tp-stale-object (list object)))
|
||||
(unless (eq (tp--surface-object-surface object) surface)
|
||||
(signal 'tp-cross-surface-object (list object surface))))
|
||||
objects)
|
||||
|
||||
(defun tp--coalesce-ranges (ranges)
|
||||
"Return sorted, merged nonempty RANGES."
|
||||
(setq ranges
|
||||
(sort (cl-remove-if (lambda (range) (>= (car range) (cdr range)))
|
||||
(mapcar (lambda (range)
|
||||
(cons (car range) (cdr range)))
|
||||
ranges))
|
||||
(lambda (left right) (< (car left) (car right)))))
|
||||
(let (merged)
|
||||
(dolist (range ranges (nreverse merged))
|
||||
(if (and merged (<= (car range) (cdar merged)))
|
||||
(setcdr (car merged) (max (cdar merged) (cdr range)))
|
||||
(push range merged)))))
|
||||
|
||||
(defun tp--live-scope-ranges (surface objects &optional relative)
|
||||
"Return live mount ranges for OBJECTS on SURFACE.
|
||||
When RELATIVE is non-nil, return offsets from the surface start."
|
||||
(let ((base (if relative
|
||||
(marker-position (tp--surface-start surface))
|
||||
0))
|
||||
ranges)
|
||||
(dolist (object objects)
|
||||
(dolist (mount (gethash object (tp--surface-mount-index surface)))
|
||||
(let ((start (marker-position (tp--surface-mount-start mount)))
|
||||
(end (marker-position (tp--surface-mount-end mount))))
|
||||
(unless (and start end)
|
||||
(signal 'tp-stale-mount (list object)))
|
||||
(push (cons (- start base) (- end base)) ranges))))
|
||||
(tp--coalesce-ranges ranges)))
|
||||
|
||||
(defun tp--candidate-scope-ranges (mount-specs objects)
|
||||
"Return relative candidate MOUNT-SPECS ranges owned by OBJECTS."
|
||||
(let ((scope-set (make-hash-table :test #'eq)) ranges)
|
||||
(dolist (object objects) (puthash object t scope-set))
|
||||
(dolist (spec mount-specs)
|
||||
(when (gethash (plist-get spec :object) scope-set)
|
||||
(push (cons (plist-get spec :start) (plist-get spec :end)) ranges)))
|
||||
(tp--coalesce-ranges ranges)))
|
||||
|
||||
(defun tp--surface-content-string (surface)
|
||||
"Return SURFACE's current propertized content string."
|
||||
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
|
||||
(with-current-buffer (tp--surface-buffer surface)
|
||||
(save-restriction
|
||||
(widen)
|
||||
(buffer-substring start end)))))
|
||||
|
||||
(defun tp--complement-ranges (length ranges)
|
||||
"Return the nonempty complement of RANGES inside zero to LENGTH."
|
||||
(let ((cursor 0) complement)
|
||||
(dolist (range ranges)
|
||||
(when (< cursor (car range))
|
||||
(push (cons cursor (car range)) complement))
|
||||
(setq cursor (cdr range)))
|
||||
(when (< cursor length)
|
||||
(push (cons cursor length) complement))
|
||||
(nreverse complement)))
|
||||
|
||||
(defun tp--substring-ranges (string ranges)
|
||||
"Return STRING content from RANGES concatenated with properties."
|
||||
(apply #'concat
|
||||
(mapcar (lambda (range)
|
||||
(substring string (car range) (cdr range)))
|
||||
ranges)))
|
||||
|
||||
(defun tp--pair-outside-ranges (old-ranges new-ranges)
|
||||
"Pair equal-length pieces of OLD-RANGES and NEW-RANGES in order."
|
||||
(let ((old-ranges (copy-tree old-ranges))
|
||||
(new-ranges (copy-tree new-ranges))
|
||||
pairs)
|
||||
(while (and old-ranges new-ranges)
|
||||
(let* ((old (car old-ranges))
|
||||
(new (car new-ranges))
|
||||
(length (min (- (cdr old) (car old))
|
||||
(- (cdr new) (car new)))))
|
||||
(push (list (car old) (+ (car old) length)
|
||||
(car new) (+ (car new) length))
|
||||
pairs)
|
||||
(setcar old-ranges (cons (+ (car old) length) (cdr old)))
|
||||
(setcar new-ranges (cons (+ (car new) length) (cdr new)))
|
||||
(when (= (caar old-ranges) (cdar old-ranges)) (pop old-ranges))
|
||||
(when (= (caar new-ranges) (cdar new-ranges)) (pop new-ranges))))
|
||||
(nreverse pairs)))
|
||||
|
||||
(defun tp--scope-patches-between-anchors (old new anchors)
|
||||
"Return changes between equal outside ANCHORS in OLD and NEW."
|
||||
(let ((old-position 0) (new-position 0) patches)
|
||||
(dolist (anchor (append anchors
|
||||
(list (list (length old) (length old)
|
||||
(length new) (length new)))))
|
||||
(let* ((old-end (nth 0 anchor))
|
||||
(new-end (nth 2 anchor))
|
||||
(replacement (substring new new-position new-end)))
|
||||
(unless (equal-including-properties
|
||||
(substring old old-position old-end) replacement)
|
||||
(push (list :old-start old-position :old-end old-end
|
||||
:new-start new-position :new-end new-end
|
||||
:replacement replacement)
|
||||
patches)))
|
||||
(setq old-position (nth 1 anchor)
|
||||
new-position (nth 3 anchor)))
|
||||
(nreverse patches)))
|
||||
|
||||
(defun tp--scope-replacement-analysis (old new old-ranges new-ranges)
|
||||
"Return scoped replacement metadata from OLD to NEW, or nil on mismatch."
|
||||
(let* ((old-outside (tp--complement-ranges (length old) old-ranges))
|
||||
(new-outside (tp--complement-ranges (length new) new-ranges)))
|
||||
(when (equal-including-properties
|
||||
(tp--substring-ranges old old-outside)
|
||||
(tp--substring-ranges new new-outside))
|
||||
(list :patches
|
||||
(tp--scope-patches-between-anchors
|
||||
old new (tp--pair-outside-ranges old-outside new-outside))))))
|
||||
|
||||
(defun tp--prepare-content-scope
|
||||
(surface rendered mount-specs objects options)
|
||||
"Return scoped publication metadata for RENDERED on SURFACE.
|
||||
MOUNT-SPECS describe the candidate OBJECTS. OPTIONS accepts
|
||||
`:on-mismatch' as `error' or `root'."
|
||||
(let* ((old (tp--surface-content-string surface))
|
||||
(old-ranges (tp--live-scope-ranges surface objects t))
|
||||
(new-ranges (tp--candidate-scope-ranges mount-specs objects))
|
||||
(analysis
|
||||
(tp--scope-replacement-analysis
|
||||
old rendered old-ranges new-ranges)))
|
||||
(cond
|
||||
(analysis (list :patches (plist-get analysis :patches) :fallback nil))
|
||||
((eq (plist-get options :on-mismatch) 'root)
|
||||
(list :patches nil :fallback t))
|
||||
(t
|
||||
(signal 'tp-scope-mismatch
|
||||
(list :surface (tp--surface-id surface)
|
||||
:old-ranges old-ranges :new-ranges new-ranges))))))
|
||||
|
||||
(defun tp--range-contained-in-p (start end ranges)
|
||||
"Return non-nil when START..END is inside one of RANGES."
|
||||
(cl-some (lambda (range)
|
||||
(and (<= (car range) start) (<= end (cdr range))))
|
||||
ranges))
|
||||
|
||||
(defun tp--prepare-properties-scope
|
||||
(surface mount-specs operations objects options)
|
||||
"Validate scoped property OPERATIONS for OBJECTS on SURFACE.
|
||||
MOUNT-SPECS describe the candidate object ranges and OPTIONS controls mismatch."
|
||||
(let* ((old-ranges (tp--live-scope-ranges surface objects))
|
||||
(new-ranges (tp--candidate-scope-ranges mount-specs objects))
|
||||
(ranges (tp--coalesce-ranges
|
||||
(append old-ranges new-ranges)))
|
||||
(outside
|
||||
(cl-find-if
|
||||
(lambda (operation)
|
||||
(not (tp--range-contained-in-p
|
||||
(plist-get operation :start) (plist-get operation :end)
|
||||
ranges)))
|
||||
operations)))
|
||||
(cond
|
||||
((not outside) (list :patches ranges :fallback nil))
|
||||
((eq (plist-get options :on-mismatch) 'root)
|
||||
(list :patches nil :fallback t))
|
||||
(t
|
||||
(signal 'tp-scope-mismatch
|
||||
(list :surface (tp--surface-id surface)
|
||||
:operation outside :ranges ranges))))))
|
||||
|
||||
(defun tp--prepare-surface (surface input options initial)
|
||||
"Prepare INPUT for SURFACE without publishing it.
|
||||
OPTIONS configure the mount and INITIAL is non-nil for first publication."
|
||||
(tp--validate-surface-buffer surface initial)
|
||||
(when (and (not initial) (tp--surface-stale surface))
|
||||
(signal 'tp-stale-mount (list (tp--surface-id surface))))
|
||||
(let* ((context (tp--make-context surface))
|
||||
(let* ((scope-request (tp--surface-scope-request surface))
|
||||
(context (tp--make-context surface))
|
||||
(scope-objects
|
||||
(and scope-request
|
||||
(tp--normalize-surface-scopes
|
||||
surface (plist-get scope-request :objects))))
|
||||
(scope-options (plist-get scope-request :options))
|
||||
(success nil)
|
||||
result)
|
||||
(unwind-protect
|
||||
@ -646,7 +834,16 @@ OPTIONS configure the mount and INITIAL is non-nil for first publication."
|
||||
surface mount-specs rendered))
|
||||
(property-result
|
||||
(when (eq (tp--surface-capability surface) 'properties)
|
||||
(tp--prepare-property-ledger surface mount-specs))))
|
||||
(tp--prepare-property-ledger surface mount-specs)))
|
||||
(scope-analysis
|
||||
(when scope-objects
|
||||
(if (eq (tp--surface-capability surface) 'content)
|
||||
(tp--prepare-content-scope
|
||||
surface rendered mount-specs scope-objects
|
||||
scope-options)
|
||||
(tp--prepare-properties-scope
|
||||
surface mount-specs (cdr property-result) scope-objects
|
||||
scope-options)))))
|
||||
(setq result
|
||||
(tp--make-prepared-surface
|
||||
:surface surface :context context :plan plan :rendered rendered
|
||||
@ -655,7 +852,10 @@ OPTIONS configure the mount and INITIAL is non-nil for first publication."
|
||||
:client-state client-state :producer input :initial initial
|
||||
:created created :removed removed
|
||||
:moved (tp--plan-moved-count (tp--surface-plan surface) plan)
|
||||
:reconciled (- (length objects) (length created))))
|
||||
:reconciled (- (length objects) (length created))
|
||||
:scope-objects scope-objects
|
||||
:scope-patches (plist-get scope-analysis :patches)
|
||||
:scope-fallback (plist-get scope-analysis :fallback)))
|
||||
(setq success t)
|
||||
result)
|
||||
(unless success (tp--discard-context context)))))
|
||||
@ -945,6 +1145,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
|
||||
|
||||
(defun tp--install-surface-producer (surface input options initial)
|
||||
"Install INPUT as SURFACE's producer binding."
|
||||
(tp--clear-surface-scope-request surface)
|
||||
(let ((binding
|
||||
(tp-bind surface tp--surface-producer-key
|
||||
(tp--surface-compute-function surface input options initial)
|
||||
@ -1017,6 +1218,30 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
surface plan-or-producer (tp--surface-options surface) nil)
|
||||
(tp-surface-report surface))
|
||||
|
||||
;;;###autoload
|
||||
(defun tp-surface-update-scoped
|
||||
(surface objects plan-or-producer &optional options)
|
||||
"Atomically update SURFACE within retained OBJECTS.
|
||||
PLAN-OR-PRODUCER has the same full candidate contract as
|
||||
`tp-surface-update'. TP resolves OBJECTS through its mount index and rejects
|
||||
any candidate output change outside their ranges before publication.
|
||||
|
||||
OPTIONS accepts `:on-mismatch'. Its default, `error', signals
|
||||
`tp-scope-mismatch'; `root' permits an explicit full-surface fallback."
|
||||
(tp--validate-live-surface surface)
|
||||
(setq objects (tp--normalize-surface-scopes surface objects))
|
||||
(let ((on-mismatch (or (plist-get options :on-mismatch) 'error)))
|
||||
(unless (memq on-mismatch '(error root))
|
||||
(signal 'wrong-type-argument
|
||||
(list '(member error root) on-mismatch)))
|
||||
(tp--call-with-transaction
|
||||
(lambda ()
|
||||
(tp--install-surface-producer
|
||||
surface plan-or-producer (tp--surface-options surface) nil)
|
||||
(tp--set-surface-scope-request
|
||||
surface objects (list :on-mismatch on-mismatch)))))
|
||||
(tp-surface-report surface))
|
||||
|
||||
(defun tp--edit-touches-span-p (beg old-length start end)
|
||||
"Return non-nil when an external edit at BEG touches START..END."
|
||||
(if (zerop old-length)
|
||||
@ -1068,6 +1293,33 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
"Return the surface extension state for the active transaction."
|
||||
(tp--transaction-extension tp--surface-extension-key t))
|
||||
|
||||
(defun tp--surface-scope-table (&optional create)
|
||||
"Return the transaction-local scope table, creating it when CREATE is non-nil."
|
||||
(when-let ((state (tp--transaction-extension
|
||||
tp--surface-extension-key create)))
|
||||
(or (gethash 'scopes state)
|
||||
(when create
|
||||
(let ((table (make-hash-table :test #'eq)))
|
||||
(puthash 'scopes table state)
|
||||
table)))))
|
||||
|
||||
(defun tp--surface-scope-request (surface)
|
||||
"Return SURFACE's one-shot scope request in the active transaction."
|
||||
(when-let ((table (tp--surface-scope-table)))
|
||||
(gethash surface table)))
|
||||
|
||||
(defun tp--clear-surface-scope-request (surface)
|
||||
"Clear SURFACE's pending one-shot scope request when one exists."
|
||||
(when tp--transaction-active
|
||||
(when-let ((table (tp--surface-scope-table)))
|
||||
(remhash surface table))))
|
||||
|
||||
(defun tp--set-surface-scope-request (surface objects options)
|
||||
"Set SURFACE's one-shot scope request to OBJECTS and OPTIONS."
|
||||
(puthash surface
|
||||
(list :objects (copy-sequence objects) :options (copy-tree options))
|
||||
(tp--surface-scope-table t)))
|
||||
|
||||
(defun tp--surface-prepared-table ()
|
||||
"Return the transaction-local surface candidate table."
|
||||
(let ((state (tp--surface-extension-state)))
|
||||
@ -1193,15 +1445,12 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
thereis (not (equal (text-properties-at (+ start offset) buffer)
|
||||
(text-properties-at offset rendered)))))
|
||||
|
||||
(defun tp--content-property-operations (surface rendered)
|
||||
"Return exact direct-property operations for SURFACE and RENDERED."
|
||||
(let* ((buffer (tp--surface-buffer surface))
|
||||
(start (marker-position (tp--surface-start surface)))
|
||||
(length (length rendered))
|
||||
(offset 0)
|
||||
operations)
|
||||
(while (< offset length)
|
||||
(let* ((next (next-property-change offset rendered length))
|
||||
(defun tp--content-property-operations-in-range
|
||||
(buffer start rendered from to)
|
||||
"Return property operations for RENDERED FROM..TO at BUFFER position START."
|
||||
(let ((offset from) operations)
|
||||
(while (< offset to)
|
||||
(let* ((next (next-property-change offset rendered to))
|
||||
(props (text-properties-at offset rendered)))
|
||||
(when (tp--string-property-run-diff-p
|
||||
buffer start rendered offset next)
|
||||
@ -1211,6 +1460,20 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(setq offset next)))
|
||||
(nreverse operations)))
|
||||
|
||||
(defun tp--content-property-operations
|
||||
(surface rendered &optional ranges scoped)
|
||||
"Return exact direct-property operations for SURFACE and RENDERED.
|
||||
When SCOPED is non-nil, inspect only RANGES, including an empty set."
|
||||
(let* ((buffer (tp--surface-buffer surface))
|
||||
(start (marker-position (tp--surface-start surface)))
|
||||
(ranges (if scoped ranges (list (cons 0 (length rendered)))))
|
||||
operations)
|
||||
(dolist (range ranges operations)
|
||||
(setq operations
|
||||
(nconc operations
|
||||
(tp--content-property-operations-in-range
|
||||
buffer start rendered (car range) (cdr range)))))))
|
||||
|
||||
(defun tp--apply-content-property-operations (buffer operations)
|
||||
"Apply content property OPERATIONS in BUFFER silently."
|
||||
(with-current-buffer buffer
|
||||
@ -1330,7 +1593,17 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
"Build PREPARED's generic commit report."
|
||||
(let* ((surface (tp--prepared-surface-surface prepared))
|
||||
(old-revision (tp--surface-revision surface))
|
||||
(new-revision (1+ old-revision)))
|
||||
(new-revision (1+ old-revision))
|
||||
(scoped (tp--prepared-surface-scope-objects prepared))
|
||||
(fallback (tp--prepared-surface-scope-fallback prepared))
|
||||
(patches (tp--prepared-surface-scope-patches prepared))
|
||||
(touched
|
||||
(if (and scoped (not fallback))
|
||||
(cl-loop for patch in patches
|
||||
sum (if (eq (tp--surface-capability surface) 'content)
|
||||
(length (plist-get patch :replacement))
|
||||
(- (cdr patch) (car patch))))
|
||||
(length (tp--prepared-surface-rendered prepared)))))
|
||||
(list :transaction-id tp--surface-transaction-id
|
||||
:surface-id (tp--surface-id surface)
|
||||
:old-revision old-revision :new-revision new-revision
|
||||
@ -1343,15 +1616,48 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
:removed-objects (length (tp--prepared-surface-removed prepared))
|
||||
:moved-objects (tp--prepared-surface-moved prepared)
|
||||
:text-operations text-ops :property-operations property-ops
|
||||
:touched-characters (length (tp--prepared-surface-rendered prepared))
|
||||
:full-root t :property-conflicts nil :rolled-back nil
|
||||
:touched-characters touched
|
||||
:full-root (or (null scoped) fallback)
|
||||
:scope-count (length scoped)
|
||||
:scope-range-count (and scoped (length patches))
|
||||
:scope-fallback fallback
|
||||
:property-conflicts nil :rolled-back nil
|
||||
:failure nil :observer-errors nil :timing nil)))
|
||||
|
||||
(defun tp--scoped-content-ranges (patches)
|
||||
"Return candidate relative ranges from scoped PATCHES."
|
||||
(mapcar (lambda (patch)
|
||||
(cons (plist-get patch :new-start)
|
||||
(plist-get patch :new-end)))
|
||||
patches))
|
||||
|
||||
(defun tp--publish-scoped-content-text (surface rendered patches)
|
||||
"Publish scoped PATCHES from RENDERED for SURFACE.
|
||||
Return the number of text operations."
|
||||
(let ((base (marker-position (tp--surface-start surface)))
|
||||
(count 0))
|
||||
(dolist (patch (reverse patches))
|
||||
(let* ((start (+ base (plist-get patch :old-start)))
|
||||
(end (+ base (plist-get patch :old-end)))
|
||||
(replacement (plist-get patch :replacement))
|
||||
(plain (substring-no-properties replacement)))
|
||||
(unless (equal (buffer-substring-no-properties start end) plain)
|
||||
(delete-region start end)
|
||||
(goto-char start)
|
||||
(insert plain)
|
||||
(cl-incf count))))
|
||||
(set-marker (tp--surface-start surface) base)
|
||||
(set-marker (tp--surface-end surface) (+ base (length rendered)))
|
||||
count))
|
||||
|
||||
(defun tp--publish-buffer-content (prepared)
|
||||
"Publish PREPARED's text and properties, returning operation counts."
|
||||
(let* ((surface (tp--prepared-surface-surface prepared))
|
||||
(buffer (tp--surface-buffer surface))
|
||||
(rendered (tp--prepared-surface-rendered prepared))
|
||||
(scoped (tp--prepared-surface-scope-objects prepared))
|
||||
(fallback (tp--prepared-surface-scope-fallback prepared))
|
||||
(patches (tp--prepared-surface-scope-patches prepared))
|
||||
(text-operations 0)
|
||||
property-operations)
|
||||
(with-current-buffer buffer
|
||||
@ -1360,10 +1666,17 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(let ((inhibit-read-only
|
||||
(plist-get (tp--surface-options surface) :inhibit-read-only)))
|
||||
(setq text-operations
|
||||
(tp--content-text-operation surface rendered))
|
||||
(if (and scoped (not fallback))
|
||||
(tp--publish-scoped-content-text
|
||||
surface rendered patches)
|
||||
(tp--content-text-operation surface rendered)))
|
||||
(tp--publication-step 'text surface)
|
||||
(setq property-operations
|
||||
(tp--content-property-operations surface rendered))
|
||||
(tp--content-property-operations
|
||||
surface rendered
|
||||
(and scoped (not fallback)
|
||||
(tp--scoped-content-ranges patches))
|
||||
(and scoped (not fallback))))
|
||||
(tp--apply-content-property-operations buffer property-operations)
|
||||
(tp--publication-step 'property surface))))
|
||||
(cons text-operations (length property-operations))))
|
||||
@ -1437,8 +1750,16 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(dolist (prepared prepared-list)
|
||||
(let ((surface (tp--prepared-surface-surface prepared)))
|
||||
(if (eq (tp--surface-capability surface) 'content)
|
||||
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
|
||||
(push (list (tp--surface-buffer surface) start end) entries))
|
||||
(if (and (tp--prepared-surface-scope-objects prepared)
|
||||
(not (tp--prepared-surface-scope-fallback prepared)))
|
||||
(let ((base (marker-position (tp--surface-start surface))))
|
||||
(dolist (patch (tp--prepared-surface-scope-patches prepared))
|
||||
(push (list (tp--surface-buffer surface)
|
||||
(+ base (plist-get patch :old-start))
|
||||
(+ base (plist-get patch :old-end)))
|
||||
entries)))
|
||||
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
|
||||
(push (list (tp--surface-buffer surface) start end) entries)))
|
||||
(dolist (operation
|
||||
(tp--prepared-surface-property-operations prepared))
|
||||
(push (list (tp--surface-buffer surface)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user