diff --git a/CHANGELOG.md b/CHANGELOG.md index bbb95eb..2bc203f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,7 @@ All notable changes to the tp library are documented here. ### Added +- 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. - TP 1.0 signals and bindings now form an exact source→binding and binding→binding dependency graph with conditional rewiring, memoized equality cutoffs, transaction-local candidate signal values, deduplicated topological flushing, nested-write stabilization, rollback, cycle paths, owner disposal, buffer-scoped sources, variable adapters, and public scheduler counters. The legacy layer scanner remains isolated only until the retained-surface cutover. - The first TP 1.0 runtime slice: `tp-style.el` provides atomic namespaced property schemas, structured subject selectors and combinators, deterministic origin/importance/layer/specificity/scope/source-order cascade, property-specific inheritance, tagged CSS-wide values, custom-property fallback/cycle handling, explicit `tp-computed` value sources, named declarations, provenance, and final Emacs-property projection. Ordinary function values remain literal. - Internal Stage 2 canonical façade records and dataflow: diff --git a/Makefile b/Makefile index 7de7523..e77193b 100644 --- a/Makefile +++ b/Makefile @@ -19,7 +19,7 @@ WERROR ?= nil TEST_DIR = tests LOADPATH = -L . -L $(TEST_DIR) $(LOAD_EXTRA) -SRC = tp-core.el tp-style.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \ +SRC = tp-core.el tp-style.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.el \ tp-render.el tp-stack.el tp-query.el tp-palette.el tp-builtins.el tp.el TESTS = $(wildcard $(TEST_DIR)/*-tests.el) TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el diff --git a/README.md b/README.md index 8f847ac..70ba332 100644 --- a/README.md +++ b/README.md @@ -178,6 +178,8 @@ 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 or cycle failures roll them back. 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. + ### Core Innovations 1. **Unified API Parameter Conventions**: All functions support multiple flexible calling patterns, working seamlessly with both strings and buffers @@ -435,6 +437,7 @@ The modules and their roles: | `tp-core.el` | Intervals, plist/face merge engine, debug logging, `$var` utilities | | `tp-style.el` | Namespaced property schemas, structured selectors, cascade, custom properties, and explicit computed values | | `tp-reactive.el` | Exact signals, memoized bindings, transactions, scoped variable adapters, and temporary legacy watcher state | +| `tp-surface.el` | Retained plans, prepare/object lifecycle, range anchors, mounts, side indexes, diffs, reports, and atomic publication | | `tp-layer.el` | `define-tp` / `define-tps`, layer registry and resolution | | `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` | | `tp-search.el` | `tp-match-*`, `tp-regexp-*`, `tp-search`, navigation | @@ -530,6 +533,17 @@ A complete overview of all tp.el functions organized by category: | `tp-variable-signal` | Adapt a global or buffer-local Elisp variable into a scoped signal | | `tp-reactive-counters` / `tp-reactive-reset-counters` | Read or reset public scheduler work counters | +#### Retained Surfaces + +| 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-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-at-point` / `tp-surface-inspect` / `tp-surface-report` | Query retained side indexes and generic commit diagnostics without scanning text | + #### Property Layer Definition Functions | Function | Description | |----------|-------------| diff --git a/README_CN.md b/README_CN.md index ad0e3d1..5186385 100644 --- a/README_CN.md +++ b/README_CN.md @@ -177,6 +177,8 @@ 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 失败时一起回滚。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 会被拒绝，避免所有权静默分裂。 + ### 核心创新 1. **统一的 API 参数规范**：所有函数支持多种灵活的调用方式，同时适用于字符串和缓冲区 @@ -431,6 +433,7 @@ OBJECT 总是位于最后（nil 表示当前缓冲区）。所有核心函数和 | `tp-core.el` | 区间、plist/face 合并引擎、调试日志、`$var` 工具 | | `tp-style.el` | namespaced property schema、结构化 selector、cascade、custom property 和显式 computed value | | `tp-reactive.el` | 精确 signal、memoized binding、transaction、scoped variable adapter 和临时 legacy watcher state | +| `tp-surface.el` | retained plan、prepare/object lifecycle、range anchor、mount、side index、diff、report 和原子 publication | | `tp-layer.el` | `define-tp` / `define-tps`、属性层注册表与解析 | | `tp-ops.el` | `tp-set` / `tp-reset` / `tp-add` / `tp-get` / `tp-at` / `tp-remove` / `tp-clear` | | `tp-search.el` | `tp-match-*`、`tp-regexp-*`、`tp-search`、导航 | @@ -525,6 +528,17 @@ tp.el 所有函数按类别组织的完整概览： | `tp-variable-signal` | 把 global 或 buffer-local Elisp variable 适配为 scoped signal | | `tp-reactive-counters` / `tp-reactive-reset-counters` | 读取或重置 public scheduler work counters | +#### Retained Surfaces + +| 函数 | 描述 | +|------|------| +| `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-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 | +| `tp-surface-at-point` / `tp-surface-inspect` / `tp-surface-report` | 不扫描文本地查询 retained side index 与 generic commit diagnostics | + #### 属性层定义函数 | 函数 | 描述 | |------|------| diff --git a/docs/API-SEMANTICS.md b/docs/API-SEMANTICS.md index 34117ff..d3d2dc5 100644 --- a/docs/API-SEMANTICS.md +++ b/docs/API-SEMANTICS.md @@ -192,3 +192,13 @@ tp 不会把外部属性收编成新的匿名层，也不会静默覆盖它。 - 任一 compute 或 cycle 失败会恢复 committed signal values、last successful binding values、dependencies、dirty state、owner registry 和 scheduler counters。cycle condition 携带 namespaced binding-key path。 - `tp-variable-signal` 是 global/buffer-local Elisp variable（包括后续 `$var` compiler）的 source adapter；它只转发精确 scope 的 write，不调用 legacy layer renderer。 - `tp-reactive-counters` 只公开 invalidated、recomputed、skipped、subscription-added、subscription-removed 五个工作量计数，不暴露 internal hash shape。 + +## 14. Retained surface、range ownership 与 publication + +- `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。 +- `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 静默覆盖。 +- 最外层 transaction 先完成所有 producer/plan/conflict validation，再按 surface id publish。multi-buffer change group 负责 text rollback，TP 的精确 property journal 覆盖 `with-silent-modifications`；失败恢复 buffer direct properties、markers/index、objects、plan、client state、revision、bindings 与 signal values。publish 中 killed buffer 不复活，其他 surfaces 与 sources 回滚。 +- `tp-surface-report` 的字段只使用 transaction/surface/source/binding/object/text/property/conflict/observer/timing 通用词汇。observer 在成功 commit 且 publishing transaction 的动态范围退出后执行，因此 observer 中的 signal write 会开启新 transaction；observer error 只写入 report，不回滚。 diff --git a/docs/ARCHITECTURE.md b/docs/ARCHITECTURE.md index aa7eb72..ce8b73e 100644 --- a/docs/ARCHITECTURE.md +++ b/docs/ARCHITECTURE.md @@ -2,7 +2,7 @@ > 未来主版本目标：TP 将重构为独立 retained/reactive text runtime，并可作为 Ebox 等高级 consumer 的通用底层执行器。TP 自身完整、可独立阅读的已批准目标见 [TP Retained/Reactive Text Runtime 目标架构](retained-runtime-target-architecture.md)（[English](retained-runtime-target-architecture-en.md)）；它不依赖 sibling Ebox checkout。本文描述当前已经落地的实现，并明确标出仍处于迁移期的旧 runtime 与 TP 1.0 功能切片。 -本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。TP 1.0 的纯 style/cascade kernel 与 exact signal/binding graph 已分别在 `tp-style.el`、`tp-reactive.el` 落地；retained surface 尚未切换。 +本文档描述 tp 库的模块分层结构与函数调用层次，从底层基础模块到上层功能模块的分层组织。TP 1.0 的纯 style/cascade kernel、exact signal/binding graph 与 retained surface publication 已分别在 `tp-style.el`、`tp-reactive.el`、`tp-surface.el` 落地；旧 managed façade 尚未切换。 当前 API 的规范契约见 [API-SEMANTICS.md](API-SEMANTICS.md)；Emacs 原生 文本属性覆盖范围、已确认问题与演进路线见 @@ -181,6 +181,12 @@ Stage 2 canonical façade 是内部模型，不改变公开入口和历史返回 文件下半部仍暂存 0.3 façade 所需的变量→layer watcher、batch queue 和 layer→buffer registry，以保持旧测试在 retained surface 建成前可运行；它们没有被新 graph 调用，并将在最终 cutover phase 与 `tp-render.el` 扫描路径一起删除。这个暂存区不是第二套长期 public runtime。 +### 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。 + +`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。 + #### 依赖注册与管理 | 函数/变量 | 描述 | |------|------| @@ -574,6 +580,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-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` | diff --git a/tests/tp-surface-tests.el b/tests/tp-surface-tests.el new file mode 100644 index 0000000..5993eee --- /dev/null +++ b/tests/tp-surface-tests.el @@ -0,0 +1,554 @@ +;;; tp-surface-tests.el --- Tests for TP retained surfaces -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Geekinney + +;;; Commentary: + +;; Contract tests for TP 1.0 plans, objects, mounts, and publication. + +;;; Code: + +(require 'ert) +(require 'tp-surface) + +(defmacro tp-surface-test--with-buffer (&rest body) + "Run BODY in a temporary live buffer." + (declare (indent 0) (debug t)) + `(let ((buffer (generate-new-buffer " *tp-surface-test*"))) + (unwind-protect + (with-current-buffer buffer ,@body) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(defun tp-surface-test--leaf (key text &optional props) + "Return a content leaf with KEY, TEXT, and PROPS." + (tp-surface-plan-create + :key key :kind 'text :text text :props props :capability 'content)) + +(defun tp-surface-test--producer (signal) + "Return a retained content producer reading SIGNAL." + (lambda (context) + (tp-object-ensure context nil 'root 'text) + (tp-surface-result-create + (tp-surface-test--leaf 'root (number-to-string (tp-signal-read signal))) + (list :value (tp-signal-peek signal))))) + +(ert-deftest tp-surface-test-plan-validates-and-defensively-copies () + "Plans reject duplicate keys and own their caller-provided values." + (let* ((callback (byte-compile + (lambda (_window _object _position) "help"))) + (props (list 'help-echo callback)) + (text (copy-sequence "A")) + (child (tp-surface-test--leaf 'child text props)) + (plan (tp-surface-plan-create + :key 'root :kind 'group :children (list child) + :capability 'content))) + (setcar props 'face) + (aset text 0 ?Z) + (let ((rendered (tp-surface-materialize-string plan))) + (should (equal (substring-no-properties rendered) "A")) + (should (eq (get-text-property 0 'help-echo rendered) callback))) + (should-error + (tp-surface-plan-create + :key 'root :kind 'group + :children (list (tp-surface-test--leaf 'same "A") + (tp-surface-test--leaf 'same "B")) + :capability 'content) + :type 'tp-duplicate-object-key))) + +(ert-deftest tp-surface-test-materialize-producer-is-ephemeral () + "Pure materialization leaves no live object, binding, or subscription." + (let ((signal (tp-signal-create 7)) object binding) + (let ((rendered + (tp-surface-materialize-string + (lambda (context) + (setq object (tp-object-ensure context nil 'root 'text) + binding (tp-bind object '(test . value) + (lambda () (tp-signal-read signal)))) + (tp-surface-test--leaf + 'root (number-to-string (tp-binding-read binding))))))) + (should (equal rendered "7"))) + (should-not (tp-object-live-p object)) + (should-not (tp-binding-live-p binding)) + (should (= (tp-signal-subscriber-count signal) 0)))) + +(ert-deftest tp-surface-test-content-mount-retains-keyed-identity () + "A content update reuses keyed objects and publishes a minimal result." + (tp-surface-test--with-buffer + (let* ((first (tp-surface-test--leaf 'root "old" '(face bold))) + (surface (tp-surface-mount buffer first '(:capability content))) + (object (tp-object-resolve surface '(root)))) + (should (equal (buffer-string) "old")) + (cl-letf (((symbol-function 'buffer-list) + (lambda (&rest _) (error "Unexpected buffer scan"))) + ((symbol-function 'text-property-search-forward) + (lambda (&rest _) (error "Unexpected property scan")))) + (tp-surface-update + surface (tp-surface-test--leaf 'root "new" '(face italic)))) + (should (equal (buffer-string) "new")) + (should (eq object (tp-object-resolve surface '(root)))) + (should (eq (get-text-property 1 'face buffer) 'italic)) + (should (= (plist-get (tp-surface-report surface) :text-operations) 1))))) + +(ert-deftest tp-surface-test-failed-candidate-does-not-leak-object () + "A failed update preserves the live tree and invalidates new handles." + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount buffer (tp-surface-test--leaf 'root "old") + '(:capability content))) + (root (tp-object-resolve surface '(root))) + candidate) + (should-error + (tp-surface-update + surface + (lambda (context) + (tp-object-ensure context nil 'root 'text) + (setq candidate (tp-object-ensure context root 'orphan 'text)) + (tp-surface-test--leaf 'root "new"))) + :type 'tp-orphan-object) + (should (equal (buffer-string) "old")) + (should (eq root (tp-object-resolve surface '(root)))) + (should-not (tp-object-live-p candidate))))) + +(ert-deftest tp-surface-test-properties-capability-rejects-text () + "A properties-only mount cannot replace host text." + (tp-surface-test--with-buffer + (insert "host") + (should-error + (tp-surface-mount buffer (tp-surface-test--leaf 'root "replacement") + '(:capability properties)) + :type 'tp-capability-error) + (should (equal (buffer-string) "host")))) + +(ert-deftest tp-surface-test-range-anchor-follows-edits-before-it () + "A host insertion before an anchor moves its property contribution." + (tp-surface-test--with-buffer + (insert "012345") + (let* ((anchor (tp-range-anchor-create buffer 3 5)) + (value "A") + (producer + (lambda (context) + (let ((object (tp-object-ensure context nil 'root 'range))) + (tp-object-attach-range context object anchor)) + (tp-surface-plan-create + :key 'root :kind 'range :props (list 'help-echo value) + :capability 'properties))) + (surface (tp-surface-mount + buffer producer '(:capability properties)))) + (should (equal (get-text-property 3 'help-echo) "A")) + (goto-char 1) + (insert "X") + (setq value "B") + (tp-surface-update surface producer) + (should (equal (get-text-property 4 'help-echo) "B")) + (should-not (get-text-property 3 'help-echo))))) + +(ert-deftest tp-surface-test-property-conflict-needs-explicit-rebase () + "TP preserves an external property write until the anchor is rebased." + (tp-surface-test--with-buffer + (insert "host") + (let* ((anchor (tp-range-anchor-create buffer 1 5)) + (value "A") + (producer + (lambda (context) + (let ((object (tp-object-ensure context nil 'root 'range))) + (tp-object-attach-range context object anchor)) + (tp-surface-plan-create + :key 'root :kind 'range :props (list 'help-echo value) + :capability 'properties))) + (surface (tp-surface-mount + buffer producer '(:capability properties))) + (revision (tp-surface-revision surface))) + (put-text-property 1 5 'help-echo "external") + (setq value "B") + (should-error (tp-surface-update surface producer) + :type 'tp-property-conflict) + (should (= (tp-surface-revision surface) revision)) + (should (equal (get-text-property 2 'help-echo) "external")) + (tp-range-rebase anchor) + (tp-surface-update surface producer) + (should (equal (get-text-property 2 'help-echo) "B")) + (tp-surface-unmount surface) + (should (equal (get-text-property 2 'help-echo) "external"))))) + +(ert-deftest tp-surface-test-unmount-preserves-conflicting-host-value () + "Unmount removes only TP's still-current property contribution." + (tp-surface-test--with-buffer + (insert "host") + (let* ((anchor (tp-range-anchor-create buffer 1 5)) + (producer + (lambda (context) + (let ((object (tp-object-ensure context nil 'root 'range))) + (tp-object-attach-range context object anchor)) + (tp-surface-plan-create + :key 'root :kind 'range :props '(help-echo "tp") + :capability 'properties))) + (surface (tp-surface-mount + buffer producer '(:capability properties)))) + (put-text-property 1 5 'help-echo "external") + (let ((report (tp-surface-unmount surface))) + (should (plist-get report :property-conflicts))) + (should (equal (get-text-property 2 'help-echo) "external")) + (should-not (tp-surface-live-p surface)) + (should-not (tp-range-anchor-live-p anchor))))) + +(ert-deftest tp-surface-test-content-external-edit-marks-mount-stale () + "An external edit inside content-owned text prevents silent overwrite." + (tp-surface-test--with-buffer + (let ((surface + (tp-surface-mount buffer (tp-surface-test--leaf 'root "abc") + '(:capability content)))) + (goto-char 2) + (insert "X") + (should-error + (tp-surface-update surface (tp-surface-test--leaf 'root "next")) + :type 'tp-stale-mount) + (should (equal (buffer-string) "aXbc"))))) + +(ert-deftest tp-surface-test-publication-steps-roll-back-exactly () + "Failure at each publication step keeps the prior surface revision." + (dolist (step '(text property marker index client-state)) + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount buffer (tp-surface-test--leaf 'root "old") + '(:capability content))) + (revision (tp-surface-revision surface)) + (object (tp-object-resolve surface '(root))) + (tp--surface-publication-step-function + (lambda (current _surface) + (when (eq current step) (error "Injected %s failure" step))))) + (should-error + (tp-surface-update + surface + (tp-surface-result-create + (tp-surface-test--leaf 'root "new" '(face bold)) + (list :candidate step)))) + (should (equal-including-properties (buffer-string) "old")) + (should (= (tp-surface-revision surface) revision)) + (should (eq object (tp-object-resolve surface '(root)))))))) + +(ert-deftest tp-surface-test-global-signal-update-is-multi-surface-atomic () + "A second-surface failure rolls back buffers, bindings, and source value." + (let* ((signal (tp-signal-create 1)) + (first-buffer (generate-new-buffer " *tp-surface-first*")) + (second-buffer (generate-new-buffer " *tp-surface-second*")) + (producer (tp-surface-test--producer signal)) + first second) + (unwind-protect + (progn + (setq first (tp-surface-mount + first-buffer producer '(:capability content)) + second (tp-surface-mount + second-buffer producer '(:capability content))) + (let ((first-revision (tp-surface-revision first)) + (second-revision (tp-surface-revision second)) + (tp--surface-publication-step-function + (lambda (step surface) + (when (and (eq step 'client-state) (eq surface second)) + (error "Injected second-surface failure"))))) + (should-error (tp-signal-set signal 2)) + (should (= (tp-signal-peek signal) 1)) + (should (= (tp-surface-revision first) first-revision)) + (should (= (tp-surface-revision second) second-revision)) + (should (equal (tp-surface-client-state first) '(:value 1))) + (should (equal (tp-surface-client-state second) '(:value 1))) + (with-current-buffer first-buffer (should (equal (buffer-string) "1"))) + (with-current-buffer second-buffer (should (equal (buffer-string) "1"))))) + (when (buffer-live-p first-buffer) (kill-buffer first-buffer)) + (when (buffer-live-p second-buffer) (kill-buffer second-buffer))))) + +(ert-deftest tp-surface-test-materialize-matches-first-content-mount () + "Pure and live publication produce identical propertized text." + (tp-surface-test--with-buffer + (let* ((child (tp-surface-test--leaf + 'child "text" '(face (:foreground "white")))) + (plan (tp-surface-plan-create + :key 'root :kind 'group :children (list child) + :props '(help-echo "root") :capability 'content)) + (materialized (tp-surface-materialize-string plan))) + (tp-surface-mount buffer plan '(:capability content)) + (should (equal-including-properties materialized (buffer-string)))))) + +(ert-deftest tp-surface-test-index-diagnostics-use-side-state () + "Point queries and reports resolve through the retained side index." + (tp-surface-test--with-buffer + (let* ((child (tp-surface-test--leaf 'child "x")) + (plan (tp-surface-plan-create + :key 'root :kind 'group :children (list child) + :tags '(:role root) :capability 'content)) + (surface (tp-surface-mount buffer plan '(:capability content))) + (objects (tp-surface-at-point 1 buffer)) + (inspection (tp-surface-inspect surface))) + (should (= (length objects) 2)) + (should (eq (plist-get inspection :surface) surface)) + (should (= (plist-get inspection :revision) 1)) + (should (equal (plist-get (tp-surface-report surface) :surface-id) + (plist-get inspection :id)))))) + +(ert-deftest tp-surface-test-kill-buffer-disposes-runtime () + "Killing the lifecycle owner releases its surface and objects." + (let* ((buffer (generate-new-buffer " *tp-surface-kill*")) + (surface (tp-surface-mount + buffer (tp-surface-test--leaf 'root "x") + '(:capability content))) + (object (tp-object-resolve surface '(root)))) + (kill-buffer buffer) + (should-not (tp-surface-live-p surface)) + (should-not (tp-object-live-p object)))) + +(ert-deftest tp-surface-test-omitted-binding-defaults-to-deletion () + "A surviving object does not retain an omitted binding by accident." + (tp-surface-test--with-buffer + (let ((signal (tp-signal-create 1)) + (include t) + binding) + (let* ((producer + (lambda (context) + (let ((object (tp-object-ensure context nil 'root 'text))) + (when include + (setq binding + (tp-bind object '(test . optional) + (lambda () (tp-signal-read signal)))) + (tp-binding-read binding))) + (tp-surface-test--leaf 'root "value"))) + (surface (tp-surface-mount + buffer producer '(:capability content)))) + (should (= (tp-signal-subscriber-count signal) 1)) + (setq include nil) + (tp-surface-update surface producer) + (should-not (tp-binding-live-p binding)) + (should (= (tp-signal-subscriber-count signal) 0)))))) + +(ert-deftest tp-surface-test-explicit-retain-keeps-omitted-binding () + "An explicit retain lifecycle keeps an omitted computation subscribed." + (tp-surface-test--with-buffer + (let ((signal (tp-signal-create 1)) + (include t) + binding) + (let* ((producer + (lambda (context) + (let ((object (tp-object-ensure context nil 'root 'text))) + (when include + (setq binding + (tp-bind object '(test . retained) + (lambda () (tp-signal-read signal)) + :lifecycle 'retain)) + (tp-binding-read binding))) + (tp-surface-test--leaf 'root "value"))) + (surface (tp-surface-mount + buffer producer '(:capability content)))) + (setq include nil) + (tp-surface-update surface producer) + (should (tp-binding-live-p binding)) + (should (= (tp-signal-subscriber-count signal) 1)))))) + +(ert-deftest tp-surface-test-read-only-and-narrowing-policy-is-explicit () + "Content publication requires opt-in for read-only buffers and preserves narrowing." + (tp-surface-test--with-buffer + (insert "012345") + (narrow-to-region 2 5) + (setq buffer-read-only t) + (should-error + (tp-surface-mount buffer (tp-surface-test--leaf 'root "x") + '(:capability content :start 2 :end 5)) + :type 'buffer-read-only) + (let ((surface + (tp-surface-mount + buffer (tp-surface-test--leaf 'root "x") + '(:capability content :start 2 :end 5 :inhibit-read-only t)))) + (should buffer-read-only) + (should (buffer-narrowed-p)) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + "x")) + (tp-surface-unmount surface)))) + +(ert-deftest tp-surface-test-observer-failure-does-not-roll-back () + "Observer errors are recorded after a successful publication." + (tp-surface-test--with-buffer + (let ((surface + (tp-surface-mount + buffer (tp-surface-test--leaf 'root "committed") + (list :capability 'content + :observers (list (lambda (_surface _report) + (error "Observer failure"))))))) + (should (equal (buffer-string) "committed")) + (should (= (tp-surface-revision surface) 1)) + (should (= (length (plist-get (tp-surface-report surface) + :observer-errors)) + 1))))) + +(ert-deftest tp-surface-test-observer-write-starts-a-new-transaction () + "An observer signal write runs after the publishing transaction exits." + (tp-surface-test--with-buffer + (let* ((signal (tp-signal-create 1)) + (write-once t) + (producer (tp-surface-test--producer signal)) + (surface + (tp-surface-mount + buffer producer + (list :capability 'content + :observers + (list (lambda (_surface _report) + (when write-once + (setq write-once nil) + (tp-signal-set signal 2)))))))) + (should (= (tp-signal-peek signal) 2)) + (should (equal (buffer-string) "2")) + (should (= (tp-surface-revision surface) 2))))) + +(ert-deftest tp-surface-test-equal-reactive-plan-skips-surface-publication () + "An equal producer result leaves the surface revision unchanged." + (tp-surface-test--with-buffer + (let* ((signal (tp-signal-create 10)) + (producer + (lambda (context) + (tp-object-ensure context nil 'root 'text) + (tp-surface-test--leaf + 'root (number-to-string (/ (tp-signal-read signal) 10))))) + (surface (tp-surface-mount + buffer producer '(:capability content))) + (revision (tp-surface-revision surface))) + (tp-signal-set signal 11) + (should (= (tp-surface-revision surface) revision)) + (should (equal (buffer-string) "1"))))) + +(ert-deftest tp-surface-test-keyed-reorder-preserves-object-handles () + "Keyed children keep identity when their display order changes." + (tp-surface-test--with-buffer + (let* ((first + (tp-surface-plan-create + :key 'root :kind 'group + :children (list (tp-surface-test--leaf 'a "A") + (tp-surface-test--leaf 'b "B")) + :capability 'content)) + (surface (tp-surface-mount buffer first '(:capability content))) + (a (tp-object-resolve surface '(root a))) + (b (tp-object-resolve surface '(root b))) + (second + (tp-surface-plan-create + :key 'root :kind 'group + :children (list (tp-surface-test--leaf 'b "B") + (tp-surface-test--leaf 'a "A")) + :capability 'content))) + (tp-surface-update surface second) + (should (equal (buffer-string) "BA")) + (should (eq a (tp-object-resolve surface '(root a)))) + (should (eq b (tp-object-resolve surface '(root b)))) + (should (= (plist-get (tp-surface-report surface) :moved-objects) 2))))) + +(ert-deftest tp-surface-test-overlapping-range-contributions-are-ordered () + "Overlapping property mounts combine deterministically by plan order." + (tp-surface-test--with-buffer + (insert "abcd") + (let* ((left (tp-range-anchor-create buffer 1 4)) + (right (tp-range-anchor-create buffer 2 5)) + (producer + (lambda (context) + (let* ((root (tp-object-ensure context nil 'root 'group)) + (a (tp-object-ensure context root 'a 'range)) + (b (tp-object-ensure context root 'b 'range))) + (tp-object-attach-range context a left) + (tp-object-attach-range context b right)) + (tp-surface-plan-create + :key 'root :kind 'group :capability 'properties + :children + (list (tp-surface-plan-create + :key 'a :kind 'range :props '(help-echo "A") + :capability 'properties) + (tp-surface-plan-create + :key 'b :kind 'range :props '(help-echo "B") + :capability 'properties))))) + (surface (tp-surface-mount + buffer producer '(:capability properties)))) + (should (equal (get-text-property 1 'help-echo) "A")) + (should (equal (get-text-property 2 'help-echo) "B")) + (should (equal (get-text-property 4 'help-echo) "B")) + (tp-surface-unmount surface) + (should-not (get-text-property 2 'help-echo))))) + +(ert-deftest tp-surface-test-explicit-nil-is-a-property-contribution () + "A present nil contribution hides and later restores its host baseline." + (tp-surface-test--with-buffer + (insert "host") + (put-text-property 1 5 'help-echo "baseline") + (let* ((anchor (tp-range-anchor-create buffer 1 5)) + (producer + (lambda (context) + (let ((object (tp-object-ensure context nil 'root 'range))) + (tp-object-attach-range context object anchor)) + (tp-surface-plan-create + :key 'root :kind 'range :props '(help-echo nil) + :capability 'properties))) + (surface (tp-surface-mount + buffer producer '(:capability properties)))) + (should (equal (tp--property-state-at buffer 2 'help-echo) + '(t))) + (tp-surface-unmount surface) + (should (equal (get-text-property 2 'help-echo) "baseline"))))) + +(ert-deftest tp-surface-test-unmount-preserves-only-conflicting-subranges () + "Unmount restores owned runs without clobbering a partial host override." + (tp-surface-test--with-buffer + (insert "abcd") + (let* ((anchor (tp-range-anchor-create buffer 1 5)) + (producer + (lambda (context) + (let ((object (tp-object-ensure context nil 'root 'range))) + (tp-object-attach-range context object anchor)) + (tp-surface-plan-create + :key 'root :kind 'range :props '(help-echo "tp") + :capability 'properties))) + (surface (tp-surface-mount + buffer producer '(:capability properties)))) + (put-text-property 2 3 'help-echo "external") + (tp-surface-unmount surface) + (should-not (get-text-property 1 'help-echo)) + (should (equal (get-text-property 2 'help-echo) "external")) + (should-not (get-text-property 3 'help-echo))))) + +(ert-deftest tp-surface-test-cross-surface-overlap-is-rejected () + "Independent surfaces cannot silently claim the same character range." + (tp-surface-test--with-buffer + (let ((first (tp-surface-mount + buffer (tp-surface-test--leaf 'first "owned") + '(:capability content)))) + (should-error + (tp-surface-mount + buffer (tp-surface-test--leaf 'second "overlap") + '(:capability content)) + :type 'tp-capability-error) + (should (tp-surface-live-p first)) + (should (equal (buffer-string) "owned"))))) + +(ert-deftest tp-surface-test-kill-during-publication-is-authoritative () + "A killed target stays dead while other surfaces and sources roll back." + (let* ((signal (tp-signal-create 1)) + (first-buffer (generate-new-buffer " *tp-surface-survivor*")) + (victim-buffer (generate-new-buffer " *tp-surface-victim*")) + (producer (tp-surface-test--producer signal)) + first victim victim-object) + (unwind-protect + (progn + (setq first (tp-surface-mount + first-buffer producer '(:capability content)) + victim (tp-surface-mount + victim-buffer producer '(:capability content)) + victim-object (tp-object-resolve victim '(root))) + (let ((revision (tp-surface-revision first)) + (tp--surface-publication-step-function + (lambda (step surface) + (when (and (eq step 'text) (eq surface victim)) + (kill-buffer victim-buffer))))) + (should-error (tp-signal-set signal 2)) + (should (= (tp-signal-peek signal) 1)) + (should (tp-surface-live-p first)) + (should (= (tp-surface-revision first) revision)) + (with-current-buffer first-buffer + (should (equal (buffer-string) "1"))) + (should-not (buffer-live-p victim-buffer)) + (should-not (tp-surface-live-p victim)) + (should-not (tp-object-live-p victim-object)))) + (when (buffer-live-p first-buffer) (kill-buffer first-buffer)) + (when (buffer-live-p victim-buffer) (kill-buffer victim-buffer))))) + +(provide 'tp-surface-tests) +;;; tp-surface-tests.el ends here diff --git a/tp-reactive.el b/tp-reactive.el index 0742c6b..cc0fbd9 100644 --- a/tp-reactive.el +++ b/tp-reactive.el @@ -67,10 +67,19 @@ (defvar tp--transaction-binding-snapshots nil) (defvar tp--transaction-created-bindings nil) (defvar tp--transaction-recompute-counts nil) +(defvar tp--transaction-extensions nil) +(defvar tp--transaction-counter-start nil) +(defvar tp--transaction-after-commit-callbacks nil) (defvar tp--current-binding nil) (defvar tp--binding-compute-stack nil) (defvar tp--collected-dependency-set nil) (defvar tp--collected-dependencies nil) +(defvar tp--binding-touch-function nil) +(defvar tp--binding-changed-functions nil) +(defvar tp--transaction-publish-functions nil) +(defvar tp--transaction-rollback-functions nil) +(defvar tp--transaction-rollback-final-functions nil) +(defvar tp--transaction-committed-functions nil) (defun tp--counter-increment (key) "Increment reactive counter KEY." @@ -360,6 +369,8 @@ dirty target has recomputed." (tp-binding-initialized-p binding) t (tp-binding-revision binding) (1+ (tp-binding-revision binding))) + (run-hook-with-args 'tp--binding-changed-functions + binding old value) (tp--invalidate-subscribers binding requester)) (tp--counter-increment :skipped)) value))) @@ -433,6 +444,8 @@ EQUALITY compares values and LIFECYCLE controls retention." (tp--register-binding binding) (push binding tp--transaction-created-bindings) (tp--enqueue-binding binding)) + (when tp--binding-touch-function + (funcall tp--binding-touch-function binding)) binding)) (cl-defun tp-bind (owner key compute &key (equality #'equal) (lifecycle 'delete)) @@ -490,6 +503,46 @@ or `retain'." (lambda () (dolist (binding bindings) (tp--dispose-binding binding))))) (length bindings))) +(defun tp-binding-owner-bindings (owner) + "Return OWNER's live bindings ordered by stable binding id." + (when-let ((table (tp--owner-binding-table owner))) + (let (bindings) + (maphash (lambda (_key binding) (push binding bindings)) table) + (sort bindings (lambda (left right) + (< (tp-binding-id left) (tp-binding-id right))))))) + +(defun tp-binding-dispose (binding) + "Dispose BINDING and detach all of its graph edges." + (tp--validate-live-binding binding) + (if tp--transaction-active + (tp--dispose-binding binding) + (tp--call-with-transaction (lambda () (tp--dispose-binding binding)))) + nil) + +(defun tp--transaction-extension (key &optional create) + "Return transaction extension state for KEY. +When CREATE is non-nil, install and return a fresh hash table when absent." + (unless tp--transaction-active + (signal 'tp-reactive-error (list :outside-transaction key))) + (or (gethash key tp--transaction-extensions) + (when create + (let ((state (make-hash-table :test #'eq))) + (puthash key state tp--transaction-extensions) + state)))) + +(defun tp--transaction-counter-delta (key) + "Return active transaction counter delta for KEY." + (if tp--transaction-counter-start + (- (plist-get tp--reactive-counters key) + (plist-get tp--transaction-counter-start key)) + 0)) + +(defun tp--enqueue-after-commit (function) + "Run FUNCTION after the active outer transaction has exited." + (unless tp--transaction-active + (signal 'tp-reactive-error (list :outside-transaction function))) + (push function tp--transaction-after-commit-callbacks)) + (defun tp--dequeue-dirty-binding () "Return and remove the next queued dirty binding." (let (binding) @@ -554,27 +607,46 @@ or `retain'." "Call FUNCTION in one atomic signal and binding transaction." (if tp--transaction-active (funcall function) - (let ((tp--transaction-active t) - (tp--transaction-signal-values (make-hash-table :test #'eq)) - (tp--transaction-signals nil) - (tp--transaction-dirty-set (make-hash-table :test #'eq)) - (tp--transaction-dirty-queue nil) - (tp--transaction-binding-snapshots (make-hash-table :test #'eq)) - (tp--transaction-created-bindings nil) - (tp--transaction-recompute-counts (make-hash-table :test #'eq)) - (counter-snapshot (copy-sequence tp--reactive-counters)) - success result) - (unwind-protect - (progn - (setq result (funcall function)) - (tp--flush-dirty-bindings) - (tp--commit-signal-values) - (setq success t) - result) - (unless success - (let ((inhibit-quit t)) - (tp--rollback-bindings) - (setq tp--reactive-counters counter-snapshot))))))) + (let (after-commit result) + (setq result + (let ((tp--transaction-active t) + (tp--transaction-signal-values + (make-hash-table :test #'eq)) + (tp--transaction-signals nil) + (tp--transaction-dirty-set (make-hash-table :test #'eq)) + (tp--transaction-dirty-queue nil) + (tp--transaction-binding-snapshots + (make-hash-table :test #'eq)) + (tp--transaction-created-bindings nil) + (tp--transaction-recompute-counts + (make-hash-table :test #'eq)) + (tp--transaction-extensions (make-hash-table :test #'eq)) + (tp--transaction-after-commit-callbacks nil) + (counter-snapshot (copy-sequence tp--reactive-counters)) + (tp--transaction-counter-start nil) + success transaction-result) + (setq tp--transaction-counter-start counter-snapshot) + (unwind-protect + (progn + (setq transaction-result (funcall function)) + (tp--flush-dirty-bindings) + (run-hooks 'tp--transaction-publish-functions) + (tp--commit-signal-values) + (setq success t) + transaction-result) + (unless success + (let ((inhibit-quit t)) + (run-hooks 'tp--transaction-rollback-functions) + (tp--rollback-bindings) + (setq tp--reactive-counters counter-snapshot) + (run-hooks 'tp--transaction-rollback-final-functions)))) + (when success + (run-hooks 'tp--transaction-committed-functions) + (setq after-commit + (nreverse tp--transaction-after-commit-callbacks))) + transaction-result)) + (dolist (callback after-commit) (funcall callback)) + result))) ;;;###autoload (defmacro tp-with-transaction (&rest body) diff --git a/tp-surface.el b/tp-surface.el new file mode 100644 index 0000000..0c06f39 --- /dev/null +++ b/tp-surface.el @@ -0,0 +1,1938 @@ +;;; tp-surface.el --- Retained text surfaces and publication -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Geekinney + +;; Author: Geekinney (kinneyzhang666@gmail.com) + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3 of +;; the License, or (at your option) any later version. + +;;; Commentary: + +;; Generic retained plans, candidate object identity, marker-backed mounts, +;; range property ownership, side indexes, and atomic buffer publication. +;; This module knows nothing about a consumer's layout or domain vocabulary. + +;;; Code: + +(require 'cl-lib) +(require 'seq) +(require 'tp-core) +(require 'tp-style) +(require 'tp-reactive) + +(define-error 'tp-surface-error "TP retained surface error") +(define-error 'tp-invalid-surface-plan "Invalid TP surface plan" + 'tp-surface-error) +(define-error 'tp-duplicate-object-key "Duplicate TP object key" + 'tp-invalid-surface-plan) +(define-error 'tp-invalid-prepare-context "Invalid TP prepare context" + 'tp-surface-error) +(define-error 'tp-stale-object "Stale TP object" 'tp-surface-error) +(define-error 'tp-cross-surface-object "Cross-surface TP object" + 'tp-surface-error) +(define-error 'tp-orphan-object "Orphan TP object" 'tp-surface-error) +(define-error 'tp-capability-error "TP mount capability violation" + 'tp-surface-error) +(define-error 'tp-stale-mount "Stale TP mount" 'tp-surface-error) +(define-error 'tp-property-conflict "TP property ownership conflict" + 'tp-surface-error) +(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-unsupported-buffer "Unsupported TP surface buffer" + 'tp-surface-error) + +(cl-defstruct (tp-surface-plan (:constructor tp--make-surface-plan)) + "Pure retained node data accepted by a TP surface." + key kind text props children tags capability) + +(cl-defstruct (tp-surface-result + (:constructor tp--make-surface-result (plan client-state))) + "A producer result carrying PLAN and opaque CLIENT-STATE." + plan client-state) + +(cl-defstruct (tp-surface + (:constructor tp--make-surface) + (: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) + +(cl-defstruct (tp-object + (:constructor tp--make-surface-object) + (:conc-name tp--surface-object-)) + "Opaque retained identity local to one surface." + id surface parent key kind path live disposed candidate-context) + +(cl-defstruct (tp-prepare-context + (: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) + +(cl-defstruct (tp-range-anchor + (:constructor tp--make-range-anchor) + (:conc-name tp--anchor-)) + "Opaque marker-backed host text range." + id buffer start end boundary-policy live stale surfaces candidate-context) + +(cl-defstruct (tp--surface-mount (:constructor tp--make-surface-mount)) + object start end tags capability anchor) + +(cl-defstruct (tp--property-ledger (:constructor tp--make-property-ledger)) + start end property baseline-present baseline-value published-present + published-value anchors) + +(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) + +(cl-defstruct (tp--surface-snapshot (:constructor tp--make-surface-snapshot)) + plan objects mounts index ledger client-state producer revision report live + stale) + +(defvar tp--surface-id-counter 0) +(defvar tp--object-id-counter 0) +(defvar tp--anchor-id-counter 0) +(defvar tp--surface-transaction-id 0) +(defvar tp--surfaces (make-hash-table :test #'eql :weakness 'value)) +(defvar tp--current-prepare-context nil) +(defvar tp--surface-publishing nil) +(defvar tp--surface-publication-step-function nil) + +(defvar-local tp--buffer-surfaces nil) +(defvar-local tp--surface-character-tick 0) + +(defconst tp--surface-producer-key '(tp/surface . producer)) +(defconst tp--surface-extension-key 'tp-surface) + +(defun tp--plist-shape-p (value) + "Return non-nil when VALUE is an even property list with symbol keys." + (and (listp value) + (zerop (% (length value) 2)) + (cl-loop for (key _value) on value by #'cddr always (symbolp key)))) + +(defun tp--copy-opaque-value (value) + "Defensively copy conses, vectors, and strings in VALUE." + (cond ((functionp value) value) + ((stringp value) (copy-sequence value)) + ((consp value) + (cons (tp--copy-opaque-value (car value)) + (tp--copy-opaque-value (cdr value)))) + ((vectorp value) + (apply #'vector (mapcar #'tp--copy-opaque-value value))) + (t value))) + +(defun tp--validate-plan-fields (kind text props children capability) + "Validate plan KIND, TEXT, PROPS, CHILDREN, and CAPABILITY." + (unless kind + (signal 'tp-invalid-surface-plan (list :kind kind))) + (unless (or (null text) (stringp text)) + (signal 'tp-invalid-surface-plan (list :text text))) + (unless (tp--plist-shape-p props) + (signal 'tp-invalid-surface-plan (list :props props))) + (unless (and (listp children) (cl-every #'tp-surface-plan-p children)) + (signal 'tp-invalid-surface-plan (list :children children))) + (when (and text children) + (signal 'tp-invalid-surface-plan (list :text-and-children kind))) + (unless (memq capability '(nil content properties)) + (signal 'tp-capability-error (list capability)))) + +(defun tp--validate-sibling-keys (children) + "Reject duplicate explicit keys among CHILDREN." + (let ((seen (make-hash-table :test #'equal))) + (dolist (child children) + (when-let ((key (tp-surface-plan-key child))) + (when (gethash key seen) + (signal 'tp-duplicate-object-key (list key))) + (puthash key t seen))))) + +(defun tp--copy-surface-plan (plan) + "Return a validated defensive copy of PLAN." + (unless (tp-surface-plan-p plan) + (signal 'wrong-type-argument (list 'tp-surface-plan-p plan))) + (let* ((children (mapcar #'tp--copy-surface-plan + (tp-surface-plan-children plan))) + (kind (tp--copy-opaque-value (tp-surface-plan-kind plan))) + (text (and (tp-surface-plan-text plan) + (copy-sequence (tp-surface-plan-text plan)))) + (props (tp--copy-opaque-value (tp-surface-plan-props plan))) + (capability (tp-surface-plan-capability plan))) + (tp--validate-plan-fields kind text props children capability) + (tp--validate-sibling-keys children) + (tp--make-surface-plan + :key (tp--copy-opaque-value (tp-surface-plan-key plan)) + :kind kind :text text :props props :children children + :tags (tp--copy-opaque-value (tp-surface-plan-tags plan)) + :capability capability))) + +(cl-defun tp-surface-plan-create + (&key key kind text props children tags capability) + "Create a defensive surface plan node. +KEY is sibling-local identity, KIND is an opaque discriminator, TEXT is a +leaf string, PROPS are final direct text properties, CHILDREN are ordered +plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'." + (tp--copy-surface-plan + (tp--make-surface-plan + :key key :kind kind :text text :props props :children children + :tags tags :capability capability))) + +(defun tp-surface-result-create (plan &optional client-state) + "Return a producer result containing PLAN and opaque CLIENT-STATE." + (tp--make-surface-result (tp--copy-surface-plan plan) client-state)) + +(defun tp--plan-equal-p (left right) + "Return non-nil when LEFT and RIGHT plans are semantically equal." + (and (equal (tp-surface-plan-key left) (tp-surface-plan-key right)) + (equal (tp-surface-plan-kind left) (tp-surface-plan-kind right)) + (let ((a (tp-surface-plan-text left)) + (b (tp-surface-plan-text right))) + (if (and (stringp a) (stringp b)) + (equal-including-properties a b) + (equal a b))) + (equal (tp-surface-plan-props left) (tp-surface-plan-props right)) + (equal (tp-surface-plan-tags left) (tp-surface-plan-tags right)) + (eq (tp-surface-plan-capability left) + (tp-surface-plan-capability right)) + (let ((a (tp-surface-plan-children left)) + (b (tp-surface-plan-children right))) + (and (= (length a) (length b)) + (cl-every #'identity + (cl-mapcar #'tp--plan-equal-p a b)))))) + +(defun tp--hash-copy (table) + "Return a shallow copy of hash TABLE." + (let ((copy (make-hash-table :test (hash-table-test table)))) + (maphash (lambda (key value) (puthash key value copy)) table) + copy)) + +(defun tp--context-parent-key (context parent) + "Return the child-table key for PARENT in CONTEXT." + (or parent (tp--context-surface context))) + +(defun tp--context-child-table (context parent) + "Return CONTEXT's explicit child-key table for PARENT." + (let* ((owner (tp--context-parent-key context parent)) + (tables (tp--context-child-seen context))) + (or (gethash owner tables) + (let ((table (make-hash-table :test #'equal))) + (puthash owner table tables) + table)))) + +(defun tp--context-next-position (context parent) + "Return and advance CONTEXT's unkeyed child position for PARENT." + (let* ((owner (tp--context-parent-key context parent)) + (positions (tp--context-child-positions context)) + (position (gethash owner positions 0))) + (puthash owner (1+ position) positions) + position)) + +(defun tp--object-path-segment (context parent key kind) + "Return the candidate path segment for KEY and KIND below PARENT." + (if key + (let ((seen (tp--context-child-table context parent))) + (when (gethash key seen) + (signal 'tp-duplicate-object-key (list key))) + (puthash key t seen) + key) + (list :position (tp--context-next-position context parent) :kind kind))) + +(defun tp--validate-context-parent (context parent) + "Validate PARENT for candidate CONTEXT." + (when parent + (unless (tp-object-p parent) + (signal 'wrong-type-argument (list 'tp-object-p parent))) + (unless (eq (tp--surface-object-surface parent) + (tp--context-surface context)) + (signal 'tp-cross-surface-object (list parent))) + (unless (gethash (tp--surface-object-path parent) + (tp--context-objects context)) + (signal 'tp-stale-object (list parent))))) + +(defun tp--validate-prepare-context (context) + "Signal unless CONTEXT is active." + (unless (and (tp-prepare-context-p context) (tp--context-active context)) + (signal 'tp-invalid-prepare-context (list context)))) + +(defun tp--new-candidate-object (context parent key kind path) + "Create a candidate object in CONTEXT below PARENT at PATH." + (let ((object (tp--make-surface-object + :id (cl-incf tp--object-id-counter) + :surface (tp--context-surface context) :parent parent + :key (tp--copy-opaque-value key) :kind kind :path path + :candidate-context context))) + (push object (tp--context-new-objects context)) + object)) + +(defun tp-object-ensure (context parent key kind) + "Return candidate identity for KEY and KIND below PARENT in CONTEXT." + (tp--validate-prepare-context context) + (tp--validate-context-parent context parent) + (unless kind + (signal 'tp-invalid-surface-plan (list :kind kind))) + (let* ((segment (tp--object-path-segment context parent key kind)) + (path (append (and parent (tp--surface-object-path parent)) + (list segment))) + (objects (tp--context-objects context)) + (old (gethash path objects)) + (object (if (and old (equal kind (tp--surface-object-kind old))) + old + (tp--new-candidate-object context parent key kind path)))) + (puthash path object objects) + (puthash object t (tp--context-touched context)) + object)) + +(defun tp-object-live-p (object) + "Return non-nil when OBJECT is committed on a live surface." + (and (tp-object-p object) (tp--surface-object-live object) + (not (tp--surface-object-disposed object)) + (tp-surface-live-p (tp--surface-object-surface object)))) + +(defun tp-object-resolve (surface key-path) + "Resolve live object in SURFACE by explicit KEY-PATH without scanning text." + (tp--validate-live-surface surface) + (let ((object (gethash key-path (tp--surface-objects surface)))) + (and (tp-object-live-p object) object))) + +(defun tp--make-context (surface &optional ephemeral) + "Create a prepare context for SURFACE. +When EPHEMERAL is non-nil, no identity may be promoted." + (tp--make-prepare-context + :surface surface + :objects (if (tp--surface-objects surface) + (tp--hash-copy (tp--surface-objects surface)) + (make-hash-table :test #'equal)) + :touched (make-hash-table :test #'eq) + :bindings (make-hash-table :test #'eq) + :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--touch-context-binding (context binding) + "Record BINDING as touched by CONTEXT." + (let ((owner (tp-binding-owner binding))) + (unless (and (tp-object-p owner) + (eq (tp--surface-object-surface owner) + (tp--context-surface context))) + (signal 'tp-cross-surface-object (list owner))) + (puthash binding t (tp--context-bindings context)))) + +(defun tp--plist-overlay (parent child) + "Return a fresh plist where CHILD values override PARENT values." + (let ((result (copy-tree parent))) + (cl-loop for (property value) on child by #'cddr + do (setq result (plist-put result property value))) + result)) + +(defun tp--plan-segment (plan position) + "Return PLAN's path segment at sibling POSITION." + (or (tp-surface-plan-key plan) + (list :position position :kind (tp-surface-plan-kind plan)))) + +(defun tp--render-plan (plan context) + "Return PLAN's propertized string and side records in CONTEXT." + (let (records) + (cl-labels + ((walk (node path inherited offset) + (let* ((props (tp--plist-overlay + inherited (tp-surface-plan-props node))) + (begin offset) + (children (tp-surface-plan-children node)) + pieces) + (if children + (cl-loop for child in children for position from 0 + for child-path = + (append path (list (tp--plan-segment child position))) + for result = (walk child child-path props offset) + do (push (car result) pieces) + do (setq offset (cdr result))) + (let ((text (copy-sequence + (or (tp-surface-plan-text node) "")))) + (when (> (length text) 0) + (add-text-properties 0 (length text) props text)) + (push text pieces) + (setq offset (+ offset (length text))))) + (let ((object (gethash path (tp--context-objects context)))) + (unless object + (signal 'tp-orphan-object (list path))) + (push (list :path path :object object :start begin :end offset + :props props :tags (tp-surface-plan-tags node)) + records)) + (cons (apply #'concat (nreverse pieces)) offset)))) + (let* ((path (list (tp--plan-segment plan 0))) + (result (walk plan path nil 0))) + (cons (car result) (nreverse records)))))) + +(defun tp--ensure-plan-objects (context plan &optional parent) + "Ensure identities for PLAN recursively below PARENT in CONTEXT." + (let ((object (tp-object-ensure + context parent (tp-surface-plan-key plan) + (tp-surface-plan-kind plan)))) + (dolist (child (tp-surface-plan-children plan)) + (tp--ensure-plan-objects context child object)) + object)) + +(defun tp--plan-paths (plan) + "Return PLAN's object paths in traversal order." + (let (paths) + (cl-labels + ((walk (node path) + (push path paths) + (cl-loop for child in (tp-surface-plan-children node) + for position from 0 + do (walk child + (append path + (list (tp--plan-segment child position))))))) + (walk plan (list (tp--plan-segment plan 0)))) + (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) + (maphash (lambda (object _present) + (push (tp--surface-object-path object) actual)) + (tp--context-touched context)) + (dolist (path expected) + (unless (member path actual) + (signal 'tp-orphan-object (list :missing path)))) + (dolist (path actual) + (unless (member path expected) + (signal 'tp-orphan-object (list :extra path)))))) + +(defun tp--validate-plan-capability (plan capability) + "Validate PLAN recursively against mount CAPABILITY." + (let ((declared (tp-surface-plan-capability plan))) + (when (and declared (not (eq declared capability))) + (signal 'tp-capability-error (list declared capability))) + (when (and (eq capability 'properties) (tp-surface-plan-text plan)) + (signal 'tp-capability-error (list :properties-text))) + (dolist (child (tp-surface-plan-children plan)) + (tp--validate-plan-capability child capability)))) + +(defun tp--producer-result (value surface options) + "Normalize producer VALUE for SURFACE using OPTIONS." + (cond + ((tp-surface-result-p value) + (cons (tp--copy-surface-plan (tp-surface-result-plan value)) + (tp-surface-result-client-state value))) + ((tp-surface-plan-p value) + (cons (tp--copy-surface-plan value) + (if (plist-member options :client-state) + (plist-get options :client-state) + (tp--surface-client-state surface)))) + (t (signal 'tp-invalid-surface-plan (list value))))) + +(defun tp--context-binding-removals (context objects) + "Return default-lifecycle bindings omitted from CONTEXT among OBJECTS." + (cl-loop for object in objects append + (cl-loop for binding in (tp-binding-owner-bindings object) + unless (or (gethash binding (tp--context-bindings context)) + (eq (tp-binding-lifecycle binding) 'retain)) + collect binding))) + +(defun tp--context-live-objects (surface) + "Return SURFACE's current objects." + (let (objects) + (when (tp--surface-objects surface) + (maphash (lambda (_path object) (push object objects)) + (tp--surface-objects surface))) + objects)) + +(defun tp--object-set-difference (left right) + "Return objects in LEFT that are not `eq' to an object in RIGHT." + (cl-remove-if (lambda (object) (memq object right)) left)) + +(defun tp--plan-key-positions (plan) + "Return an alist from PLAN keyed paths to sibling positions." + (let (positions) + (cl-labels + ((walk (node path) + (cl-loop for child in (tp-surface-plan-children node) + for position from 0 + for key = (tp-surface-plan-key child) + for child-path = (and key (append path (list key))) + when key do (push (cons child-path position) positions) + do (walk child + (or child-path + (append path + (list (tp--plan-segment + child position)))))))) + (walk plan (list (tp--plan-segment plan 0)))) + positions)) + +(defun tp--plan-moved-count (old new) + "Return the number of keyed objects moved between OLD and NEW plans." + (if (null old) + 0 + (let ((old-positions (tp--plan-key-positions old))) + (cl-loop for (path . position) in (tp--plan-key-positions new) + for old-position = (alist-get path old-positions nil nil #'equal) + count (and old-position (/= old-position position)))))) + +(defun tp--candidate-object-list (context) + "Return CONTEXT's touched objects." + (let (objects) + (maphash (lambda (object _present) (push object objects)) + (tp--context-touched context)) + objects)) + +(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--properties-mount-specs records context))) + +(defun tp--ranges-overlap-p (left-start left-end right-start right-end) + "Return non-nil when the two nonempty half-open ranges overlap." + (and (< left-start left-end) (< right-start right-end) + (< left-start right-end) (< right-start left-end))) + +(defun tp--candidate-ranges (surface mount-specs rendered) + "Return absolute candidate ranges for SURFACE." + (if (eq (tp--surface-capability surface) 'content) + (let ((start (marker-position (tp--surface-start surface)))) + (list (cons start (+ start (length rendered))))) + (mapcar (lambda (spec) + (cons (plist-get spec :start) (plist-get spec :end))) + mount-specs))) + +(defun tp--validate-cross-surface-ranges (surface mount-specs rendered) + "Reject overlapping ownership between SURFACE and other live surfaces." + (let ((ranges (tp--candidate-ranges surface mount-specs rendered))) + (with-current-buffer (tp--surface-buffer surface) + (dolist (other tp--buffer-surfaces) + (unless (eq other surface) + (dolist (mount (tp--surface-mounts other)) + (let ((start (marker-position (tp--surface-mount-start mount))) + (end (marker-position (tp--surface-mount-end mount)))) + (when (cl-some (lambda (range) + (tp--ranges-overlap-p + (car range) (cdr range) start end)) + ranges) + (signal 'tp-capability-error + (list :cross-surface-overlap + (tp--surface-id other))))))))))) + +(defun tp--prepare-input (surface input options context) + "Run INPUT for SURFACE in CONTEXT and normalize its result." + (let ((tp--current-prepare-context context) + (tp--binding-touch-function + (lambda (binding) (tp--touch-context-binding context binding)))) + (if (functionp input) + (tp--producer-result (funcall input context) surface options) + (let ((plan (tp--copy-surface-plan input))) + (tp--ensure-plan-objects context plan) + (tp--producer-result plan surface options))))) + +(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)) + (success nil) + result) + (unwind-protect + (let* ((normalized (tp--prepare-input surface input options context)) + (plan (car normalized)) + (client-state (cdr normalized)) + (_capability (tp--validate-plan-capability + plan (tp--surface-capability surface))) + (_tree (tp--validate-context-tree context plan)) + (render-result (tp--render-plan plan context)) + (rendered (car render-result)) + (records (cdr render-result)) + (objects (tp--candidate-object-list context)) + (old-objects (tp--context-live-objects surface)) + (created (tp--object-set-difference objects old-objects)) + (removed (tp--object-set-difference old-objects objects)) + (mount-specs (tp--plan-record-mount-specs + records (tp--surface-capability surface) context)) + (_ranges (tp--validate-cross-surface-ranges + surface mount-specs rendered)) + (property-result + (when (eq (tp--surface-capability surface) 'properties) + (tp--prepare-property-ledger surface mount-specs)))) + (setq result + (tp--make-prepared-surface + :surface surface :context context :plan plan :rendered rendered + :mount-specs mount-specs :ledger-specs (car property-result) + :property-operations (cdr property-result) :objects objects + :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)))) + (setq success t) + result) + (unless success (tp--discard-context context))))) + +(defun tp--validate-buffer-range (buffer start end) + "Validate START and END as an ordered live range in BUFFER." + (unless (buffer-live-p buffer) + (signal 'tp-unsupported-buffer (list buffer))) + (with-current-buffer buffer + (save-restriction + (widen) + (unless (and (integer-or-marker-p start) (integer-or-marker-p end) + (<= (point-min) start) (<= start end) (<= end (point-max))) + (signal 'args-out-of-range (list buffer start end)))))) + +(cl-defun tp-range-anchor-create + (buffer start end &key (start-insertion-type nil) (end-insertion-type t) + (boundary-policy 'stale)) + "Create an opaque marker-backed range in BUFFER from START to END. +START-INSERTION-TYPE and END-INSERTION-TYPE control marker movement. +BOUNDARY-POLICY is `stale', `shorten', or `remove'." + (tp--validate-buffer-range buffer start end) + (unless (memq boundary-policy '(stale shorten remove)) + (signal 'tp-invalid-range-anchor (list boundary-policy))) + (let ((anchor (tp--make-range-anchor + :id (cl-incf tp--anchor-id-counter) :buffer buffer + :start (copy-marker start start-insertion-type) + :end (copy-marker end end-insertion-type) + :boundary-policy boundary-policy :live t + :candidate-context tp--current-prepare-context))) + (when tp--current-prepare-context + (push anchor (tp--context-created-anchors tp--current-prepare-context))) + anchor)) + +(defun tp-range-anchor-live-p (anchor) + "Return non-nil when ANCHOR still has live markers." + (and (tp-range-anchor-p anchor) (tp--anchor-live anchor) + (buffer-live-p (tp--anchor-buffer anchor)) + (marker-position (tp--anchor-start anchor)) + (marker-position (tp--anchor-end anchor)))) + +(defun tp--validate-anchor (anchor surface) + "Validate ANCHOR for SURFACE." + (unless (tp-range-anchor-live-p anchor) + (signal 'tp-invalid-range-anchor (list anchor))) + (unless (eq (tp--anchor-buffer anchor) (tp--surface-buffer surface)) + (signal 'tp-cross-surface-object (list anchor surface))) + (when (and (tp--anchor-surfaces anchor) + (not (memq surface (tp--anchor-surfaces anchor)))) + (signal 'tp-cross-surface-object (list anchor surface))) + (when (tp--anchor-stale anchor) + (signal 'tp-stale-mount (list (tp--anchor-id anchor))))) + +(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-anchor anchor (tp--context-surface context)) + (when (gethash object (tp--context-attachments context)) + (signal 'tp-invalid-range-anchor (list :duplicate object))) + (puthash object anchor (tp--context-attachments context)) + object) + +(defun tp--properties-mount-specs (records context) + "Return properties mount specs from RECORDS and CONTEXT attachments." + (let (specs) + (dolist (record records) + (let* ((object (plist-get record :object)) + (anchor (gethash object (tp--context-attachments context)))) + (when anchor + (push (list :object object :anchor anchor + :start (marker-position (tp--anchor-start anchor)) + :end (marker-position (tp--anchor-end anchor)) + :props (plist-get record :props) + :tags (tp--copy-opaque-value (plist-get record :tags))) + specs)))) + (maphash + (lambda (object _anchor) + (unless (cl-find object records :key (lambda (item) + (plist-get item :object)) + :test #'eq) + (signal 'tp-orphan-object (list object)))) + (tp--context-attachments context)) + (nreverse specs))) + +(defun tp--property-state-at (buffer position property) + "Return direct PROPERTY presence and value at POSITION in BUFFER." + (with-current-buffer buffer + (let ((cell (plist-member (text-properties-at position buffer) property))) + (cons (and cell t) (and cell (cadr cell)))))) + +(defun tp--property-state-equal-p (left right) + "Return non-nil when property states LEFT and RIGHT are equal." + (and (eq (car left) (car right)) + (equal (cdr left) (cdr right)))) + +(defun tp--ledger-position (marker) + "Return live MARKER position or signal a stale-mount error." + (or (marker-position marker) + (signal 'tp-stale-mount (list marker)))) + +(defun tp--old-ledger-at (surface position property) + "Return SURFACE ledger entry covering POSITION for PROPERTY." + (cl-find-if + (lambda (entry) + (and (eq property (tp--property-ledger-property entry)) + (<= (tp--ledger-position (tp--property-ledger-start entry)) position) + (< position (tp--ledger-position (tp--property-ledger-end entry))))) + (tp--surface-ledger surface))) + +(defun tp--contribution-properties (mount-specs surface) + "Return all property names in MOUNT-SPECS and SURFACE's old ledger." + (let (properties) + (dolist (spec mount-specs) + (cl-loop for (property _value) on (plist-get spec :props) by #'cddr + do (cl-pushnew property properties :test #'eq))) + (dolist (entry (tp--surface-ledger surface)) + (cl-pushnew (tp--property-ledger-property entry) properties :test #'eq)) + properties)) + +(defun tp--property-boundaries (buffer mount-specs surface properties) + "Return sorted candidate interval boundaries in BUFFER." + (let (boundaries) + (dolist (spec mount-specs) + (push (plist-get spec :start) boundaries) + (push (plist-get spec :end) boundaries)) + (dolist (entry (tp--surface-ledger surface)) + (push (tp--ledger-position (tp--property-ledger-start entry)) boundaries) + (push (tp--ledger-position (tp--property-ledger-end entry)) boundaries)) + (setq boundaries (sort (delete-dups boundaries) #'<)) + (when boundaries + (let ((minimum (car boundaries)) (maximum (car (last boundaries)))) + (with-current-buffer buffer + (dolist (property properties) + (let ((position minimum)) + (while (< position maximum) + (setq position (next-single-property-change + position property buffer maximum)) + (push position boundaries))))))) + (sort (delete-dups boundaries) #'<))) + +(defun tp--covering-contributions (mount-specs start end property) + "Return ordered MOUNT-SPECS covering START..END and declaring PROPERTY." + (cl-remove-if-not + (lambda (spec) + (and (<= (plist-get spec :start) start) + (>= (plist-get spec :end) end) + (plist-member (plist-get spec :props) property))) + mount-specs)) + +(defun tp--merge-property-contributions (baseline contributions property) + "Merge PROPERTY CONTRIBUTIONS over BASELINE property state." + (let ((state baseline) + (merge (tp-property-schema-merge + (tp-register-text-property property)))) + (dolist (spec contributions) + (let ((value (plist-get (plist-get spec :props) property))) + (setq state + (cons t (if (null value) + nil + (if (car state) + (funcall merge (cdr state) value) + value)))))) + state)) + +(defun tp--ledger-baseline-state (old current) + "Return OLD ledger baseline state, or CURRENT when there is no OLD entry." + (if old + (cons (tp--property-ledger-baseline-present old) + (tp--property-ledger-baseline-value old)) + current)) + +(defun tp--ledger-published-state (entry) + "Return ENTRY's last published property state." + (cons (tp--property-ledger-published-present entry) + (tp--property-ledger-published-value entry))) + +(defun tp--property-segment-result + (surface mount-specs start end property) + "Prepare one PROPERTY segment from START to END for SURFACE." + (let* ((buffer (tp--surface-buffer surface)) + (current (tp--property-state-at buffer start property)) + (old (tp--old-ledger-at surface start property)) + (contributions + (tp--covering-contributions mount-specs start end property))) + (when (and old (not (tp--property-state-equal-p + current (tp--ledger-published-state old)))) + (signal 'tp-property-conflict + (list (tp--surface-id surface) start end property current))) + (let* ((baseline (tp--ledger-baseline-state old current)) + (target (tp--merge-property-contributions + baseline contributions property)) + (anchors (delete-dups + (mapcar (lambda (spec) (plist-get spec :anchor)) + contributions)))) + (list :operation + (unless (tp--property-state-equal-p current target) + (list :start start :end end :property property + :present (car target) :value (cdr target))) + :ledger + (when contributions + (list :start start :end end :property property + :baseline-present (car baseline) + :baseline-value (cdr baseline) + :published-present (car target) + :published-value (cdr target) :anchors anchors)))))) + +(defun tp--prepare-property-ledger (surface mount-specs) + "Return candidate ledger specs and property operations for SURFACE." + (let* ((buffer (tp--surface-buffer surface)) + (properties (tp--contribution-properties mount-specs surface)) + (boundaries (tp--property-boundaries + buffer mount-specs surface properties)) + ledger operations) + (cl-loop for (start end) on boundaries while end do + (dolist (property properties) + (let ((result (tp--property-segment-result + surface mount-specs start end property))) + (when-let ((entry (plist-get result :ledger))) + (push entry ledger)) + (when-let ((operation (plist-get result :operation))) + (push operation operations))))) + (cons (nreverse ledger) (nreverse operations)))) + +(defun tp--validate-live-surface (surface) + "Signal unless SURFACE is live and its buffer exists." + (unless (tp-surface-p surface) + (signal 'wrong-type-argument (list 'tp-surface-p surface))) + (unless (and (tp--surface-live surface) + (buffer-live-p (tp--surface-buffer surface))) + (signal 'tp-dead-surface (list (and (tp-surface-p surface) + (tp--surface-id surface)))))) + +(defun tp-surface-live-p (surface) + "Return non-nil when SURFACE is mounted in a live buffer." + (and (tp-surface-p surface) (tp--surface-live surface) + (buffer-live-p (tp--surface-buffer surface)))) + +(defun tp-surface-revision (surface) + "Return SURFACE's committed revision." + (unless (tp-surface-p surface) + (signal 'wrong-type-argument (list 'tp-surface-p surface))) + (tp--surface-revision surface)) + +(defun tp-surface-client-state (surface) + "Return SURFACE's opaque committed client state." + (tp--validate-live-surface surface) + (tp--surface-client-state surface)) + +(defun tp--validate-surface-buffer (surface initial) + "Validate SURFACE's buffer before prepare; INITIAL permits a candidate." + (let ((buffer (tp--surface-buffer surface))) + (unless (buffer-live-p buffer) + (signal 'tp-dead-surface (list (tp--surface-id surface)))) + (when (buffer-base-buffer buffer) + (signal 'tp-unsupported-buffer (list :indirect buffer))) + (unless (or initial (tp--surface-live surface)) + (signal 'tp-dead-surface (list (tp--surface-id surface)))) + (with-current-buffer buffer + (when (and buffer-read-only + (not (plist-get (tp--surface-options surface) + :inhibit-read-only))) + (signal 'buffer-read-only (list buffer)))))) + +(defun tp--surface-range (surface) + "Return SURFACE's live start and end positions." + (let ((start (marker-position (tp--surface-start surface))) + (end (marker-position (tp--surface-end surface)))) + (unless (and start end) + (signal 'tp-stale-mount (list (tp--surface-id surface)))) + (cons start end))) + +(defun tp--create-surface (buffer capability options) + "Create an unmounted surface candidate for BUFFER." + (unless (memq capability '(content properties)) + (signal 'tp-capability-error (list capability))) + (when (buffer-base-buffer buffer) + (signal 'tp-unsupported-buffer (list :indirect buffer))) + (let* ((range (with-current-buffer buffer + (save-restriction + (widen) + (cons (or (plist-get options :start) (point-min)) + (or (plist-get options :end) (point-max)))))) + (_valid (tp--validate-buffer-range buffer (car range) (cdr range)))) + (tp--make-surface + :id (cl-incf tp--surface-id-counter) :buffer buffer + :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 + :ledger nil :revision 0 :live nil :stale nil + :observers (copy-sequence (plist-get options :observers))))) + +(defun tp--surface-compute-function (surface input options initial) + "Return the producer binding function for SURFACE and INPUT." + (lambda () + (tp--prepare-surface + surface input options (and initial (not (tp--surface-live surface)))))) + +(defun tp--install-surface-producer (surface input options initial) + "Install INPUT as SURFACE's producer binding." + (let ((binding + (tp-bind surface tp--surface-producer-key + (tp--surface-compute-function surface input options initial) + :equality (lambda (_old _new) nil) :lifecycle 'retain))) + (setf (tp--surface-producer-binding surface) binding) + binding)) + +(defun tp--dispose-marker (marker) + "Detach MARKER when it is live." + (when (markerp marker) (set-marker marker nil))) + +(defun tp--dispose-anchor (anchor) + "Invalidate ANCHOR and detach its markers." + (when (and (tp-range-anchor-p anchor) (tp--anchor-live anchor)) + (tp--dispose-marker (tp--anchor-start anchor)) + (tp--dispose-marker (tp--anchor-end anchor)) + (setf (tp--anchor-live anchor) nil + (tp--anchor-stale anchor) t + (tp--anchor-surfaces anchor) nil))) + +(defun tp--discard-new-objects (context) + "Invalidate CONTEXT's uncommitted object handles." + (dolist (object (tp--context-new-objects context)) + (unless (tp--surface-object-live object) + (tp-binding-dispose-owner object) + (setf (tp--surface-object-disposed object) t + (tp--surface-object-candidate-context object) nil)))) + +(defun tp--discard-context (context) + "Release unpromoted handles owned by CONTEXT." + (when (and (tp-prepare-context-p context) (tp--context-active context)) + (setf (tp--context-active context) nil) + (tp--discard-new-objects context) + (dolist (anchor (tp--context-created-anchors context)) + (unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor))))) + +(defun tp--surface-mount-cleanup (surface) + "Release candidate markers and bindings for failed SURFACE mount." + (tp-binding-dispose-owner surface) + (tp--dispose-marker (tp--surface-start surface)) + (tp--dispose-marker (tp--surface-end surface)) + (setf (tp--surface-live surface) nil)) + +;;;###autoload +(defun tp-surface-mount (buffer plan-or-producer &optional options) + "Mount PLAN-OR-PRODUCER into BUFFER according to OPTIONS. +OPTIONS accepts :capability (`content' or `properties'), :start, :end, +:inhibit-read-only, :client-state, and :observers. Return a surface handle." + (let* ((target (get-buffer buffer)) + (_live (unless (buffer-live-p target) + (signal 'tp-unsupported-buffer (list buffer)))) + (capability (or (plist-get options :capability) + (and (tp-surface-plan-p plan-or-producer) + (tp-surface-plan-capability plan-or-producer)) + 'content)) + (surface (tp--create-surface target capability options)) + success) + (unwind-protect + (progn + (tp--install-surface-producer surface plan-or-producer options t) + (setq success t) + surface) + (unless success (tp--surface-mount-cleanup surface))))) + +;;;###autoload +(defun tp-surface-update (surface plan-or-producer) + "Atomically update SURFACE from PLAN-OR-PRODUCER and return its report." + (tp--validate-live-surface surface) + (tp--install-surface-producer + surface plan-or-producer (tp--surface-options surface) nil) + (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) + (and (> beg start) (< beg end)) + (and (>= beg start) (< beg end)))) + +(defun tp--mark-anchor-after-edit (anchor beg old-length) + "Apply ANCHOR's boundary policy after an edit at BEG." + (let ((start (marker-position (tp--anchor-start anchor))) + (end (marker-position (tp--anchor-end anchor)))) + (when (and start end (tp--edit-touches-span-p beg old-length start end)) + (pcase (tp--anchor-boundary-policy anchor) + ('shorten nil) + ('remove (setf (tp--anchor-stale anchor) 'remove)) + (_ (setf (tp--anchor-stale anchor) t)))))) + +(defun tp--surface-after-change (beg _end old-length) + "Maintain retained mount staleness after a host edit at BEG." + (let* ((tick (buffer-chars-modified-tick)) + (character-change (/= tick tp--surface-character-tick))) + (setq tp--surface-character-tick tick) + (when (and character-change (not tp--surface-publishing)) + (dolist (surface tp--buffer-surfaces) + (when (tp-surface-live-p surface) + (if (eq (tp--surface-capability surface) 'content) + (pcase-let ((`(,start . ,end) (tp--surface-range surface))) + (when (tp--edit-touches-span-p beg old-length start end) + (setf (tp--surface-stale surface) t))) + (dolist (mount (tp--surface-mounts surface)) + (when-let ((anchor (tp--surface-mount-anchor mount))) + (tp--mark-anchor-after-edit anchor beg old-length))))))))) + +(defun tp--surface-buffer-killed () + "Dispose every retained surface owned by the current buffer." + (let ((surfaces tp--buffer-surfaces)) + (setq tp--buffer-surfaces nil) + (dolist (surface surfaces) (tp--teardown-surface surface t)))) + +(defun tp--register-live-surface (surface) + "Register committed SURFACE under its buffer lifecycle owner." + (puthash (tp--surface-id surface) surface tp--surfaces) + (with-current-buffer (tp--surface-buffer surface) + (cl-pushnew surface tp--buffer-surfaces :test #'eq) + (setq tp--surface-character-tick (buffer-chars-modified-tick)) + (add-hook 'after-change-functions #'tp--surface-after-change nil t) + (add-hook 'kill-buffer-hook #'tp--surface-buffer-killed nil t))) + +(defun tp--surface-extension-state () + "Return the surface extension state for the active transaction." + (tp--transaction-extension tp--surface-extension-key t)) + +(defun tp--surface-prepared-table () + "Return the transaction-local surface candidate table." + (let ((state (tp--surface-extension-state))) + (or (gethash 'prepared state) + (let ((table (make-hash-table :test #'eq))) + (puthash 'prepared table state) + table)))) + +(defun tp--surface-binding-changed (binding _old new) + "Queue NEW when BINDING is a retained surface producer." + (when (and (equal (tp-binding-key binding) tp--surface-producer-key) + (tp-surface-p (tp-binding-owner binding))) + (unless (tp--prepared-surface-p new) + (signal 'tp-invalid-surface-plan (list :producer-result new))) + (let* ((table (tp--surface-prepared-table)) + (surface (tp-binding-owner binding)) + (previous (gethash surface table))) + (when previous + (tp--discard-context (tp--prepared-surface-context previous))) + (puthash surface new table)))) + +(defun tp--prepared-mount-signature (prepared) + "Return PREPARED's stable mount attachment signature." + (mapcar (lambda (spec) + (list (plist-get spec :object) (plist-get spec :anchor) + (plist-get spec :start) (plist-get spec :end) + (plist-get spec :tags))) + (tp--prepared-surface-mount-specs prepared))) + +(defun tp--live-mount-signature (surface) + "Return SURFACE's stable live mount signature." + (let ((base (if (eq (tp--surface-capability surface) 'content) + (marker-position (tp--surface-start surface)) + 0))) + (mapcar (lambda (mount) + (list (tp--surface-mount-object mount) + (tp--surface-mount-anchor mount) + (- (marker-position (tp--surface-mount-start mount)) base) + (- (marker-position (tp--surface-mount-end mount)) base) + (tp--surface-mount-tags mount))) + (tp--surface-mounts surface)))) + +(defun tp--content-output-equal-p (prepared) + "Return non-nil when PREPARED already matches its content mount." + (let ((surface (tp--prepared-surface-surface prepared))) + (if (not (eq (tp--surface-capability surface) 'content)) + t + (pcase-let ((`(,start . ,end) (tp--surface-range surface))) + (with-current-buffer (tp--surface-buffer surface) + (save-restriction + (widen) + (equal-including-properties + (buffer-substring start end) + (tp--prepared-surface-rendered prepared)))))))) + +(defun tp--prepared-changed-p (prepared) + "Return non-nil when PREPARED changes its committed surface." + (let ((surface (tp--prepared-surface-surface prepared))) + (or (tp--prepared-surface-initial prepared) + (not (tp--plan-equal-p (tp--surface-plan surface) + (tp--prepared-surface-plan prepared))) + (not (equal (tp--surface-client-state surface) + (tp--prepared-surface-client-state prepared))) + (not (eq (tp--surface-producer surface) + (tp--prepared-surface-producer prepared))) + (tp--prepared-surface-created prepared) + (tp--prepared-surface-removed prepared) + (not (tp--content-output-equal-p prepared)) + (not (equal (tp--live-mount-signature surface) + (tp--prepared-mount-signature prepared)))))) + +(defun tp--sorted-prepared-surfaces (table) + "Return changed candidates in TABLE ordered by surface id." + (let (prepared) + (maphash (lambda (_surface candidate) + (when (tp--prepared-changed-p candidate) + (push candidate prepared))) + table) + (sort prepared + (lambda (left right) + (< (tp--surface-id (tp--prepared-surface-surface left)) + (tp--surface-id (tp--prepared-surface-surface right))))))) + +(defun tp--publication-step (step surface) + "Run the internal publication failure hook for STEP and SURFACE." + (when tp--surface-publication-step-function + (funcall tp--surface-publication-step-function step surface))) + +(defun tp--common-prefix-length (left right) + "Return the common character prefix length of LEFT and RIGHT." + (let ((limit (min (length left) (length right))) (index 0)) + (while (and (< index limit) (= (aref left index) (aref right index))) + (setq index (1+ index))) + index)) + +(defun tp--common-suffix-length (left right prefix) + "Return LEFT and RIGHT's common suffix length after PREFIX." + (let ((limit (- (min (length left) (length right)) prefix)) (count 0)) + (while (and (< count limit) + (= (aref left (- (length left) count 1)) + (aref right (- (length right) count 1)))) + (setq count (1+ count))) + count)) + +(defun tp--content-text-operation (surface rendered) + "Publish SURFACE's minimal character replacement for RENDERED." + (pcase-let* ((`(,start . ,end) (tp--surface-range surface)) + (old (buffer-substring-no-properties start end)) + (new (substring-no-properties rendered)) + (prefix (tp--common-prefix-length old new)) + (suffix (tp--common-suffix-length old new prefix))) + (unless (equal old new) + (delete-region (+ start prefix) (- end suffix)) + (goto-char (+ start prefix)) + (insert (substring new prefix (- (length new) suffix)))) + (set-marker (tp--surface-start surface) start) + (set-marker (tp--surface-end surface) (+ start (length new))) + (if (equal old new) 0 1))) + +(defun tp--string-property-run-diff-p (buffer start rendered from to) + "Return non-nil when BUFFER differs from RENDERED on FROM..TO." + (cl-loop for offset from from below to + 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)) + (props (text-properties-at offset rendered))) + (when (tp--string-property-run-diff-p + buffer start rendered offset next) + (push (list :start (+ start offset) :end (+ start next) + :props props) + operations)) + (setq offset next))) + (nreverse operations))) + +(defun tp--apply-content-property-operations (buffer operations) + "Apply content property OPERATIONS in BUFFER silently." + (with-current-buffer buffer + (with-silent-modifications + (dolist (operation operations) + (set-text-properties (plist-get operation :start) + (plist-get operation :end) + (plist-get operation :props) buffer))))) + +(defun tp--apply-property-operation (buffer operation) + "Apply one host-range property OPERATION in BUFFER." + (let ((start (plist-get operation :start)) + (end (plist-get operation :end)) + (property (plist-get operation :property))) + (if (plist-get operation :present) + (put-text-property start end property + (plist-get operation :value) buffer) + (remove-list-of-text-properties start end (list property) buffer)))) + +(defun tp--apply-properties-operations (surface operations) + "Apply properties-only OPERATIONS for SURFACE silently." + (let ((buffer (tp--surface-buffer surface))) + (with-current-buffer buffer + (with-silent-modifications + (dolist (operation operations) + (tp--apply-property-operation buffer operation)))))) + +(defun tp--make-content-mounts (prepared) + "Create marker-backed content mounts for PREPARED." + (let* ((surface (tp--prepared-surface-surface prepared)) + (buffer (tp--surface-buffer surface)) + (base (marker-position (tp--surface-start surface)))) + (mapcar + (lambda (spec) + (tp--make-surface-mount + :object (plist-get spec :object) + :start (with-current-buffer buffer + (copy-marker (+ base (plist-get spec :start)) nil)) + :end (with-current-buffer buffer + (copy-marker (+ base (plist-get spec :end)) t)) + :tags (plist-get spec :tags) :capability 'content)) + (tp--prepared-surface-mount-specs prepared)))) + +(defun tp--make-properties-mounts (prepared) + "Create property mounts for PREPARED from its live anchors." + (mapcar + (lambda (spec) + (let ((anchor (plist-get spec :anchor))) + (tp--make-surface-mount + :object (plist-get spec :object) + :start (tp--anchor-start anchor) :end (tp--anchor-end anchor) + :tags (plist-get spec :tags) :capability 'properties :anchor anchor))) + (tp--prepared-surface-mount-specs prepared))) + +(defun tp--make-live-ledger (prepared) + "Create marker-backed property ledger entries for PREPARED." + (let ((buffer (tp--surface-buffer (tp--prepared-surface-surface prepared)))) + (mapcar + (lambda (spec) + (tp--make-property-ledger + :start (with-current-buffer buffer + (copy-marker (plist-get spec :start) nil)) + :end (with-current-buffer buffer + (copy-marker (plist-get spec :end) t)) + :property (plist-get spec :property) + :baseline-present (plist-get spec :baseline-present) + :baseline-value (plist-get spec :baseline-value) + :published-present (plist-get spec :published-present) + :published-value (plist-get spec :published-value) + :anchors (plist-get spec :anchors))) + (tp--prepared-surface-ledger-specs prepared)))) + +(defun tp--create-candidate-mount-state (prepared) + "Create PREPARED's marker-backed mount, ledger, and index candidates." + (let* ((surface (tp--prepared-surface-surface prepared)) + (mounts (if (eq (tp--surface-capability surface) 'content) + (tp--make-content-mounts prepared) + (tp--make-properties-mounts prepared))) + (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-ledger prepared) ledger) + mounts)) + +(defun tp--surface-snapshot (surface) + "Return a rollback snapshot of SURFACE side state." + (tp--make-surface-snapshot + :plan (tp--surface-plan surface) :objects (tp--surface-objects surface) + :mounts (tp--surface-mounts surface) :index (tp--surface-index surface) + :ledger (tp--surface-ledger surface) + :client-state (tp--surface-client-state surface) + :producer (tp--surface-producer surface) + :revision (tp--surface-revision surface) :report (tp--surface-report surface) + :live (tp--surface-live surface) :stale (tp--surface-stale surface))) + +(defun tp--surface-object-table (objects) + "Return a path-indexed hash table containing OBJECTS." + (let ((table (make-hash-table :test #'equal))) + (dolist (object objects) + (puthash (tp--surface-object-path object) object table)) + table)) + +(defun tp--surface-report-value (prepared text-ops property-ops) + "Build PREPARED's generic commit report." + (let* ((surface (tp--prepared-surface-surface prepared)) + (old-revision (tp--surface-revision surface)) + (new-revision (1+ old-revision))) + (list :transaction-id tp--surface-transaction-id + :surface-id (tp--surface-id surface) + :old-revision old-revision :new-revision new-revision + :candidate-source-writes (length tp--transaction-signals) + :invalidated-bindings (tp--transaction-counter-delta :invalidated) + :recomputed-bindings (tp--transaction-counter-delta :recomputed) + :skipped-bindings (tp--transaction-counter-delta :skipped) + :reconciled-objects (tp--prepared-surface-reconciled prepared) + :created-objects (length (tp--prepared-surface-created prepared)) + :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 + :failure nil :observer-errors nil :timing nil))) + +(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)) + (text-operations 0) + property-operations) + (with-current-buffer buffer + (save-restriction + (widen) + (let ((inhibit-read-only + (plist-get (tp--surface-options surface) :inhibit-read-only))) + (setq text-operations + (tp--content-text-operation surface rendered)) + (tp--publication-step 'text surface) + (setq property-operations + (tp--content-property-operations surface rendered)) + (tp--apply-content-property-operations buffer property-operations) + (tp--publication-step 'property surface)))) + (cons text-operations (length property-operations)))) + +(defun tp--publish-buffer-properties (prepared) + "Publish PREPARED's host-range property operations." + (let* ((surface (tp--prepared-surface-surface prepared)) + (operations (tp--prepared-surface-property-operations prepared))) + (tp--publication-step 'text surface) + (tp--apply-properties-operations surface operations) + (tp--publication-step 'property surface) + (cons 0 (length operations)))) + +(defun tp--promote-prepared-objects (prepared) + "Promote PREPARED's touched identities to live state." + (let ((surface (tp--prepared-surface-surface prepared)) + (context (tp--prepared-surface-context prepared))) + (dolist (object (tp--prepared-surface-objects prepared)) + (setf (tp--surface-object-surface object) surface + (tp--surface-object-live object) t + (tp--surface-object-disposed object) nil + (tp--surface-object-candidate-context object) nil)) + (setf (tp--context-active context) nil))) + +(defun tp--swap-surface-state (prepared counts) + "Promote PREPARED side state using operation COUNTS." + (let* ((surface (tp--prepared-surface-surface prepared)) + (mounts (tp--prepared-surface-live-mounts prepared)) + (ledger (tp--prepared-surface-live-ledger prepared)) + (report (tp--surface-report-value prepared (car counts) (cdr counts)))) + (tp--promote-prepared-objects prepared) + (setf (tp--surface-plan surface) (tp--prepared-surface-plan prepared) + (tp--surface-objects surface) + (tp--surface-object-table (tp--prepared-surface-objects prepared)) + (tp--surface-mounts surface) mounts + (tp--surface-index surface) mounts + (tp--surface-ledger surface) ledger + (tp--surface-client-state surface) + (tp--prepared-surface-client-state prepared) + (tp--surface-producer surface) (tp--prepared-surface-producer prepared) + (tp--surface-revision surface) (1+ (tp--surface-revision surface)) + (tp--surface-report surface) report + (tp--surface-live surface) t + (tp--surface-stale surface) nil + (tp--prepared-surface-report prepared) report) + (tp--publication-step 'client-state surface) + (when (tp--prepared-surface-initial prepared) + (tp--register-live-surface surface)))) + +(defun tp--publish-one-surface (prepared) + "Publish PREPARED buffer and side state." + (let* ((started (float-time)) + (surface (tp--prepared-surface-surface prepared)) + (counts (if (eq (tp--surface-capability surface) 'content) + (tp--publish-buffer-content prepared) + (tp--publish-buffer-properties prepared)))) + (tp--create-candidate-mount-state prepared) + (tp--publication-step 'marker surface) + (tp--publication-step 'index surface) + (tp--swap-surface-state prepared counts) + (let ((report (plist-put (tp--surface-report surface) :timing + (list :publication (- (float-time) started))))) + (setf (tp--surface-report surface) report + (tp--prepared-surface-report prepared) report)))) + +(defun tp--journal-intervals (prepared-list) + "Return buffer intervals whose properties PREPARED-LIST may mutate." + (let (entries) + (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)) + (dolist (operation + (tp--prepared-surface-property-operations prepared)) + (push (list (tp--surface-buffer surface) + (plist-get operation :start) + (plist-get operation :end)) + entries))))) + entries)) + +(defun tp--merge-buffer-intervals (entries) + "Merge overlapping journal ENTRIES per buffer." + (let ((by-buffer (make-hash-table :test #'eq)) result) + (dolist (entry entries) + (push (cdr entry) (gethash (car entry) by-buffer))) + (maphash + (lambda (buffer intervals) + (setq intervals (sort intervals (lambda (a b) (< (car a) (car b))))) + (let (merged) + (dolist (interval intervals) + (if (and merged (<= (car interval) (cadar merged))) + (setcar (cdar merged) (max (cadar merged) (cadr interval))) + (push (copy-sequence interval) merged))) + (dolist (interval (nreverse merged)) + (push (list buffer (car interval) (cadr interval)) result)))) + by-buffer) + result)) + +(defun tp--capture-property-journals (prepared-list) + "Capture direct property journals for PREPARED-LIST." + (mapcar + (lambda (entry) + (pcase-let ((`(,buffer ,start ,end) entry)) + (list buffer start end + (with-current-buffer buffer + (save-restriction + (widen) (buffer-substring start end)))))) + (tp--merge-buffer-intervals (tp--journal-intervals prepared-list)))) + +(defun tp--replay-string-properties (buffer start string) + "Restore STRING's direct properties into BUFFER starting at START." + (let ((length (length string)) (offset 0)) + (when (> length 0) + (set-text-properties start (+ start length) nil buffer) + (while (< offset length) + (let ((next (next-property-change offset string length))) + (set-text-properties (+ start offset) (+ start next) + (text-properties-at offset string) buffer) + (setq offset next)))))) + +(defun tp--restore-property-journals (journals) + "Restore direct property JOURNALS after buffer change cancellation." + (dolist (journal journals) + (pcase-let ((`(,buffer ,start ,_end ,string) journal)) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-restriction + (widen) + (let ((inhibit-read-only t)) + (with-silent-modifications + (tp--replay-string-properties buffer start string))))))))) + +(defun tp--prepared-buffers (prepared-list) + "Return distinct live buffers affected by PREPARED-LIST." + (delete-dups + (mapcar (lambda (prepared) + (tp--surface-buffer (tp--prepared-surface-surface prepared))) + prepared-list))) + +(defun tp--capture-view-state (buffers) + "Capture point, windows, and modified state for BUFFERS." + (mapcar + (lambda (buffer) + (with-current-buffer buffer + (list buffer (copy-marker (point) t) (buffer-modified-p) + (mapcar (lambda (window) + (cons window (copy-marker (window-start window) nil))) + (get-buffer-window-list buffer nil t))))) + buffers)) + +(defun tp--restore-view-state (states) + "Restore captured point, window, and modified STATES." + (dolist (state states) + (pcase-let ((`(,buffer ,point-marker ,modified ,windows) state)) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when-let ((position (marker-position point-marker))) + (goto-char (min (point-max) (max (point-min) position)))) + (set-buffer-modified-p modified)) + (dolist (entry windows) + (when (window-live-p (car entry)) + (when-let ((position (marker-position (cdr entry)))) + (set-window-start (car entry) position t))))) + (tp--dispose-marker point-marker) + (dolist (entry windows) (tp--dispose-marker (cdr entry)))))) + +(defun tp--dispose-content-mounts (mounts) + "Detach private markers owned by content MOUNTS." + (dolist (mount mounts) + (when (eq (tp--surface-mount-capability mount) 'content) + (tp--dispose-marker (tp--surface-mount-start mount)) + (tp--dispose-marker (tp--surface-mount-end mount))))) + +(defun tp--dispose-ledger (ledger) + "Detach interval markers owned by property LEDGER entries." + (dolist (entry ledger) + (tp--dispose-marker (tp--property-ledger-start entry)) + (tp--dispose-marker (tp--property-ledger-end entry)))) + +(defun tp--unregister-surface (surface) + "Remove SURFACE from weak and buffer-local registries." + (remhash (tp--surface-id surface) tp--surfaces) + (when (buffer-live-p (tp--surface-buffer surface)) + (with-current-buffer (tp--surface-buffer surface) + (setq tp--buffer-surfaces (delq surface tp--buffer-surfaces)) + (unless tp--buffer-surfaces + (remove-hook 'after-change-functions #'tp--surface-after-change t) + (remove-hook 'kill-buffer-hook #'tp--surface-buffer-killed t))))) + +(defun tp--restore-surface-snapshot (prepared snapshot) + "Restore PREPARED's surface from SNAPSHOT after failed publication." + (let ((surface (tp--prepared-surface-surface prepared))) + (tp--dispose-content-mounts + (tp--prepared-surface-live-mounts prepared)) + (tp--dispose-ledger (tp--prepared-surface-live-ledger prepared)) + (if (not (buffer-live-p (tp--surface-buffer surface))) + (progn + (when (tp--surface-snapshot-objects snapshot) + (maphash (lambda (_path object) + (setf (tp--surface-object-live object) nil + (tp--surface-object-disposed object) t)) + (tp--surface-snapshot-objects snapshot))) + (setf (tp--surface-live surface) nil + (tp--surface-stale surface) 'killed + (tp--surface-objects surface) + (tp--surface-snapshot-objects snapshot) + (tp--surface-mounts surface) + (tp--surface-snapshot-mounts snapshot) + (tp--surface-ledger surface) + (tp--surface-snapshot-ledger snapshot))) + (when (and (tp--surface-live surface) + (not (tp--surface-snapshot-live snapshot))) + (tp--unregister-surface surface)) + (dolist (object (tp--prepared-surface-created prepared)) + (setf (tp--surface-object-live object) nil + (tp--surface-object-disposed object) t)) + (when (tp--surface-snapshot-objects snapshot) + (maphash (lambda (_path object) + (setf (tp--surface-object-live object) + (tp--surface-snapshot-live snapshot) + (tp--surface-object-disposed object) nil)) + (tp--surface-snapshot-objects snapshot))) + (setf (tp--surface-plan surface) (tp--surface-snapshot-plan snapshot) + (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-ledger surface) (tp--surface-snapshot-ledger snapshot) + (tp--surface-client-state surface) + (tp--surface-snapshot-client-state snapshot) + (tp--surface-producer surface) + (tp--surface-snapshot-producer snapshot) + (tp--surface-revision surface) + (tp--surface-snapshot-revision snapshot) + (tp--surface-report surface) (tp--surface-snapshot-report snapshot) + (tp--surface-live surface) (tp--surface-snapshot-live snapshot) + (tp--surface-stale surface) (tp--surface-snapshot-stale snapshot))))) + +(defun tp--prepare-change-group-for-buffers (buffers) + "Prepare and activate one multi-buffer change group for BUFFERS." + (let (handle) + (dolist (buffer buffers) + (unless (buffer-live-p buffer) + (signal 'tp-dead-surface (list buffer))) + (setq handle (nconc handle (prepare-change-group buffer)))) + (activate-change-group handle) + handle)) + +(defun tp--surface-state-snapshots (prepared-list) + "Return side-state snapshots for PREPARED-LIST." + (mapcar (lambda (prepared) + (cons prepared + (tp--surface-snapshot + (tp--prepared-surface-surface prepared)))) + prepared-list)) + +(defun tp--surface-publish-transaction () + "Prepare journals and publish every queued changed surface atomically." + (let* ((state (tp--surface-extension-state)) + (table (gethash 'prepared state)) + (prepared (and table (tp--sorted-prepared-surfaces table)))) + (when prepared + (let* ((buffers (tp--prepared-buffers prepared)) + (journals (tp--capture-property-journals prepared)) + (views (tp--capture-view-state buffers)) + (snapshots (tp--surface-state-snapshots prepared)) + (group (tp--prepare-change-group-for-buffers buffers))) + (puthash 'changed prepared state) + (puthash 'journals journals state) + (puthash 'views views state) + (puthash 'snapshots snapshots state) + (puthash 'change-group group state) + (cl-incf tp--surface-transaction-id) + (let ((tp--surface-publishing t)) + (dolist (candidate prepared) + (tp--publish-one-surface candidate))))))) + +(defun tp--cancel-change-group-safely (group) + "Cancel active change GROUP without allowing quit to interrupt rollback." + (when group + (let ((inhibit-quit t)) + (condition-case nil + (cancel-change-group group) + (error nil))))) + +(defun tp--surface-rollback-transaction () + "Rollback buffers, side state, markers, and contexts for this transaction." + (when-let ((state (tp--transaction-extension tp--surface-extension-key))) + (tp--cancel-change-group-safely (gethash 'change-group state)) + (tp--restore-property-journals (gethash 'journals state)) + (dolist (entry (gethash 'snapshots state)) + (tp--restore-surface-snapshot (car entry) (cdr entry))) + (tp--restore-view-state (gethash 'views state)) + (when-let ((table (gethash 'prepared state))) + (maphash (lambda (_surface prepared) + (let ((context (tp--prepared-surface-context prepared))) + (setf (tp--context-active context) t) + (tp--discard-context context))) + table)))) + +(defun tp--surface-finalize-killed-rollback () + "Reapply authoritative teardown after graph rollback for killed buffers." + (when-let ((state (tp--transaction-extension tp--surface-extension-key))) + (when-let ((table (gethash 'prepared state))) + (maphash + (lambda (surface _prepared) + (unless (buffer-live-p (tp--surface-buffer surface)) + (tp--teardown-surface surface t))) + table)))) + +(defun tp--anchors-in-mounts (mounts) + "Return distinct range anchors referenced by MOUNTS." + (delete-dups + (delq nil (mapcar #'tp--surface-mount-anchor mounts)))) + +(defun tp--update-anchor-ownership (surface old-mounts new-mounts) + "Update anchor ownership for SURFACE from OLD-MOUNTS to NEW-MOUNTS." + (let ((old (tp--anchors-in-mounts old-mounts)) + (new (tp--anchors-in-mounts new-mounts))) + (dolist (anchor old) + (unless (memq anchor new) + (setf (tp--anchor-surfaces anchor) + (delq surface (tp--anchor-surfaces anchor))) + (unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor)))) + (dolist (anchor new) + (cl-pushnew surface (tp--anchor-surfaces anchor) :test #'eq) + (setf (tp--anchor-candidate-context anchor) nil)))) + +(defun tp--finalize-object-lifecycle (prepared) + "Delete omitted bindings and removed objects after PREPARED commits." + (let* ((context (tp--prepared-surface-context prepared)) + (objects (tp--prepared-surface-objects prepared)) + (omitted (tp--context-binding-removals context objects))) + (dolist (binding omitted) + (when (tp-binding-live-p binding) (tp-binding-dispose binding))) + (dolist (object (tp--prepared-surface-removed prepared)) + (tp-binding-dispose-owner object) + (setf (tp--surface-object-live object) nil + (tp--surface-object-disposed object) t)) + (setf (tp--context-active context) nil))) + +(defun tp--finalize-context (prepared published) + "Finalize PREPARED after commit; PUBLISHED means side state was swapped." + (let* ((surface (tp--prepared-surface-surface prepared)) + (context (tp--prepared-surface-context prepared))) + (if published + (progn + (tp--finalize-object-lifecycle prepared) + (dolist (anchor (tp--context-created-anchors context)) + (unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor)))) + (tp--finalize-object-lifecycle prepared) + (dolist (object (tp--context-new-objects context)) + (unless (tp--surface-object-live object) + (setf (tp--surface-object-disposed object) t))) + (dolist (anchor (tp--context-created-anchors context)) + (unless (memq surface (tp--anchor-surfaces anchor)) + (tp--dispose-anchor anchor)))))) + +(defun tp--record-observer-error (surface observer failure) + "Record OBSERVER FAILURE in SURFACE's latest report." + (let ((report (copy-tree (tp--surface-report surface)))) + (setq report + (plist-put report :observer-errors + (append (plist-get report :observer-errors) + (list (list :observer observer :error failure))))) + (setf (tp--surface-report surface) report))) + +(defun tp--run-surface-observers (surface observers report) + "Run SURFACE OBSERVERS with REPORT and record their errors." + (dolist (observer observers) + (condition-case failure + (funcall observer surface report) + (error (tp--record-observer-error surface observer failure))))) + +(defun tp--enqueue-surface-observers (surface) + "Schedule SURFACE observers outside the publishing transaction." + (let ((observers (copy-sequence (tp--surface-observers surface))) + (report (tp-surface-report surface))) + (tp--enqueue-after-commit + (lambda () (tp--run-surface-observers surface observers report))))) + +(defun tp--surface-commit-transaction () + "Accept buffer changes and finalize every transaction surface." + (when-let ((state (tp--transaction-extension tp--surface-extension-key))) + (when-let ((group (gethash 'change-group state))) + (accept-change-group group)) + (tp--restore-view-state (gethash 'views state)) + (let ((changed (gethash 'changed state)) + (snapshots (gethash 'snapshots state))) + (dolist (entry snapshots) + (let* ((prepared (car entry)) + (snapshot (cdr entry)) + (surface (tp--prepared-surface-surface prepared))) + (tp--update-anchor-ownership + surface (tp--surface-snapshot-mounts snapshot) + (tp--surface-mounts surface)) + (tp--dispose-content-mounts (tp--surface-snapshot-mounts snapshot)) + (tp--dispose-ledger (tp--surface-snapshot-ledger snapshot)))) + (when-let ((table (gethash 'prepared state))) + (maphash (lambda (_surface prepared) + (tp--finalize-context prepared (memq prepared changed))) + table)) + (dolist (prepared changed) + (tp--enqueue-surface-observers + (tp--prepared-surface-surface prepared)))))) + +(defun tp-surface-materialize-string (plan-or-producer) + "Materialize PLAN-OR-PRODUCER without creating live runtime state." + (let* ((surface (tp--make-surface + :id 0 :capability 'content :options nil + :objects (make-hash-table :test #'equal))) + (context (tp--make-context surface t)) + (success nil) + rendered) + (unwind-protect + (let* ((normalized + (tp--prepare-input surface plan-or-producer nil context)) + (plan (car normalized))) + (tp--validate-plan-capability plan 'content) + (tp--validate-context-tree context plan) + (setq rendered (car (tp--render-plan plan context)) + success t) + rendered) + (setf (tp--context-active context) t) + (tp--discard-context context) + (unless success (setq rendered nil))))) + +(defun tp--rebase-ledger-entry (surface entry) + "Return current-property segments rebased from ledger ENTRY on SURFACE." + (let* ((buffer (tp--surface-buffer surface)) + (start (tp--ledger-position (tp--property-ledger-start entry))) + (end (tp--ledger-position (tp--property-ledger-end entry))) + (property (tp--property-ledger-property entry)) + segments) + (while (< start end) + (let* ((next (with-current-buffer buffer + (next-single-property-change start property buffer end))) + (state (tp--property-state-at buffer start property))) + (push (tp--make-property-ledger + :start (with-current-buffer buffer (copy-marker start nil)) + :end (with-current-buffer buffer (copy-marker next t)) + :property property :baseline-present (car state) + :baseline-value (cdr state) :published-present (car state) + :published-value (cdr state) + :anchors (tp--property-ledger-anchors entry)) + segments) + (setq start next))) + (tp--dispose-marker (tp--property-ledger-start entry)) + (tp--dispose-marker (tp--property-ledger-end entry)) + (nreverse segments))) + +(defun tp-range-rebase (anchor) + "Accept current host properties as the new baseline for ANCHOR." + (unless (tp-range-anchor-live-p anchor) + (signal 'tp-invalid-range-anchor (list anchor))) + (dolist (surface (copy-sequence (tp--anchor-surfaces anchor))) + (when (tp-surface-live-p surface) + (let (ledger) + (dolist (entry (tp--surface-ledger surface)) + (setq ledger + (nconc ledger + (if (memq anchor (tp--property-ledger-anchors entry)) + (tp--rebase-ledger-entry surface entry) + (list entry))))) + (setf (tp--surface-ledger surface) ledger)))) + (setf (tp--anchor-stale anchor) nil) + anchor) + +(defun tp--unmount-ledger-segments (surface entry) + "Return restoration operations and conflicts for one ledger ENTRY." + (let* ((buffer (tp--surface-buffer surface)) + (start (tp--ledger-position (tp--property-ledger-start entry))) + (end (tp--ledger-position (tp--property-ledger-end entry))) + (property (tp--property-ledger-property entry)) + (published (tp--ledger-published-state entry)) + operations conflicts) + (while (< start end) + (let* ((next (with-current-buffer buffer + (next-single-property-change start property buffer end))) + (current (tp--property-state-at buffer start property))) + (if (tp--property-state-equal-p current published) + (push (list :start start :end next :property property + :present (tp--property-ledger-baseline-present entry) + :value (tp--property-ledger-baseline-value entry)) + operations) + (push (list :start start :end next :property property + :current current :published published) + conflicts)) + (setq start next))) + (cons (nreverse operations) (nreverse conflicts)))) + +(defun tp--unmount-property-operations (surface) + "Return restoration operations and conflicts for SURFACE." + (let (operations conflicts) + (dolist (entry (tp--surface-ledger surface)) + (pcase-let ((`(,entry-operations . ,entry-conflicts) + (tp--unmount-ledger-segments surface entry))) + (setq operations (nconc operations entry-operations) + conflicts (nconc conflicts entry-conflicts)))) + (cons operations conflicts))) + +(defun tp--unmount-journals (surface operations) + "Capture property rollback journals for SURFACE and OPERATIONS." + (let ((entries + (if (eq (tp--surface-capability surface) 'content) + (pcase-let ((`(,start . ,end) (tp--surface-range surface))) + (list (list (tp--surface-buffer surface) start end))) + (mapcar (lambda (operation) + (list (tp--surface-buffer surface) + (plist-get operation :start) + (plist-get operation :end))) + operations)))) + (mapcar + (lambda (entry) + (pcase-let ((`(,buffer ,start ,end) entry)) + (list buffer start end + (with-current-buffer buffer (buffer-substring start end))))) + (tp--merge-buffer-intervals entries)))) + +(defun tp--publish-unmount (surface operations) + "Remove SURFACE content or apply property restoration OPERATIONS." + (let ((buffer (tp--surface-buffer surface)) + (tp--surface-publishing t)) + (with-current-buffer buffer + (save-restriction + (widen) + (let ((inhibit-read-only + (plist-get (tp--surface-options surface) :inhibit-read-only))) + (if (eq (tp--surface-capability surface) 'content) + (pcase-let ((`(,start . ,end) (tp--surface-range surface))) + (delete-region start end)) + (with-silent-modifications + (dolist (operation operations) + (tp--apply-property-operation buffer operation))))))))) + +(defun tp--remove-surface-anchor-ownership (surface) + "Detach SURFACE from every range anchor it owns." + (dolist (anchor (tp--anchors-in-mounts (tp--surface-mounts surface))) + (setf (tp--anchor-surfaces anchor) + (delq surface (tp--anchor-surfaces anchor))) + (unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor)))) + +(defun tp--teardown-surface (surface killed) + "Release SURFACE runtime state; KILLED means its buffer is gone." + (when (tp-surface-p surface) + (tp--unregister-surface surface) + (tp-binding-dispose-owner surface) + (when (tp--surface-objects surface) + (maphash + (lambda (_path object) + (tp-binding-dispose-owner object) + (setf (tp--surface-object-live object) nil + (tp--surface-object-disposed object) t)) + (tp--surface-objects surface))) + (tp--remove-surface-anchor-ownership surface) + (tp--dispose-content-mounts (tp--surface-mounts surface)) + (tp--dispose-ledger (tp--surface-ledger surface)) + (tp--dispose-marker (tp--surface-start surface)) + (tp--dispose-marker (tp--surface-end surface)) + (setf (tp--surface-live surface) nil + (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-ledger surface) nil + (tp--surface-client-state surface) nil))) + +;;;###autoload +(defun tp-surface-unmount (surface) + "Unmount SURFACE and return a generic report. +Properties-only mounts restore their baseline only when TP's last value still +owns the property; conflicting host values are preserved and reported." + (tp--validate-live-surface surface) + (when tp--transaction-active + (signal 'tp-surface-error (list :unmount-during-transaction))) + (let* ((property-result + (if (eq (tp--surface-capability surface) 'properties) + (tp--unmount-property-operations surface) + (cons nil nil))) + (operations (car property-result)) + (conflicts (cdr property-result)) + (journals (tp--unmount-journals surface operations)) + (views (tp--capture-view-state (list (tp--surface-buffer surface)))) + (group (tp--prepare-change-group-for-buffers + (list (tp--surface-buffer surface)))) + success) + (unwind-protect + (progn + (tp--publish-unmount surface operations) + (accept-change-group group) + (setq success t)) + (unless success + (tp--cancel-change-group-safely group) + (tp--restore-property-journals journals)) + (tp--restore-view-state views)) + (let ((report (list :transaction-id (cl-incf tp--surface-transaction-id) + :surface-id (tp--surface-id surface) + :old-revision (tp--surface-revision surface) + :new-revision nil :text-operations + (if (eq (tp--surface-capability surface) 'content) 1 0) + :property-operations (length operations) + :property-conflicts conflicts :unmounted t))) + (tp--teardown-surface surface nil) + report))) + +(defun tp-surface-at-point (&optional position buffer) + "Return live objects mounted at POSITION in BUFFER from side indexes." + (let ((target (if buffer (get-buffer buffer) (current-buffer))) + objects) + (unless (buffer-live-p target) + (signal 'tp-unsupported-buffer (list buffer))) + (with-current-buffer target + (let ((point (or position (point)))) + (dolist (surface tp--buffer-surfaces) + (dolist (mount (tp--surface-index surface)) + (let ((start (marker-position (tp--surface-mount-start mount))) + (end (marker-position (tp--surface-mount-end mount)))) + (when (and start end (<= start point) (< point end)) + (cl-pushnew (tp--surface-mount-object mount) objects + :test #'eq))))))) + (sort objects + (lambda (left right) + (< (length (tp--surface-object-path left)) + (length (tp--surface-object-path right))))))) + +(defun tp-surface-report (surface) + "Return a defensive copy of SURFACE's latest generic commit report." + (unless (tp-surface-p surface) + (signal 'wrong-type-argument (list 'tp-surface-p surface))) + (copy-tree (tp--surface-report surface))) + +(defun tp-surface-inspect (surface) + "Return read-only retained diagnostics for SURFACE." + (tp--validate-live-surface surface) + (list :surface surface :id (tp--surface-id surface) + :buffer (tp--surface-buffer surface) + :capability (tp--surface-capability surface) + :revision (tp--surface-revision surface) + :object-count (hash-table-count (tp--surface-objects surface)) + :mount-count (length (tp--surface-mounts surface)) + :client-state (tp--surface-client-state surface) + :report (tp-surface-report surface))) + +(add-hook 'tp--binding-changed-functions #'tp--surface-binding-changed) +(add-hook 'tp--transaction-publish-functions #'tp--surface-publish-transaction) +(add-hook 'tp--transaction-rollback-functions #'tp--surface-rollback-transaction) +(add-hook 'tp--transaction-rollback-final-functions + #'tp--surface-finalize-killed-rollback) +(add-hook 'tp--transaction-committed-functions #'tp--surface-commit-transaction) + +(provide 'tp-surface) +;;; tp-surface.el ends here diff --git a/tp.el b/tp.el index 1826a86..70b26e7 100644 --- a/tp.el +++ b/tp.el @@ -26,6 +26,8 @@ ;; custom properties, and explicit computed values. ;; tp-reactive.el Exact signals, bindings, transactions, scoped variable ;; adapters, plus temporary legacy layer watcher state. +;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes, +;; and atomic buffer publication. ;; tp-layer.el Layer registry: `define-tp', `define-tps', ;; layer/group resolution and expansion. ;; tp-ops.el Core primitives: `tp-set', `tp-reset', `tp-add', @@ -54,6 +56,7 @@ (require 'tp-core) (require 'tp-style) (require 'tp-reactive) +(require 'tp-surface) (require 'tp-layer) (require 'tp-ops) (require 'tp-search)