feat(tp): support disjoint logical object mounts
Allow retained logical objects to own multiple marker-backed output fragments without leaking handles or positions into pure plans. Expose only defensive numeric mount snapshots through the public object index. Verified: 718 ERT tests, 92 doctests, WERROR compile-all, checkdoc, and git diff --check.
This commit is contained in:
Kinneyzhang
parent
8d108403ad
commit
e3d7d1dfc6
@ -6,6 +6,7 @@ All notable changes to the tp library are documented here.
|
||||
|
||||
### Added
|
||||
|
||||
- Retained content surfaces now support explicitly retained logical objects and `tp-object-attach-fragment`, so one stable object can own several disjoint marker-backed output fragments without putting runtime handles or positions into the pure plan. `tp-object-mounts` exposes defensive numeric range/tag snapshots through an object-keyed side index.
|
||||
- `tp-transaction-participate` lets a client promote rollback-capable opaque side state after all affected surfaces publish but before source values commit. Participant keys are unique per outer transaction, failure rolls participants back in reverse publication order, and observers still run only after the transaction exits.
|
||||
- `tp-propertize`, `tp-apply`, and `tp-watch` now provide simple one-shot string, one-shot buffer-range, and reactive existing-text entry points over the same schema/cascade/projector and retained properties-surface core.
|
||||
- TP 1.0 retained surfaces now provide defensive pure plans, prepare-scoped object identity, keyed/positional reconciliation, `content` and `properties` capabilities, marker-backed range anchors, same-surface overlapping property contributions, compare-before-write conflicts and explicit rebase, common-prefix/suffix text edits, property-run diffs, side indexes, opaque client state, generic reports, lifecycle cleanup, and atomic multi-buffer publication with exact rollback. Pure materialization uses the same plan semantics without leaving live handles or subscriptions.
|
||||
|
||||
@ -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. 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. `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.
|
||||
|
||||
@ -541,7 +541,8 @@ A complete overview of all tp.el functions organized by category:
|
||||
| Function | Description |
|
||||
|----------|-------------|
|
||||
| `tp-surface-plan-create` / `tp-surface-result-create` | Build defensive pure plan data and attach optional opaque client state |
|
||||
| `tp-object-ensure` / `tp-object-resolve` | Allocate candidate identity during prepare or resolve committed identity by key path |
|
||||
| `tp-object-ensure` / `tp-object-retain` / `tp-object-resolve` | Allocate candidate identity, explicitly retain a logical object, or resolve committed identity by key path |
|
||||
| `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 |
|
||||
|
||||
@ -177,7 +177,7 @@ TP 1.0 迁移已经从纯 schema-driven cascade kernel 开始。`tp-style.el`
|
||||
|
||||
`tp-reactive.el` 现在也提供 TP 1.0 的精确依赖 runtime：signal 只 invalidates 真实订阅的 binding，binding read 建立 memoized binding→binding edge，条件计算会替换已经失效的旧依赖，最外层 `tp-with-transaction` 对每个 dirty binding 最多 flush 一次。candidate signal write 与 binding value/dependencies 一起提交；compute、cycle、publication 或 transaction participant 失败时一起回滚。`tp-transaction-participate` 允许 client 在 surface 发布后晋升 opaque side state，同时为同一 rollback boundary 提供逆操作。global 和 buffer-local variable adapter 复用同一 graph，不再把文本属性或 buffer scan 当作新 runtime database。
|
||||
|
||||
`tp-surface.el` 补全了从 object identity 到 marker-backed mount 和 buffer 的 retained publication 路径。producer 获得短生命周期 prepare context，在计算输出前确保 candidate object，并返回防御性 pure plan 与可选 opaque client state。TP 在 publication 前验证整个 candidate，执行 common-prefix/suffix text edit 与 property-run diff，并以同一个 revision 切换 plan/index/client state；失败时把所有受影响 buffer 与 signal 一起回滚。`content` 拥有一个不重叠的文本 span；`properties` 装饰 attached host range，检测外部 property conflict，并要求显式 rebase。同一 surface 内的 overlap 可以合成；独立 surface 之间的 overlap 会被拒绝，避免所有权静默分裂。
|
||||
`tp-surface.el` 补全了从 object identity 到 marker-backed mount 和 buffer 的 retained publication 路径。producer 获得短生命周期 prepare context，在计算输出前确保 candidate object，并返回防御性 pure plan 与可选 opaque client state。logical object 可以在没有可见输出时被显式保留，也可以挂到多个不连续 plan fragment；plan 仍不包含 runtime handle 或 position，`tp-object-mounts` 则从 side state 直接解析当前数值范围。TP 在 publication 前验证整个 candidate，执行 common-prefix/suffix text edit 与 property-run diff，并以同一个 revision 切换 plan/index/client state；失败时把所有受影响 buffer 与 signal 一起回滚。`content` 拥有一个不重叠的文本 span；`properties` 装饰 attached host range，检测外部 property conflict，并要求显式 rebase。同一 surface 内的 overlap 可以合成；独立 surface 之间的 overlap 会被拒绝，避免所有权静默分裂。
|
||||
|
||||
普通调用者不必手工构造 runtime object，也能使用同一个 core：`tp-propertize` 返回带样式的字符串副本，`tp-apply` 把声明一次性应用到已有 buffer range，`tp-watch` 则让已有 range 的属性随 signal 保持同步。这些入口接受 Emacs 原生 property declarations；`help-echo` 等 callback 保持 literal value，只有显式包装的 `tp-computed` source 才由 cascade 求值。
|
||||
|
||||
@ -536,7 +536,8 @@ tp.el 所有函数按类别组织的完整概览：
|
||||
| 函数 | 描述 |
|
||||
|------|------|
|
||||
| `tp-surface-plan-create` / `tp-surface-result-create` | 构造防御性 pure plan data，并附带可选 opaque client state |
|
||||
| `tp-object-ensure` / `tp-object-resolve` | 在 prepare 中分配 candidate identity，或按 key path 解析 committed identity |
|
||||
| `tp-object-ensure` / `tp-object-retain` / `tp-object-resolve` | 分配 candidate identity、显式保留 logical object，或按 key path 解析 committed identity |
|
||||
| `tp-object-attach-fragment` / `tp-object-mounts` | 让一个 logical object 拥有不连续 output mounts，并读取防御性的数值 range/tag snapshot |
|
||||
| `tp-range-anchor-create` / `tp-object-attach-range` / `tp-range-rebase` | 挂载 host-owned text range，不把 position 放进 plan |
|
||||
| `tp-surface-materialize-string` | 物化 plan 或 ephemeral producer，不留下 live identity、marker 或 subscription |
|
||||
| `tp-surface-mount` / `tp-surface-update` / `tp-surface-unmount` | 唯一 live publication lifecycle |
|
||||
|
||||
@ -198,6 +198,7 @@ tp 不会把外部属性收编成新的匿名层，也不会静默覆盖它。
|
||||
|
||||
- `tp-surface-plan-create` 只接受 key/kind/text/props/children/tags/capability 纯数据；text 与 children 互斥，同一 parent 的显式 key 不可重复，constructor 与每次 prepare 都做 defensive copy。普通 function property value 保持 literal identity，plan 不携带 marker、position、binding 或 producer closure。
|
||||
- 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。
|
||||
- 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 静默覆盖。
|
||||
|
||||
@ -183,7 +183,7 @@ Stage 2 canonical façade 是内部模型，不改变公开入口和历史返回
|
||||
|
||||
### tp-surface.el：retained publication owner
|
||||
|
||||
只依赖 `tp-core`、`tp-style` 与 `tp-reactive`。它集中拥有 prepare context、candidate/live object identity、pure surface plan、content/properties capability、range anchor、object→mount 与 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。normal update 从 binding owner 直接取得 prepared surface，再从 object 直接取得 mounts；不读取 `buffer-list`，也不按 `tp-name`、`tp-layers` 或显示文本反查 identity。
|
||||
只依赖 `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。
|
||||
|
||||
|
||||
@ -93,7 +93,7 @@ A definition is a reusable recipe; a binding is a concrete computation installed
|
||||
|
||||
Before recomputation TP removes old dependencies; after success the actual set read this time becomes authoritative, so conditional branches release unused sources. A transaction dirty queue deduplicates invalidations and recomputes one binding at most once per batch. Cycles report the complete path.
|
||||
|
||||
Prepare records touched objects and bindings. Removing an object cleans up its bindings, subscriptions, anchors, and mounts in the same publication. A surviving binding omitted from the current declaration is removed by default unless an explicit lifecycle policy retains it. Ordinary bindings may return arbitrary client values; only designated producer bindings return plans or subplans.
|
||||
Prepare records touched objects and bindings. A logical object with no visible characters must be retained explicitly; one logical object may use prepare-only attachments to own several disjoint plan fragments without putting those attachments in the plan. Removing an object cleans up its bindings, subscriptions, anchors, and mounts in the same publication. A surviving binding omitted from the current declaration is removed by default unless an explicit lifecycle policy retains it. Ordinary bindings may return arbitrary client values; only designated producer bindings return plans or subplans.
|
||||
|
||||
## 7. Surface plans
|
||||
|
||||
@ -131,7 +131,7 @@ Live markers follow host text editing. An edit crossing or deleting an anchor bo
|
||||
|
||||
## 9. Reconciliation and transactions
|
||||
|
||||
TP reconciles object identity by parent/key and computes child insert/remove/reorder, text diff, and property-run diff between old and new plans. A normal update resolves ranges directly through the object-to-mount index.
|
||||
TP reconciles object identity by parent/key and computes child insert/remove/reorder, text diff, and property-run diff between old and new plans. A normal update resolves one or more ranges directly through the object-to-mount index; public queries expose numeric range/tag snapshots rather than live markers.
|
||||
|
||||
A transaction freezes candidate signal writes; creates prepare contexts; prepares every actually affected surface; validates capabilities, conflicts, and lifecycle; creates per-surface operations and inverse journals; publishes in stable surface-id order; then atomically swaps source values, bindings, plans, indexes, client state, and revisions. Observers run only after every surface succeeds.
|
||||
|
||||
|
||||
@ -93,7 +93,7 @@ definition 是可复用配方，binding 是安装在一个 object 上的具体
|
||||
|
||||
重新计算前撤销旧依赖，成功后以本次实际读取集合替换。conditional branch 因而会自动断开不再使用的 source。transaction dirty queue 去重，同一 binding 每批最多重算一次；循环报告完整路径。
|
||||
|
||||
每次 prepare 记录 touched object/binding。删除 object 时同步清理 bindings、subscriptions、anchors 和 mounts；仍存在但本次未声明的 binding 默认删除，只有显式 lifecycle policy 才能保留。普通 binding 可返回任意 client value，只有 designated producer binding 返回 plan/subplan。
|
||||
每次 prepare 记录 touched object/binding。没有可见字符但仍属于 candidate 的 logical object 必须显式 retain；一个 logical object 可以通过 prepare-only attachment 对应多个不连续 plan fragment，attachment 不进入 plan。删除 object 时同步清理 bindings、subscriptions、anchors 和 mounts；仍存在但本次未声明的 binding 默认删除，只有显式 lifecycle policy 才能保留。普通 binding 可返回任意 client value，只有 designated producer binding 返回 plan/subplan。
|
||||
|
||||
## 7. Surface plan
|
||||
|
||||
@ -131,7 +131,7 @@ host text 编辑由 live markers 跟随。跨越或删除 anchor 边界时按显
|
||||
|
||||
## 9. Reconcile 与 transaction
|
||||
|
||||
TP 按 parent/key reconcile object identity，并对 old/new plan 计算 child insert/remove/reorder、text diff 和 property-run diff。normal update 从 object→mount index 直接取得范围。
|
||||
TP 按 parent/key reconcile object identity，并对 old/new plan 计算 child insert/remove/reorder、text diff 和 property-run diff。normal update 从 object→mount index 直接取得一个或多个范围；公开查询只返回数值 range/tag snapshot，不暴露 live marker。
|
||||
|
||||
transaction 顺序是：冻结 candidate signal writes；建立 prepare contexts；准备所有实际受影响 surfaces；验证 capability/conflict/lifecycle；生成 per-surface operations 与 inverse journals；按稳定 surface id publish；最后原子切换 source values、bindings、plans、indexes、client state 和 revisions；全部成功后才运行 observers。
|
||||
|
||||
|
||||
@ -109,6 +109,104 @@
|
||||
(should (eq root (tp-object-resolve surface '(root))))
|
||||
(should-not (tp-object-live-p candidate)))))
|
||||
|
||||
(ert-deftest tp-surface-test-logical-object-can-own-disjoint-fragments ()
|
||||
"One retained object can resolve several output fragments without scans."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((first "A") (second "BC"))
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let* ((root (tp-object-ensure context nil 'root 'group))
|
||||
(logical
|
||||
(tp-object-ensure context root 'logical 'item))
|
||||
(left
|
||||
(tp-object-ensure context root 'left 'fragment))
|
||||
(right
|
||||
(tp-object-ensure context root 'right 'fragment)))
|
||||
(tp-object-retain context logical)
|
||||
(tp-object-attach-fragment
|
||||
context logical left '(:slot left))
|
||||
(tp-object-attach-fragment
|
||||
context logical right '(:slot right)))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(list (tp-surface-test--leaf 'left first)
|
||||
(tp-surface-test--leaf 'right second)))))
|
||||
(surface (tp-surface-mount
|
||||
buffer producer '(:capability content)))
|
||||
(logical (tp-object-resolve surface '(root logical))))
|
||||
(should (tp-object-live-p logical))
|
||||
(should (equal (tp-object-mounts logical)
|
||||
'((:start 1 :end 2 :tags (:slot left))
|
||||
(:start 2 :end 4 :tags (:slot right)))))
|
||||
(should (memq logical (tp-surface-at-point 1 buffer)))
|
||||
(should (memq logical (tp-surface-at-point 3 buffer)))
|
||||
(setq first "AA" second "BBB")
|
||||
(cl-letf (((symbol-function 'buffer-list)
|
||||
(lambda (&rest _) (error "Unexpected buffer scan")))
|
||||
((symbol-function 'text-property-search-forward)
|
||||
(lambda (&rest _) (error "Unexpected property scan"))))
|
||||
(tp-surface-update surface producer))
|
||||
(should (eq logical (tp-object-resolve surface '(root logical))))
|
||||
(should (equal (tp-object-mounts logical)
|
||||
'((:start 1 :end 3 :tags (:slot left))
|
||||
(:start 3 :end 6 :tags (:slot right)))))))))
|
||||
|
||||
(ert-deftest tp-surface-test-explicitly-retained-object-may-be-unmounted ()
|
||||
"An explicitly retained logical object may have no rendered characters."
|
||||
(tp-surface-test--with-buffer
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let* ((root (tp-object-ensure context nil 'root 'group))
|
||||
(hidden (tp-object-ensure context root 'hidden 'item)))
|
||||
(tp-object-retain context hidden)
|
||||
(tp-object-ensure context root 'visible 'text))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children (list (tp-surface-test--leaf 'visible "x")))))
|
||||
(surface (tp-surface-mount
|
||||
buffer producer '(:capability content)))
|
||||
(hidden (tp-object-resolve surface '(root hidden))))
|
||||
(should (tp-object-live-p hidden))
|
||||
(should-not (tp-object-mounts hidden)))))
|
||||
|
||||
(ert-deftest tp-surface-test-disjoint-mount-index-rolls-back-atomically ()
|
||||
"Failed publication restores every mount of a retained logical object."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((value "A"))
|
||||
(let* ((producer
|
||||
(lambda (context)
|
||||
(let* ((root (tp-object-ensure context nil 'root 'group))
|
||||
(logical
|
||||
(tp-object-ensure context root 'logical 'item))
|
||||
(left
|
||||
(tp-object-ensure context root 'left 'fragment))
|
||||
(right
|
||||
(tp-object-ensure context root 'right 'fragment)))
|
||||
(tp-object-retain context logical)
|
||||
(tp-object-attach-fragment context logical left 'left)
|
||||
(tp-object-attach-fragment context logical right 'right))
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'group :capability 'content
|
||||
:children
|
||||
(list (tp-surface-test--leaf 'left value)
|
||||
(tp-surface-test--leaf 'right value)))))
|
||||
(surface (tp-surface-mount
|
||||
buffer producer '(:capability content)))
|
||||
(logical (tp-object-resolve surface '(root logical)))
|
||||
(mounts (tp-object-mounts logical))
|
||||
(revision (tp-surface-revision surface)))
|
||||
(setq value "LONG")
|
||||
(let ((tp--surface-publication-step-function
|
||||
(lambda (step _surface)
|
||||
(when (eq step 'client-state)
|
||||
(error "Injected mount-index failure")))))
|
||||
(should-error (tp-surface-update surface producer)))
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(should (equal (buffer-string) "AA"))
|
||||
(should (eq logical (tp-object-resolve surface '(root logical))))
|
||||
(should (equal (tp-object-mounts logical) mounts))))))
|
||||
|
||||
(ert-deftest tp-surface-test-properties-capability-rejects-text ()
|
||||
"A properties-only mount cannot replace host text."
|
||||
(tp-surface-test--with-buffer
|
||||
|
||||
155
tp-surface.el
155
tp-surface.el
@ -57,7 +57,8 @@
|
||||
(:conc-name tp--surface-))
|
||||
"One live retained tree mounted in a buffer."
|
||||
id buffer capability start end options producer producer-binding plan objects
|
||||
mounts index ledger client-state revision report live stale observers)
|
||||
mounts index mount-index ledger client-state revision report live stale
|
||||
observers)
|
||||
|
||||
(cl-defstruct (tp-object
|
||||
(:constructor tp--make-surface-object)
|
||||
@ -69,8 +70,8 @@
|
||||
(:constructor tp--make-prepare-context)
|
||||
(:conc-name tp--context-))
|
||||
"Short-lived candidate identity and attachment owner."
|
||||
surface objects touched bindings attachments child-seen child-positions
|
||||
new-objects created-anchors active ephemeral)
|
||||
surface objects touched retained bindings attachments fragment-attachments
|
||||
child-seen child-positions new-objects created-anchors active ephemeral)
|
||||
|
||||
(cl-defstruct (tp-range-anchor
|
||||
(:constructor tp--make-range-anchor)
|
||||
@ -88,11 +89,11 @@
|
||||
(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-ledger report)
|
||||
live-mounts live-mount-index live-ledger report)
|
||||
|
||||
(cl-defstruct (tp--surface-snapshot (:constructor tp--make-surface-snapshot))
|
||||
plan objects mounts index ledger client-state producer revision report live
|
||||
stale)
|
||||
plan objects mounts index mount-index ledger client-state producer revision
|
||||
report live stale)
|
||||
|
||||
(defvar tp--surface-id-counter 0)
|
||||
(defvar tp--object-id-counter 0)
|
||||
@ -297,6 +298,21 @@ plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
|
||||
(let ((object (gethash key-path (tp--surface-objects surface))))
|
||||
(and (tp-object-live-p object) object)))
|
||||
|
||||
(defun tp-object-mounts (object)
|
||||
"Return OBJECT's live numeric mount ranges and opaque tags.
|
||||
Each result is a plist with `:start', `:end', and `:tags'. Marker objects
|
||||
remain private so callers cannot mutate TP's publication coordinates."
|
||||
(unless (tp-object-live-p object)
|
||||
(signal 'tp-stale-object (list object)))
|
||||
(let* ((surface (tp--surface-object-surface object))
|
||||
(mounts (gethash object (tp--surface-mount-index surface))))
|
||||
(mapcar
|
||||
(lambda (mount)
|
||||
(list :start (marker-position (tp--surface-mount-start mount))
|
||||
:end (marker-position (tp--surface-mount-end mount))
|
||||
:tags (tp--copy-opaque-value (tp--surface-mount-tags mount))))
|
||||
mounts)))
|
||||
|
||||
(defun tp--make-context (surface &optional ephemeral)
|
||||
"Create a prepare context for SURFACE.
|
||||
When EPHEMERAL is non-nil, no identity may be promoted."
|
||||
@ -306,12 +322,47 @@ When EPHEMERAL is non-nil, no identity may be promoted."
|
||||
(tp--hash-copy (tp--surface-objects surface))
|
||||
(make-hash-table :test #'equal))
|
||||
:touched (make-hash-table :test #'eq)
|
||||
:retained (make-hash-table :test #'eq)
|
||||
:bindings (make-hash-table :test #'eq)
|
||||
:attachments (make-hash-table :test #'eq)
|
||||
:fragment-attachments (make-hash-table :test #'eq)
|
||||
:child-seen (make-hash-table :test #'eq)
|
||||
:child-positions (make-hash-table :test #'eq)
|
||||
:active t :ephemeral ephemeral))
|
||||
|
||||
(defun tp--validate-context-object (context object)
|
||||
"Require OBJECT to be a candidate in active CONTEXT."
|
||||
(tp--validate-prepare-context context)
|
||||
(unless (and (tp-object-p object)
|
||||
(eq (tp--surface-object-surface object)
|
||||
(tp--context-surface context))
|
||||
(gethash object (tp--context-touched context)))
|
||||
(signal 'tp-stale-object (list object))))
|
||||
|
||||
(defun tp-object-retain (context object)
|
||||
"Declare candidate OBJECT live even when it owns no output fragment."
|
||||
(tp--validate-context-object context object)
|
||||
(puthash object t (tp--context-retained context))
|
||||
object)
|
||||
|
||||
(defun tp-object-attach-fragment (context object fragment &optional tags)
|
||||
"Attach logical OBJECT to output FRAGMENT with opaque TAGS in CONTEXT.
|
||||
OBJECT and FRAGMENT must be candidate handles from the same content surface.
|
||||
The plan remains pure; this side attachment may give OBJECT several disjoint
|
||||
marker-backed mounts after publication."
|
||||
(tp--validate-context-object context object)
|
||||
(tp--validate-context-object context fragment)
|
||||
(unless (eq (tp--surface-capability (tp--context-surface context)) 'content)
|
||||
(signal 'tp-capability-error (list :fragment-attachment)))
|
||||
(let ((attachments (gethash fragment
|
||||
(tp--context-fragment-attachments context))))
|
||||
(when (assq object attachments)
|
||||
(signal 'tp-surface-error (list :duplicate-fragment object fragment)))
|
||||
(puthash fragment
|
||||
(cons (cons object (tp--copy-opaque-value tags)) attachments)
|
||||
(tp--context-fragment-attachments context)))
|
||||
(tp-object-retain context object))
|
||||
|
||||
(defun tp--touch-context-binding (context binding)
|
||||
"Record BINDING as touched by CONTEXT."
|
||||
(let ((owner (tp-binding-owner binding)))
|
||||
@ -391,17 +442,31 @@ When EPHEMERAL is non-nil, no identity may be promoted."
|
||||
(nreverse paths)))
|
||||
|
||||
(defun tp--validate-context-tree (context plan)
|
||||
"Require CONTEXT's touched object paths to equal PLAN's paths."
|
||||
(let ((expected (tp--plan-paths plan)) actual)
|
||||
"Validate CONTEXT's planned, retained, and fragment object paths."
|
||||
(let ((expected (make-hash-table :test #'equal))
|
||||
(actual (make-hash-table :test #'equal)))
|
||||
(dolist (path (tp--plan-paths plan)) (puthash path t expected))
|
||||
(maphash (lambda (object _present)
|
||||
(push (tp--surface-object-path object) actual))
|
||||
(puthash (tp--surface-object-path object) object actual))
|
||||
(tp--context-touched context))
|
||||
(dolist (path expected)
|
||||
(unless (member path actual)
|
||||
(maphash
|
||||
(lambda (path _present)
|
||||
(unless (gethash path actual)
|
||||
(signal 'tp-orphan-object (list :missing path))))
|
||||
(dolist (path actual)
|
||||
(unless (member path expected)
|
||||
(signal 'tp-orphan-object (list :extra path))))))
|
||||
expected)
|
||||
(maphash
|
||||
(lambda (path object)
|
||||
(unless (or (gethash path expected)
|
||||
(gethash object (tp--context-retained context)))
|
||||
(signal 'tp-orphan-object (list :extra path))))
|
||||
actual)
|
||||
(maphash
|
||||
(lambda (fragment _attachments)
|
||||
(unless (gethash (tp--surface-object-path fragment) expected)
|
||||
(signal 'tp-orphan-object
|
||||
(list :unplanned-fragment
|
||||
(tp--surface-object-path fragment)))))
|
||||
(tp--context-fragment-attachments context))))
|
||||
|
||||
(defun tp--validate-plan-capability (plan capability)
|
||||
"Validate PLAN recursively against mount CAPABILITY."
|
||||
@ -480,16 +545,34 @@ When EPHEMERAL is non-nil, no identity may be promoted."
|
||||
(tp--context-touched context))
|
||||
objects))
|
||||
|
||||
(defun tp--content-mount-spec (object record &optional tags)
|
||||
"Return one content mount spec for OBJECT over RECORD with TAGS."
|
||||
(list :object object :start (plist-get record :start)
|
||||
:end (plist-get record :end)
|
||||
:tags (tp--copy-opaque-value
|
||||
(if tags tags (plist-get record :tags)))))
|
||||
|
||||
(defun tp--content-mount-specs (records context)
|
||||
"Return direct and logical-fragment mount specs for RECORDS in CONTEXT."
|
||||
(let (specs)
|
||||
(dolist (record records)
|
||||
(let* ((fragment (plist-get record :object))
|
||||
(attachments
|
||||
(nreverse
|
||||
(copy-sequence
|
||||
(gethash fragment
|
||||
(tp--context-fragment-attachments context))))))
|
||||
(push (tp--content-mount-spec fragment record) specs)
|
||||
(dolist (attachment attachments)
|
||||
(push (tp--content-mount-spec
|
||||
(car attachment) record (cdr attachment))
|
||||
specs))))
|
||||
(nreverse specs)))
|
||||
|
||||
(defun tp--plan-record-mount-specs (records capability context)
|
||||
"Build candidate mount specs from RECORDS for CAPABILITY in CONTEXT."
|
||||
(if (eq capability 'content)
|
||||
(mapcar (lambda (record)
|
||||
(list :object (plist-get record :object)
|
||||
:start (plist-get record :start)
|
||||
:end (plist-get record :end)
|
||||
:tags (tp--copy-opaque-value
|
||||
(plist-get record :tags))))
|
||||
records)
|
||||
(tp--content-mount-specs records context)
|
||||
(tp--properties-mount-specs records context)))
|
||||
|
||||
(defun tp--ranges-overlap-p (left-start left-end right-start right-end)
|
||||
@ -617,12 +700,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
|
||||
|
||||
(defun tp-object-attach-range (context object anchor)
|
||||
"Attach OBJECT to marker-backed ANCHOR in candidate CONTEXT."
|
||||
(tp--validate-prepare-context context)
|
||||
(unless (and (tp-object-p object)
|
||||
(eq (tp--surface-object-surface object)
|
||||
(tp--context-surface context))
|
||||
(gethash object (tp--context-touched context)))
|
||||
(signal 'tp-stale-object (list object)))
|
||||
(tp--validate-context-object context object)
|
||||
(tp--validate-anchor anchor (tp--context-surface context))
|
||||
(when (gethash object (tp--context-attachments context))
|
||||
(signal 'tp-invalid-range-anchor (list :duplicate object)))
|
||||
@ -855,6 +933,7 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
|
||||
:capability capability :start (copy-marker (car range) nil)
|
||||
:end (copy-marker (cdr range) t) :options (copy-tree options)
|
||||
:objects (make-hash-table :test #'equal) :mounts nil :index nil
|
||||
:mount-index (make-hash-table :test #'eq)
|
||||
:ledger nil :revision 0 :live nil :stale nil
|
||||
:observers (copy-sequence (plist-get options :observers)))))
|
||||
|
||||
@ -1204,6 +1283,16 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
:anchors (plist-get spec :anchors)))
|
||||
(tp--prepared-surface-ledger-specs prepared))))
|
||||
|
||||
(defun tp--index-mounts-by-object (mounts)
|
||||
"Return an object-keyed index of marker-backed MOUNTS."
|
||||
(let ((index (make-hash-table :test #'eq)))
|
||||
(dolist (mount mounts)
|
||||
(push mount (gethash (tp--surface-mount-object mount) index)))
|
||||
(maphash (lambda (object entries)
|
||||
(puthash object (nreverse entries) index))
|
||||
index)
|
||||
index))
|
||||
|
||||
(defun tp--create-candidate-mount-state (prepared)
|
||||
"Create PREPARED's marker-backed mount, ledger, and index candidates."
|
||||
(let* ((surface (tp--prepared-surface-surface prepared))
|
||||
@ -1213,6 +1302,8 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(ledger (and (eq (tp--surface-capability surface) 'properties)
|
||||
(tp--make-live-ledger prepared))))
|
||||
(setf (tp--prepared-surface-live-mounts prepared) mounts
|
||||
(tp--prepared-surface-live-mount-index prepared)
|
||||
(tp--index-mounts-by-object mounts)
|
||||
(tp--prepared-surface-live-ledger prepared) ledger)
|
||||
mounts))
|
||||
|
||||
@ -1221,6 +1312,7 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(tp--make-surface-snapshot
|
||||
:plan (tp--surface-plan surface) :objects (tp--surface-objects surface)
|
||||
:mounts (tp--surface-mounts surface) :index (tp--surface-index surface)
|
||||
:mount-index (tp--surface-mount-index surface)
|
||||
:ledger (tp--surface-ledger surface)
|
||||
:client-state (tp--surface-client-state surface)
|
||||
:producer (tp--surface-producer surface)
|
||||
@ -1308,6 +1400,8 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(tp--surface-object-table (tp--prepared-surface-objects prepared))
|
||||
(tp--surface-mounts surface) mounts
|
||||
(tp--surface-index surface) mounts
|
||||
(tp--surface-mount-index surface)
|
||||
(tp--prepared-surface-live-mount-index prepared)
|
||||
(tp--surface-ledger surface) ledger
|
||||
(tp--surface-client-state surface)
|
||||
(tp--prepared-surface-client-state prepared)
|
||||
@ -1481,6 +1575,10 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(tp--surface-snapshot-objects snapshot)
|
||||
(tp--surface-mounts surface)
|
||||
(tp--surface-snapshot-mounts snapshot)
|
||||
(tp--surface-index surface)
|
||||
(tp--surface-snapshot-index snapshot)
|
||||
(tp--surface-mount-index surface)
|
||||
(tp--surface-snapshot-mount-index snapshot)
|
||||
(tp--surface-ledger surface)
|
||||
(tp--surface-snapshot-ledger snapshot)))
|
||||
(when (and (tp--surface-live surface)
|
||||
@ -1499,6 +1597,8 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(tp--surface-objects surface) (tp--surface-snapshot-objects snapshot)
|
||||
(tp--surface-mounts surface) (tp--surface-snapshot-mounts snapshot)
|
||||
(tp--surface-index surface) (tp--surface-snapshot-index snapshot)
|
||||
(tp--surface-mount-index surface)
|
||||
(tp--surface-snapshot-mount-index snapshot)
|
||||
(tp--surface-ledger surface) (tp--surface-snapshot-ledger snapshot)
|
||||
(tp--surface-client-state surface)
|
||||
(tp--surface-snapshot-client-state snapshot)
|
||||
@ -1835,6 +1935,7 @@ OPTIONS accepts :capability (`content' or `properties'), :start, :end,
|
||||
(tp--surface-stale surface) (and killed 'killed)
|
||||
(tp--surface-objects surface) (make-hash-table :test #'equal)
|
||||
(tp--surface-mounts surface) nil (tp--surface-index surface) nil
|
||||
(tp--surface-mount-index surface) (make-hash-table :test #'eq)
|
||||
(tp--surface-ledger surface) nil
|
||||
(tp--surface-client-state surface) nil)))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user