Compare commits

...

15 Commits

Author SHA1 Message Date
Kinneyzhang
0a820bd0cb fix: preserve native interaction properties in incremental publication
Some checks are pending
CI / test (28.1) (push) Waiting to run
CI / test (29.4) (push) Waiting to run
CI / test (30.1) (push) Waiting to run
Preserve keymap ownership and hover grouping while applying minimal text patches. Reduce retained publication allocations without weakening policy comparisons or transactional rollback.

Validation: 451 ERT tests, README doctests, strict byte compilation and checkdoc passed.
2026-09-09 22:25:09 +08:00
Kinneyzhang
e28df6a5fb feat: compose property contributions in retained commit batches 2026-09-07 05:03:27 +08:00
Kinneyzhang
6ed8df3915 perf: match retained mount identities with ordered queues 2026-09-07 04:09:57 +08:00
Kinneyzhang
5bcc91d867 perf: check publication identity uniqueness with equal hashing 2026-09-06 21:04:44 +08:00
Kinneyzhang
47e8d8c256 perf: retain authoritative publication target state 2026-09-05 07:07:53 +08:00
Kinneyzhang
b2b9462269 perf: rebuild shadow patch output in one pass 2026-09-05 06:53:10 +08:00
Kinneyzhang
c05174ff9d refactor!: publish transactions exclusively through protocol v2 2026-09-05 05:25:29 +08:00
Kinneyzhang
25cb66c040 feat(transaction): expose structured participant registration 2026-09-01 15:52:05 +08:00
Kinneyzhang
469bdff17d feat(transaction): cut over to structured publication authority 2026-09-01 15:37:29 +08:00
Kinneyzhang
2e2d9edc84 fix(package): distinguish transaction-capable TP 2026-09-01 05:57:28 +08:00
Kinneyzhang
9ac8c7a133 feat: expose bounded final-accept markers 2026-09-01 00:50:32 +08:00
Kinneyzhang
76be75f674 feat: add TP v1+v2 transaction contract 2026-08-31 19:35:02 +08:00
Kinneyzhang
7632a05bdf test: lock M0a transaction fault behavior 2026-08-31 17:49:33 +08:00
Kinneyzhang
c2525a137b feat: expose transaction activity boundary 2026-08-27 22:49:21 +08:00
Kinneyzhang
31304c1906 perf: make surface observation opt-in 2026-08-27 22:30:16 +08:00
19 changed files with 5947 additions and 177 deletions

View File

@ -2,13 +2,20 @@
All notable changes to the tp library are documented here.
## 1.0.0 (Unreleased)
## 2.0.0 (Unreleased)
### Added
- A standalone retained surface runtime with pure defensive plans, prepare-scoped stable objects, keyed/positional reconciliation, content and properties capabilities, marker-backed range anchors, object/mount indexes, scoped updates, opaque client state, generic reports, and lifecycle cleanup.
- Exact signal-to-binding and binding-to-binding dependency tracking with conditional rewiring, equality cutoffs, batched transactions, nested-write stabilization, owner disposal, buffer-scoped sources, variable adapters, cycle paths, and public structural counters.
- Atomic single- and multi-surface publication with candidate source values, prepare-all/publish-all ordering, explicit property journals, rollback-capable transaction participants, observer isolation, and authoritative kill-buffer cleanup.
- Transaction protocol v2: transaction-scoped publication batches, structured
participants, bounded opaque final-accept markers using the closed
`tp-vector-slots/v1` primitive, immutable tagged outcomes, and one live writer.
- `tp-runtime-manifest`, advertising `tp-transaction-protocol-v2` and package
version 2.0.0.
- Public `tp-transaction-participate-v2` registration for cross-package
structured participants.
- Native property policies and contribution composition with explicit nil/absence, normalization, validation, equality, merge, projection, named direct styles, and explicit `tp-computed` value sources.
- `tp-propertize`, `tp-apply`, and `tp-watch` as the one-shot string, one-shot buffer-range, and reactive existing-text conveniences over the same direct property/surface core.
- Retained logical objects with `tp-object-retain` and `tp-object-attach-fragment`, allowing one object to own multiple disjoint physical fragments without placing handles or positions in plans.
@ -16,6 +23,9 @@ All notable changes to the tp library are documented here.
### Changed
- Structured publication batches own the single live surface-entry loop,
participant stage/precommit/commit vector, and candidate-bound final accept.
- Package metadata now identifies the v2-only breaking transaction contract.
- `define-tp` and `define-tps` now define static or parameterized direct declaration recipes. Applying a recipe produces ordinary properties and never publishes runtime identity metadata.
- TP is no longer a CSS engine. Selector, stylesheet, specificity, origin/importance, cascade layer, CSS-wide value, custom property, winner, and provenance behavior belongs to the independent ECSS package.
- Function-valued properties are always literal. Only values wrapped by `tp-computed` execute and participate in dependency collection.
@ -24,6 +34,12 @@ All notable changes to the tp library are documented here.
### Removed
- The public `tp-transaction-participate` v1 facade. Replace
`(tp-transaction-participate KEY PUBLISH ROLLBACK)` with
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`.
- The v1 publication writer, execution-route kill switch, artifact-mode switch,
and their runtime manifest claims.
- `tp-render.el`, `tp-stack.el`, the scan-driven renderer, layer-to-buffer registry, and duplicate managed transaction path.
- Managed stack mutation, attach/detach, diagnostics, and lifecycle APIs that depended on inline stack storage.
- `tp-text`, `$variable` declaration syntax, automatic layer refresh, and character-level `tp-name`/`tp-layers`/`tp-meta` runtime storage.

View File

@ -3,6 +3,9 @@
# Usage:
# make test # run all ERT test suites
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
# make test-m0a # run current TP completion characterization
# make test-m1a # run additive transaction contract + fault gates
# make test-c1b # run the v2-only transaction regression gate
# make doctest # execute README examples against the code
# make benchmark # run reproducible correctness-first benchmarks
# make compile # byte-compile the library modules
@ -21,19 +24,42 @@ WERROR ?= nil
TEST_DIR = tests
LOADPATH = -L . -L $(TEST_DIR) -L examples $(LOAD_EXTRA)
SRC = tp-core.el tp-style.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.el \
SRC = tp-core.el tp-style.el tp-transaction.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.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
EXAMPLES = $(wildcard examples/*.el)
DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el
.PHONY: test test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean
.PHONY: test test-m0a test-m1a test-c1b test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean
test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
-f ert-run-tests-batch-and-exit
test-m0a:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
-l $(TEST_DIR)/tp-binding-tests.el \
-l $(TEST_DIR)/tp-surface-tests.el \
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
--eval '(ert-run-tests-batch-and-exit "tp-m0a-characterization-test-\\|tp-binding-test-signal-commit-journal-rolls-back-every-write\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-global-signal-update-is-multi-surface-atomic\\|tp-surface-test-full-and-scoped-precommit-stages-roll-back\\|tp-surface-test-full-and-scoped-final-accept-roll-back")'
test-m1a:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
-l $(TEST_DIR)/tp-binding-tests.el \
-l $(TEST_DIR)/tp-surface-tests.el \
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
-l $(TEST_DIR)/tp-transaction-tests.el \
--eval '(ert-run-tests-batch-and-exit "tp-transaction-test-\\|tp-m0a-characterization-test-\\|tp-binding-test-signal-commit-journal-rolls-back-every-write\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-global-signal-update-is-multi-surface-atomic\\|tp-surface-test-full-and-scoped-precommit-stages-roll-back\\|tp-surface-test-full-and-scoped-final-accept-roll-back")'
test-c1b:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
-l $(TEST_DIR)/tp-binding-tests.el \
-l $(TEST_DIR)/tp-surface-tests.el \
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
-l $(TEST_DIR)/tp-transaction-tests.el \
--eval '(ert-run-tests-batch-and-exit "tp-transaction-test-\\|tp-m0a-characterization-test-participant-failure-preserves-condition\\|tp-binding-test-participant-key-is-owned-by-transaction\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-transaction-participant\\|tp-surface-test-failing-participant")'
test-shuffled:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
-l tp-run-shuffled.el

View File

@ -1,13 +1,13 @@
# TP
TP 1.0 is a standalone retained/reactive text runtime for Emacs. It projects declarative properties, reactive data, and stable text objects onto strings and buffers while owning text-property composition, exact dependency tracking, retained identity, marker-backed mounts, diffing, transactions, rollback, and final buffer publication.
TP 2.0 is a standalone retained/reactive text runtime for Emacs. It projects declarative properties, reactive data, and stable text objects onto strings and buffers while owning text-property composition, exact dependency tracking, retained identity, marker-backed mounts, diffing, transactions, rollback, and final buffer publication.
TP does not depend on Ebox or ECSS. It does not implement CSS selectors, stylesheets, specificity, cascade winners, Box, Flex, Grid, measurement, or layout. A CSS consumer may compute final declarations with ECSS and publish them through TP, but TP itself only understands Emacs text properties and generic retained text surfaces.
Chinese documentation: [README_CN.md](README_CN.md).
Complete public API reference: [API-REFERENCE.md](docs/API-REFERENCE.md) (中文).
It is the symbol-level usage index for the current TP 1.0 implementation; this
It is the symbol-level usage index for the current TP 2.0 implementation; this
README remains the conceptual quick start.
## Requirements
@ -146,6 +146,17 @@ TP records the host baseline and each TP contribution per property interval. Ove
Observers run only after a successful commit. Their failures are recorded and do not roll back an already committed transaction. A buffer killed during publication remains killed; rollback never recreates it.
TP 2.0 drives the single live publication from exact transaction-scoped batch
entries, one frozen participant vector, and the candidate-bound final accept.
The same journals, surface snapshots, and change group are shared rather than
copied. Transaction participants register through
`tp-transaction-participate-v2`; TP has no alternate transaction writer or
runtime route switch.
Generic opaque authority markers are bounded and whitelist-validated before
final accept, then reverse-restored before ordinary rollback on partial apply or
accept failure. `tp-with-transaction` still returns its body value, and
internal outcomes remain observational side-channel evidence.
ETAF integration uses the same boundary through one opaque transaction
participant. ETAF prepares its immutable generation and Ebox candidate before
TP accepts the transaction; participant publish, TP final accept, and
@ -174,7 +185,7 @@ cycles instead of spinning.
| Core inspection and debug | `tp-debug-*`, `tp-intervals`, `tp-intervals-map`, `tp-plist`, `tp-text-snapshot`, `tp-empty-p` |
| Property policy and declarations | `tp-define-property-policy`, `tp-register-text-property`, `tp-text-declarations`, `tp-computed`, `tp-resolve-value`, `tp-merge-declarations`, `tp-define-style`, `tp-style-declarations` |
| Static recipes | `define-tp`/`tp-define-layer`, `define-tps`/`define-tp-group`/`tp-define-group`, layer/group queries, undefine/reset/describe |
| Signals and bindings | signal create/read/peek/set/dispose, binding install/read/dispose, `tp-variable-signal`, `tp-with-transaction`, `tp-transaction-participate`, counters/reset |
| Signals and bindings | signal create/read/peek/set/dispose, binding install/read/dispose, `tp-variable-signal`, `tp-with-transaction`, `tp-transaction-participate-v2`, read-only `tp-transaction-active-p`, `tp-runtime-manifest`, counters/reset |
| Objects and plans | plan/result constructors, `tp-object-ensure`, retain/reuse, fragment/content-range attachment, resolve, mounted/mounts |
| Host ranges | `tp-range-anchor-create`, `tp-range-anchor-live-p`, `tp-object-attach-range`, `tp-range-rebase` |
| Surfaces | mount/update/scoped update, materialize, live/revision/client-state, at-point, report/report-summary/inspect, unmount |
@ -192,6 +203,15 @@ for module boundaries and transaction flow.
TP 1.0 removes the 0.3 managed stack/renderer runtime instead of hiding it behind compatibility branches. Removed behavior includes `tp-render.el`, `tp-stack.el`, stack mutation APIs, `tp-text`, `$variable` declarations, layer-to-buffer registries, scan-driven refresh, managed attach/detach/diagnostics, and inline `tp-name`/`tp-layers`/`tp-meta` runtime storage.
## TP 2.0 transaction migration
TP 2.0 removes the v1 transaction participant facade and the legacy execution
route. Replace `(tp-transaction-participate KEY PUBLISH ROLLBACK)` exactly with
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`.
Callers that inspect `tp-runtime-manifest` must require
`tp-transaction-protocol-v2`; route-selection and v1-adapter fields are no
longer published.
Use direct recipes for reusable static declarations, `tp-watch` for reactive properties on existing text, and retained content surfaces for reactive text or structured UI. TP does not automatically scan historical propertized text to reconstruct runtime identity.
## Examples

View File

@ -1,13 +1,13 @@
# TP
TP 1.0 是一个可独立使用的 Emacs retained/reactive text runtime。它把声明式属性、响应式数据和稳定文本对象投影到 string 与 buffer并拥有文本属性 contribution 合成、精确依赖追踪、保留式身份、marker-backed mount、diff、事务、回滚和最终 Buffer publication。
TP 2.0 是一个可独立使用的 Emacs retained/reactive text runtime。它把声明式属性、响应式数据和稳定文本对象投影到 string 与 buffer并拥有文本属性 contribution 合成、精确依赖追踪、保留式身份、marker-backed mount、diff、事务、回滚和最终 Buffer publication。
TP 不依赖 Ebox 或 ECSS也不实现 CSS selector、stylesheet、specificity、cascade winner、Box、Flex、Grid、测量或布局。需要 CSS 的调用者可以先用 ECSS 算出最终 declarations再交给 TP 发布TP 自身只理解 Emacs 文本属性和通用 retained text surface。
英文文档:[README.md](README.md)。
完整公共 API 参考:[API-REFERENCE.md](docs/API-REFERENCE.md)。本文负责概念
和快速开始API 参考按当前 TP 1.0 源码列出入口、参数语义、返回值和用法。
和快速开始API 参考按当前 TP 2.0 源码列出入口、参数语义、返回值和用法。
## 运行要求
@ -145,6 +145,15 @@ TP 为每个 property interval 保存 host baseline 和各个 TP contribution。
observer 只在成功提交之后运行observer failure 只记录,不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡rollback 不会把它重新创建。
TP 2.0 从 transaction-scoped batch 的 exact entries、同一个冻结 participant
vector 和 candidate-bound final accept 驱动唯一 live publicationjournal、
surface snapshot 与 change group 仍只保留一份。transaction participant 统一通过
`tp-transaction-participate-v2` 注册,不再提供备用 transaction writer 或 runtime
route switch。generic opaque authority marker 在 final accept 前
完成固定上界与 whitelist 校验partial apply 或 accept failure 时先逆序恢复
marker再执行普通 rollback。`tp-with-transaction` 仍返回 body result内部
outcome 仅作为只读 side-channel evidence。
ETAF 集成复用同一事务边界,只注册一个 opaque transaction participant。ETAF
先准备 immutable generation 和 Ebox candidate再由 TP 按固定顺序完成
participant publish、TP final accept 和 post-accept cleanup。participant failure
@ -171,7 +180,7 @@ effect 的 input/version tuple重复或超过图规模上限时停止循环
| Core inspection 与 debug | `tp-debug-*`、`tp-intervals`、`tp-intervals-map`、`tp-plist`、`tp-text-snapshot`、`tp-empty-p` |
| Property policy 与 declaration | `tp-define-property-policy`、`tp-register-text-property`、`tp-text-declarations`、`tp-computed`、`tp-resolve-value`、`tp-merge-declarations`、`tp-define-style`、`tp-style-declarations` |
| 静态 recipe | `define-tp`/`tp-define-layer`、`define-tps`/`define-tp-group`/`tp-define-group`、layer/group 查询、undefine/reset/describe |
| Signal 与 binding | signal create/read/peek/set/dispose、binding install/read/dispose、`tp-variable-signal`、`tp-with-transaction`、`tp-transaction-participate`、counter/reset |
| Signal 与 binding | signal create/read/peek/set/dispose、binding install/read/dispose、`tp-variable-signal`、`tp-with-transaction`、`tp-transaction-participate-v2`、只读 `tp-transaction-active-p`、`tp-runtime-manifest`、counter/reset |
| Object 与 plan | plan/result constructor、`tp-object-ensure`、retain/reuse、fragment/content-range attach、resolve、mounted/mounts |
| Host range | `tp-range-anchor-create`、`tp-range-anchor-live-p`、`tp-object-attach-range`、`tp-range-rebase` |
| Surface | mount/update/scoped update、materialize、live/revision/client-state、at-point、report/report-summary/inspect、unmount |
@ -188,6 +197,14 @@ ownership、生命周期、错误和返回值合同见 [API semantics](docs/API-
TP 1.0 直接删除 0.3 的 managed stack/renderer runtime不使用隐藏兼容分支。删除的行为包括 `tp-render.el`、`tp-stack.el`、stack mutation APIs、`tp-text`、`$variable` declarations、layer-to-buffer registry、scan-driven refresh、managed attach/detach/diagnostics以及以 `tp-name`/`tp-layers`/`tp-meta` 作为权威 runtime storage 的机制。
## TP 2.0 transaction 迁移
TP 2.0 删除 v1 transaction participant facade 和 legacy execution route。把
`(tp-transaction-participate KEY PUBLISH ROLLBACK)` 精确替换为
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`
检查 `tp-runtime-manifest` 的调用方必须要求 `tp-transaction-protocol-v2`manifest
不再发布 route-selection 和 v1-adapter 字段。
可复用静态声明使用 direct recipe已有文本的响应式属性使用 `tp-watch`;响应式文字或结构化 UI 使用 retained content surface。TP 不会自动扫描历史 propertized text 来重建 runtime identity。
## 示例

View File

@ -1,4 +1,4 @@
# TP 1.0 公共 API 与用法参考
# TP 2.0 公共 API 与用法参考
本文是 TP 当前实现的完整公共入口索引。它以 tp.el 加载的模块为准;带
tp-- 前缀的函数、变量和结构体是内部实现,不属于本文的稳定 API。
@ -226,10 +226,15 @@ tp-binding-dispose 释放单个 binding。
(tp-signal-dispose left)
(tp-signal-dispose right))
(tp-transaction-participate
'my-external-state
(lambda () (my-publish))
(lambda () (my-rollback)))
(tp-with-transaction
(tp-transaction-participate-v2
:key 'my-structured-state
:stage (lambda () (my-stage))
:rollback (lambda () (my-rollback))))
(tp-transaction-active-p)
(tp-runtime-manifest)
(tp-variable-signal 'my-variable)
(tp-variable-signal 'my-buffer-variable some-buffer)
@ -240,10 +245,29 @@ tp-binding-dispose 释放单个 binding。
tp-with-transaction 将 signal、binding、surface 和注册的 transaction
participant 一起原子处理。participant 必须在 active transaction 内注册;
publish 在 surface publication 后、source commit 前运行,失败时按逆序
rollback。tp-variable-signal 用 Emacs variable watcher 适配全局或指定
stage 在 surface publication 后、source commit 前运行,失败时按逆序
rollback。consumer 使用 `tp-transaction-participate-v2`;它
返回 key不暴露内部 participant 对象。tp-variable-signal 用 Emacs variable
watcher 适配全局或指定
Buffer 的变量,不是旧的 $variable API。
tp-transaction-active-p 是只读边界查询:只在当前 dynamic extent 已进入
或加入 TP transaction 时返回严格的 t否则返回 nil。它不暴露 transaction
对象、participant 或内部状态,调用方只能用它在 mutation 前拒绝不支持的
嵌套事务边界。
tp-runtime-manifest 返回防御性 capability snapshot本版本的
`:transaction-protocol``tp-transaction-protocol-v2``:version` 为
`"2.0.0"`。`:structured-participant-api` 指向
`tp-transaction-participate-v2``:batch-execute`、`:batch-artifacts` 和
`:single-live-writer` 均为 non-nil。manifest 不再发布 execution route、
v1 adapter 或 v1 rollback route。
从 TP 1.x 迁移时,把 `(tp-transaction-participate KEY PUBLISH ROLLBACK)`
精确替换为 `(tp-transaction-participate-v2 :key KEY :stage PUBLISH
:rollback ROLLBACK)`。删除所有对 `tp-transaction-execution-route`
`tp--transaction-artifact-mode` 的设置。
ETAF registers one opaque participant for its immutable generation and Ebox
client state. Its publish is paired with rollback across TP final accept; the
ETAF runtime separately records effect input/version tuples and reports a
@ -366,6 +390,19 @@ Report 的常用字段包括:
:scope-fallback、:property-conflicts、:rolled-back、:failure、
:observer-errors、:timing。
已经精确计算出变更区间的 producer 可以使用 `tp-commit-batch-create` 构造
批次,再由 `tp-commit-batch-result-create` 绑定当前 prepare context发布和
回滚仍使用相同 surface 事务。批次绑定前后 revision、extent 和坐标映射。
每个 patch 的 `:replacement` 是完整属性文本,也可以携带局部
`:property-contributions`:其中 `:start`/`:end` 相对于该 replacement按列表
顺序使用已注册的 property merge policy 合成。策略在**构造批次时**求值;
批次只保留合成后的文本快照,不保留贡献列表,之后的调用方修改或策略替换
不会重新计算这份批次。函数、record 等 opaque 属性身份按既有 snapshot 规则保留。
producer 只有在证明整个挂载拓扑、tags 和坐标均与已提交版本相同时,才能向
`tp-commit-batch-result-create``:reuse-mount-projection t`。它不能与显式
`:mount-specs` 同时使用;数量相同或对象没有增删都不能替代完整的不变证明。
### 6.3 Host range 和 tp-watch
~~~elisp
@ -594,7 +631,8 @@ TP 1.0 已删除并且不应在新代码中使用:
| tp-core.el | tp-debug-*、tp-with-current-buffer、tp-intervals、tp-intervals-map、tp-empty-p、tp-plist、tp-text-snapshot |
| tp-style.el | tp-define-property-policy、tp-property-policy、tp-text-property-id、tp-register-text-property、tp-text-declarations、tp-computed、tp-resolve-value、tp-merge-declarations、tp-define-style、tp-style-declarations、tp-undefine-style |
| tp-layer.el | define-tp/tp-define-layer、define-tps/define-tp-group/tp-define-group、layer/group query、tp-layer-reset、tp-undefine-*、tp-describe-layer |
| tp-reactive.el | signal、binding、transaction、variable adapter、counter 和 reset API |
| tp-transaction.el | structured batch/entry、final-marker 与 tagged-outcome 内部合同 |
| tp-reactive.el | signal、binding、transaction coordinator、variable adapter、counter 和 reset API |
| tp-surface.el | plan/result、object、range anchor、surface lifecycle、scoped update、report、tp-watch |
| tp-ops.el | tp-propertize、tp-apply、tp-set、tp-reset、tp-add、tp-remove、tp-clear、tp-get、tp-at、tp-member |
| tp-search.el | tp-match-*、tp-regexp-*、tp-search、tp-search-map、tp-forward*、tp-backward*、tp-any-value |

View File

@ -1,6 +1,6 @@
# TP 1.0 API Semantics
# TP 2.0 API Semantics
本文记录 TP 1.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
本文记录 TP 2.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
完整的公共符号、参数形状、返回值和示例见 [API reference](API-REFERENCE.md)。
@ -196,13 +196,34 @@ TP 为每个 interval 保存:
3. 运行 binding graph 与 producers
4. 校验 object、plan、capability、range、conflict 与 lifecycle
5. 为所有 surfaces 准备 text/property operations 与 inverse journals
6. 按稳定 surface id publish
7. 原子切换 signals、bindings、plans、mount/index、client state 和 revisions
8. 全部成功后运行 observers。
6. 默认从 publication batch 的 exact entry bindings 按稳定 surface id publish
7. 从 batch 绑定的同一 participant vector 按声明顺序 stage participant再执行
declared precommit
8. commit signal journal
9. 在 candidate 绑定的 single final accept 内按顺序 apply bounded opaque markers再 accept
change groupmarker 只能使用 closed `tp-vector-slots/v1` fixed-write
primitive不能注册 callbackpartial apply 或 accept failure 先逆序
restore markers
10. final accept 成功后固定写入 tagged success再运行 contained
committed/observer work。
嵌套 transaction 加入最外层。一个 global signal 可以原子触达多个 buffers任一 surface 失败时,已发布 surfaces 和 source/binding state 全部回滚。
`tp-transaction-participate` 允许 client side state 在 surfaces 发布后、source commit 前加入同一 rollback boundary。participant key 在一个 outer transaction 中必须唯一。它不是 observer失败会回滚 transaction。Observer failure 只记录,不回滚已提交结果。
`tp-transaction-participate-v2` 允许 client side state 在 surfaces 发布后、
source commit 前加入同一 rollback boundary。调用方通过 `:key`、`:stage` 和
`:rollback` 注册 structured participant返回值仍是 key内部 participant
identity、state 与 journal 不暴露。participant key 在一个 outer transaction
中必须唯一。它不是 observer失败会回滚 transaction。Observer failure 只记录,
不回滚已提交结果。
publication batch、structured participant、final marker 与 tagged outcome 共享
现有 journal/change-group不复制第二份 live state。publication batch 是唯一
live writersurface 从 candidate entries 执行participant 从 candidate
绑定的同一 identity vector 执行final accept 从 candidate binding 执行;任何
binding/order 漂移都会 fail-fast 并回滚。TP 2.0 不再提供 alternate writer、
execution route 或 artifact-mode switch。`tp-with-transaction` 的返回值仍是 body result
success/failure outcome 只走内部 side channel。zero-surface 与 output-equal
operation 不创建 publication batch。
ETAF uses this API with one opaque participant for its immutable generation and
Ebox client state. The participant is published only after candidate

View File

@ -1,6 +1,6 @@
# TP 1.0 Current Architecture
# TP 2.0 Current Architecture
本文描述 TP 1.0 当前实现的模块边界、权威状态、数据流和事务模型。公共行为合同见 [API semantics](API-SEMANTICS.md),设计背景见 [retained runtime architecture](retained-runtime-target-architecture.md)。
本文描述 TP 2.0 当前实现的模块边界、权威状态、数据流和事务模型。公共行为合同见 [API semantics](API-SEMANTICS.md),设计背景见 [retained runtime architecture](retained-runtime-target-architecture.md)。
按功能查找公共入口和用法时,使用 [API reference](API-REFERENCE.md)。
@ -26,6 +26,7 @@ TP 不依赖 Ebox 或 ECSS不包含 selector、stylesheet、CSS cascade、Box
```text
tp-core
├─ tp-style
├─ tp-transaction
│ └─ tp-reactive
│ └─ tp-surface
├─ tp-layer
@ -44,6 +45,7 @@ tp.el loads the public package surface
| --- | --- | --- |
| `tp-core.el` | canonical ranges/requests/results、interval traversal、plist/face merge、native property facts | runtime identity、reactivity、publication |
| `tp-style.el` | native property policies、direct declarations、explicit computed source、projection | selector、stylesheet、specificity、CSS winner |
| `tp-transaction.el` | structured batch/entry validators、one-shot states、opaque final-marker descriptors、tagged outcomes | live buffer writer、consumer semantics、parallel journals |
| `tp-reactive.el` | signals、bindings、dynamic dependency graph、scheduler、candidate source state、transaction participants | buffer scans、mount positions、layout impact |
| `tp-surface.el` | prepare context、objects、plans、anchors、mount/index、contribution ledger、diff、publication、rollback、reports | stylesheet/cascade、consumer layout decisions |
| `tp-layer.el` | `define-tp`/`define-tps` declaration recipes and registry | live layer stack、inline runtime metadata、watcher engine |
@ -180,6 +182,11 @@ An equal candidate produces no prepared publication. It preserves revision, repo
The outer transaction owns candidate source values, dirty bindings, prepared surfaces, participants, inverse journals, view state, and final observer scheduling.
The v2 contract uses those exact owners. It does not copy participant,
scheduler, snapshot, journal, or change-group state. The publication batch is
the sole writer and validates its canonical entries against the committed
property and revision state after commit or rollback.
```text
freeze candidate writes
→ recompute exact dependency closure
@ -188,7 +195,11 @@ freeze candidate writes
→ capture inverse journals
→ publish surfaces in stable id order
→ publish transaction participants
→ commit signals/bindings/surface state/revisions
→ run precommit validators
→ commit signals
→ apply bounded opaque final markers
→ invoke the single final accept
→ finalize tagged success evidence
→ run observers
```
@ -196,7 +207,16 @@ Content publication edits the minimal text span and then exact property runs. Pr
Rollback restores text, properties, marker/index state, plans, producer, client state, signal values, binding values/dependencies, dirty queues, revisions and reports. Property journals are explicit because `atomic-change-group` alone does not cover every silent property mutation path.
`tp-transaction-participate` lets a consumer promote rollback-capable opaque state inside this boundary. Observers are different: they run only after the transaction commits, and observer failure is recorded rather than rolled back.
`tp-transaction-participate-v2` lets a consumer promote rollback-capable opaque state inside this boundary. Observers are different: they run only after the transaction commits, and observer failure is recorded rather than rolled back.
Each structured participant has one stable key, registration order, stage,
rollback, optional declared precommit, contained after-commit work, owner
journal, and one-shot state. Final markers are not
participants. TP treats their values as opaque and accepts only predeclared,
fixed-bound operations. M1a's closed `tp-vector-slots/v1` primitive accepts
only prebuilt vector-slot expectations and writes; marker registration cannot
inject callbacks. Partial apply or final-accept failure restores markers in
reverse order before the existing participant/surface/signal rollback.
If publication kills a target buffer, kill teardown is authoritative. Other surfaces and source state roll back; TP never recreates the killed buffer.

View File

@ -160,6 +160,15 @@
(should (= calls 2))
(should (= (plist-get (tp-reactive-counters) :recomputed) 1)))))
(ert-deftest tp-binding-test-public-transaction-state-follows-dynamic-extent ()
"The public transaction predicate is true only inside joined transactions."
(should-not (tp-transaction-active-p))
(tp-with-transaction
(should (tp-transaction-active-p))
(tp-with-transaction
(should (tp-transaction-active-p))))
(should-not (tp-transaction-active-p)))
(ert-deftest tp-binding-test-transaction-commits-signals-in-first-touch-order ()
"Touched signals commit once in first-touch order, including net reverts."
(tp-binding-test--isolated
@ -390,20 +399,20 @@
(setq failure
(condition-case condition
(tp-with-transaction
(tp-transaction-participate
'first
(lambda ()
(tp-transaction-participate-v2
:key 'first
:stage (lambda ()
(push 'publish-first
tp-binding-test-transaction-trace))
(lambda ()
:rollback (lambda ()
(push 'rollback-first
tp-binding-test-transaction-trace)))
(tp-transaction-participate
'second
(lambda ()
(tp-transaction-participate-v2
:key 'second
:stage (lambda ()
(push 'publish-second
tp-binding-test-transaction-trace))
(lambda ()
:rollback (lambda ()
(push 'rollback-second
tp-binding-test-transaction-trace)))
(tp-signal-set signal 2))
@ -680,7 +689,8 @@
(caller-vector (vector (copy-sequence "key")))
(key (list 'test caller-string caller-vector)))
(tp-with-transaction
(tp-transaction-participate key #'ignore #'ignore)
(tp-transaction-participate-v2
:key key :stage #'ignore :rollback #'ignore)
(let ((stored (tp--transaction-participant-key
(car tp--transaction-participants))))
(should-not (eq (nth 1 stored) caller-string))
@ -692,8 +702,9 @@
(should (equal (nth 1 stored) "participant"))
(should (equal (nth 2 stored) ["key"]))
(should-error
(tp-transaction-participate
(list 'test "participant" ["key"]) #'ignore #'ignore)
(tp-transaction-participate-v2
:key (list 'test "participant" ["key"])
:stage #'ignore :rollback #'ignore)
:type 'tp-reactive-error))))))
(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge ()

View File

@ -161,6 +161,49 @@
(should (equal (nth 0 copy) "value"))
(should (equal (nth 1 copy) ["nested"])))))
(ert-deftest tp-core-test-property-value-copy-isolates-full-keymaps ()
"Full keymaps, parent maps and self-references retain an isolated graph."
(let* ((map (make-keymap))
(parent (make-keymap))
(callback (lambda () "callback")))
(define-key map (kbd "RET") callback)
(define-key parent (kbd "x") #'ignore)
(define-key map [prefix] map)
(set-keymap-parent map parent)
(let ((copy (tp-property-value-copy map)))
(should-not (eq copy map))
(should-not (eq (keymap-parent copy) parent))
(should (eq (lookup-key copy [prefix]) copy))
(should (eq (lookup-key copy (kbd "RET")) callback))
(define-key map (kbd "RET") #'forward-char)
(define-key parent (kbd "x") #'backward-char)
(should (eq (lookup-key copy (kbd "RET")) callback))
(should (eq (lookup-key copy (kbd "x")) #'ignore)))))
(ert-deftest tp-core-test-property-value-copy-preserves-character-table-structure ()
"Local ranges, defaults, parents, extra slots and cycles are copied faithfully."
(let ((purpose (make-symbol "tp-copy-table")))
(put purpose 'char-table-extra-slots 1)
(let* ((parent (make-char-table purpose))
(table (make-char-table purpose))
(value (list 'value)))
(set-char-table-range parent ?p value)
(set-char-table-range table ?x value)
(set-char-table-range table ?s table)
(set-char-table-extra-slot table 0 value)
(set-char-table-parent table parent)
(let ((copy (tp-property-value-copy table)))
(should (eq (char-table-range copy ?s) copy))
(should (eq (char-table-range copy ?x) (char-table-extra-slot copy 0)))
(should (eq (char-table-range copy ?x)
(char-table-range (char-table-parent copy) ?p)))
(set-char-table-range (char-table-parent copy) ?p 'new)
(should (eq (char-table-range copy ?p) 'new))
(set-char-table-range copy nil 'default)
(should (eq (char-table-range copy ?z) 'default))
(setcar value 'mutated)
(should (equal (char-table-range copy ?x) '(value)))))))
(ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
"Property copies keep list-shaped function values opaque."
(let ((function-value '(lambda () 1)))

View File

@ -0,0 +1,188 @@
;;; tp-m0a-characterization-tests.el --- Current TP completion semantics -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;;; Commentary:
;; Focused M0a characterization tests for completion semantics that are
;; already implemented. Future structured batches and final markers do not
;; belong in this baseline.
;;; Code:
(require 'cl-lib)
(require 'ert)
(require 'tp-surface)
(define-error 'tp-m0a-characterization-error
"Injected TP M0a characterization failure")
(defvar tp-m0a-characterization--precommit-condition nil
"Condition injected by the M0a precommit test hook.")
(defun tp--m0a-characterization-precommit-inject ()
"Signal `tp-m0a-characterization--precommit-condition'."
(when tp-m0a-characterization--precommit-condition
(signal (car tp-m0a-characterization--precommit-condition)
(cdr tp-m0a-characterization--precommit-condition))))
(defun tp-m0a-characterization--leaf (text)
"Return a retained content leaf displaying TEXT."
(tp-surface-plan-create
:key 'root :kind 'text :text text :capability 'content))
(defun tp-m0a-characterization--producer (source)
"Return a retained content producer reading SOURCE."
(lambda (context)
(tp-object-ensure context nil 'root 'text)
(tp-m0a-characterization--leaf
(number-to-string (tp-signal-read source)))))
(defun tp-m0a-characterization--capture (function)
"Call FUNCTION and return its signaled condition."
(condition-case condition
(progn (funcall function) nil)
(tp-m0a-characterization-error condition)))
(cl-defmacro tp-m0a-characterization--with-surface
((buffer surface source) &rest body)
"Create BUFFER, SOURCE, and SURFACE, then evaluate BODY."
(declare (indent 1) (debug ((symbolp symbolp symbolp) body)))
`(let* ((,buffer (generate-new-buffer " *tp-m0a-characterization*"))
(,source (tp-signal-create 1))
(,surface
(tp-surface-mount
,buffer (tp-m0a-characterization--producer ,source)
'(:capability content))))
(unwind-protect
(progn ,@body)
(when (buffer-live-p ,buffer)
(kill-buffer ,buffer))
(when (tp-signal-live-p ,source)
(tp-signal-dispose ,source)))))
(ert-deftest tp-m0a-characterization-test-first-surface-failure-rolls-back-batch ()
"A first-surface failure restores every surface and the source state."
(let* ((source (tp-signal-create 1))
(producer (tp-m0a-characterization--producer source))
(first-buffer (generate-new-buffer " *tp-m0a-first*"))
(second-buffer (generate-new-buffer " *tp-m0a-second*"))
(first (tp-surface-mount
first-buffer producer '(:capability content)))
(second (tp-surface-mount
second-buffer producer '(:capability content)))
(first-revision (tp-surface-revision first))
(second-revision (tp-surface-revision second))
(injected '(tp-m0a-characterization-error
:phase first-surface :payload (1 2 3)))
(tp--surface-publication-step-function
(lambda (step surface)
(when (and (eq step 'client-state) (eq surface first))
(signal (car injected) (cdr injected))))))
(unwind-protect
(let ((failure
(tp-m0a-characterization--capture
(lambda () (tp-signal-set source 2)))))
(should (equal failure injected))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision first) first-revision))
(should (= (tp-surface-revision second) second-revision))
(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))
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
(ert-deftest tp-m0a-characterization-test-participant-failure-preserves-condition ()
"A participant failure preserves raw condition data and restores all owners."
(tp-m0a-characterization--with-surface (buffer surface source)
(let ((external 'old)
(revision (tp-surface-revision surface))
(injected '(tp-m0a-characterization-error
:phase participant :payload [raw data])))
(let ((failure
(tp-m0a-characterization--capture
(lambda ()
(tp-with-transaction
(tp-transaction-participate-v2
:key 'm0a-participant
:stage (lambda ()
(setq external 'candidate)
(signal (car injected) (cdr injected)))
:rollback (lambda () (setq external 'old)))
(tp-signal-set source 2))))))
(should (equal failure injected)))
(should (eq external 'old))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(ert-deftest tp-m0a-characterization-test-precommit-failure-preserves-condition ()
"A precommit failure preserves raw condition data and restores publication."
(tp-m0a-characterization--with-surface (buffer surface source)
(let* ((revision (tp-surface-revision surface))
(injected '(tp-m0a-characterization-error
:phase precommit :payload (raw data)))
(tp--transaction-precommit-functions
'(tp--m0a-characterization-precommit-inject))
(tp--transaction-precommit-allowed-functions
'(tp--m0a-characterization-precommit-inject))
(tp-m0a-characterization--precommit-condition injected)
(failure
(tp-m0a-characterization--capture
(lambda () (tp-signal-set source 2)))))
(should (equal failure injected))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(ert-deftest tp-m0a-characterization-test-signal-commit-failure-preserves-condition ()
"A signal commit failure preserves raw condition data and restores publication."
(tp-m0a-characterization--with-surface (buffer surface source)
(let ((revision (tp-surface-revision surface))
(injected '(tp-m0a-characterization-error
:phase signal :payload (:raw data)))
(original (symbol-function 'tp--commit-signal-entry)))
(let ((failure
(cl-letf (((symbol-function 'tp--commit-signal-entry)
(lambda (entry)
(funcall original entry)
(signal (car injected) (cdr injected)))))
(tp-m0a-characterization--capture
(lambda () (tp-signal-set source 2))))))
(should (equal failure injected)))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(ert-deftest tp-m0a-characterization-test-final-accept-failure-preserves-condition ()
"A final-accept failure preserves raw condition data and restores publication."
(tp-m0a-characterization--with-surface (buffer surface source)
(let ((revision (tp-surface-revision surface))
(injected '(tp-m0a-characterization-error
:phase final-accept :payload ((raw . data)))))
(let ((failure
(cl-letf (((symbol-function 'accept-change-group)
(lambda (_group)
(signal (car injected) (cdr injected)))))
(tp-m0a-characterization--capture
(lambda () (tp-signal-set source 2))))))
(should (equal failure injected)))
(should (= (tp-signal-peek source) 1))
(should (= (tp-signal-revision source) 0))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(provide 'tp-m0a-characterization-tests)
;;; tp-m0a-characterization-tests.el ends here

View File

@ -14,6 +14,46 @@
(require 'tp-style)
(require 'tp-layer)
(ert-deftest tp-style-test-native-keymaps-preserve-all-binding-facts ()
"Snapshots compare by prompts, menu order, parents and literal commands."
(let* ((factory (eval '(lambda ()
(let ((n 0))
(lambda () (setq n (1+ n))))) t))
(first (funcall factory)) (second (funcall factory))
(map (make-keymap "Root"))
(prefix (make-sparse-keymap "Prefix"))
(parent (make-sparse-keymap "Parent")))
(define-key map (kbd "RET") first)
(define-key map [t] #'ignore)
(define-key prefix [self] prefix)
(define-key prefix [one] '(menu-item "One" ignore))
(define-key prefix [two] '(menu-item "Two" forward-char))
(define-key map [prefix] prefix)
(define-key parent [inherited] #'backward-char)
(set-keymap-parent map parent)
(should (equal first second))
(should (tp--native-property-value-equal-p map (tp-property-value-copy map)))
(dolist (kind '(root-prompt prefix-prompt parent-prompt menu-order
callback default inherited))
(let ((copy (tp-property-value-copy map)))
(pcase kind
((or 'root-prompt 'prefix-prompt 'parent-prompt)
(let* ((target (pcase kind
('root-prompt copy)
('prefix-prompt (lookup-key copy [prefix]))
('parent-prompt (keymap-parent copy))))
(cell (memq (keymap-prompt target) target)))
(setcar cell "Changed")))
('menu-order
(let* ((target (lookup-key copy [prefix]))
(one (lookup-key target [one])))
(define-key target [one] nil t)
(define-key target [one] one)))
('callback (define-key copy (kbd "RET") second))
('default (define-key copy [t] #'forward-char))
('inherited (define-key (keymap-parent copy) [inherited] #'ignore)))
(should-not (tp--native-property-value-equal-p map copy))))))
(defmacro tp-style-test--isolated (&rest body)
"Run BODY with isolated TP property and named-style registries."
(declare (indent 0) (debug t))

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -279,6 +279,7 @@ Otherwise, START-OR-STRING and END define the range."
(and (not (functionp value))
(or (consp value)
(stringp value)
(char-table-p value)
(and (vectorp value) (not (recordp value))))))
(defun tp--copy-cons-spine (value cache)
@ -309,6 +310,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology."
(if (and (not (functionp item))
(or (consp item)
(stringp item)
(char-table-p item)
(and (vectorp item) (not (recordp item)))))
(tp--copy-property-value item cache)
item)))
@ -323,6 +325,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology."
(defun tp--copy-proper-cons-list (value cache)
"Return a fast memoized copy of uncached proper-list VALUE.
CACHE preserves sharing and cycles across the copied value graph.
The whole spine is registered before mutable cars are copied, preserving
back-references from cars while `copy-sequence' supplies the spine cheaply."
(let ((source value)
@ -343,6 +346,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply."
(when (and (not (functionp item))
(or (consp item)
(stringp item)
(char-table-p item)
(and (vectorp item) (not (recordp item)))))
(setcar target (tp--copy-property-value item cache))))
(setq source (cdr source)
@ -352,6 +356,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply."
(defun tp--copy-string-with-properties
(value &optional cache reuse-property-p)
"Return a copy of string VALUE with recursively copied property values.
CACHE preserves sharing across mutable property values.
REUSE-PROPERTY-P, when non-nil, is called with PROPERTY and VALUE. A non-nil
result transfers that exact candidate-owned VALUE into the returned string;
the caller must ensure that VALUE is not mutated by another owner. Values not
@ -403,7 +408,9 @@ values are recursively isolated."
(defun tp--copy-property-value (value &optional cache)
"Return a defensive copy of mutable containers in property VALUE.
Cons cells, strings, and vectors are copied recursively. Functions, records,
Optional CACHE preserves sharing and cycles across recursive copies.
Cons cells, strings, vectors and character tables are copied recursively.
Functions, records,
and other opaque objects keep their identity; functions are never executed."
(if (not (tp--copy-mutable-property-value-p value))
value
@ -417,6 +424,29 @@ and other opaque objects keep their identity; functions are never executed."
(tp--copy-proper-cons-list value cache)
(tp--copy-cons-spine value cache)))
((stringp value) (tp--copy-string-with-properties value cache))
((char-table-p value)
(let ((copy (copy-sequence value))
(default (char-table-range value nil))
entries)
(puthash value copy cache)
;; Enumerate only local assignments, without inherited/default
;; ranges becoming explicit assignments in the copied table.
(set-char-table-parent copy nil)
(set-char-table-range copy nil nil)
(map-char-table (lambda (range item) (push (cons range item) entries))
copy)
(dolist (entry entries)
(set-char-table-range
copy (car entry) (tp--copy-property-value (cdr entry) cache)))
(set-char-table-range copy nil (tp--copy-property-value default cache))
(set-char-table-parent
copy (tp--copy-property-value (char-table-parent value) cache))
(dotimes (index (or (get (char-table-subtype value)
'char-table-extra-slots) 0))
(set-char-table-extra-slot
copy index (tp--copy-property-value
(char-table-extra-slot value index) cache)))
copy))
((vectorp value)
(let ((copy (copy-sequence value)))
(puthash value copy cache)
@ -428,7 +458,8 @@ and other opaque objects keep their identity; functions are never executed."
(defun tp-property-value-copy (value)
"Return a defensive copy of mutable text-property VALUE.
Functions, records, and other opaque identities are retained; mutable cons,
string, and non-record vector graphs are copied with sharing and cycles intact."
string, character-table and non-record vector graphs are copied with sharing
and cycles intact."
(tp--copy-property-value value (make-hash-table :test #'eq)))
(defun tp--deep-merge-plist (base new)

View File

@ -11,13 +11,14 @@
;;; Commentary:
;; TP 1.0's exact signal-to-binding dependency graph, transaction-local
;; TP 2.0's exact signal-to-binding dependency graph, transaction-local
;; scheduler, scoped variable adapters, and rollback state.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(require 'tp-transaction)
(define-error 'tp-reactive-error "TP reactive runtime error")
(define-error 'tp-invalid-signal-scope "Invalid TP signal scope"
@ -43,8 +44,8 @@
(cl-defstruct (tp--transaction-participant
(:constructor tp--make-transaction-participant))
"One rollback-capable side-state participant in a TP transaction."
key publish rollback)
"One structured transaction participant."
key rollback protocol order stage precommit after-commit journal state)
(cl-defstruct (tp--signal-commit-entry
(:constructor tp--make-signal-commit-entry))
@ -68,6 +69,11 @@
:subscription-added 0 :subscription-removed 0))
(defvar tp--transaction-active nil)
;;;###autoload
(defun tp-transaction-active-p ()
"Return non-nil while the current dynamic extent is in a TP transaction."
(and tp--transaction-active t))
(defvar tp--transaction-signal-values nil)
(defvar tp--transaction-signals nil)
(defvar tp--transaction-dirty-set nil)
@ -80,10 +86,28 @@
(defvar tp--transaction-after-commit-callbacks nil)
(defvar tp--transaction-participants nil)
(defvar tp--transaction-participant-keys nil)
(defvar tp--transaction-participant-order 0)
(defvar tp--transaction-published-participants nil)
(defvar tp--transaction-signal-commit-journal nil)
(defvar tp--transaction-id nil)
(defvar tp--transaction-phase nil)
(defvar tp--transaction-phase-start nil)
(defvar tp--transaction-phase-timings nil)
(defvar tp--transaction-publication-batch nil)
(defvar tp--transaction-structured-participants nil)
(defvar tp--transaction-final-marker-registry nil)
(defvar tp--transaction-final-marker-owner-keys nil)
(defvar tp--transaction-final-marker-count 0)
(defvar tp--transaction-final-marker-slot-writes 0)
(defvar tp--transaction-final-markers-frozen-p nil)
(defvar tp--transaction-applied-final-marker-count 0)
(defvar tp--transaction-marker-restore-failures nil)
(defvar tp--transaction-outcome nil)
(defvar tp--transaction-outcome-cell nil)
(defvar tp--transaction-contained-failures nil)
(defvar tp--last-transaction-diagnostics nil)
(defvar tp--last-transaction-outcome nil)
(defvar tp--last-shadow-proof nil)
(defvar tp--current-binding nil)
(defvar tp--binding-compute-stack nil)
(defvar tp--collected-dependency-set nil)
@ -103,6 +127,9 @@
(defvar tp--transaction-rollback-final-functions nil)
(defvar tp--transaction-committed-functions nil)
(defvar tp--transaction-participant-precommit-allowed-functions nil
"Declared internal structured-participant precommit validators.")
(defconst tp--transaction-condition-trailer-tag
(make-symbol "tp--transaction-condition-trailer")
"Unforgeable tag separating primary condition data from TP metadata.")
@ -492,7 +519,8 @@ or `retain'."
(defun tp--bind-precomputed-in-transaction
(owner key compute value dependencies equality lifecycle)
"Install one new initialized binding with explicit DEPENDENCIES."
"Install OWNER's KEY using COMPUTE, VALUE, and explicit DEPENDENCIES.
EQUALITY controls change detection and LIFECYCLE controls candidate omission."
(let ((table (tp--owner-binding-table owner t)))
(when (gethash key table)
(signal 'tp-reactive-error (list :precomputed-binding-exists key)))
@ -521,6 +549,8 @@ or `retain'."
(owner key compute value dependencies
&key (equality #'equal) (lifecycle 'delete))
"Install a new binding with precomputed VALUE and explicit DEPENDENCIES.
OWNER and KEY identify the binding; EQUALITY and LIFECYCLE retain their normal
`tp-bind' meanings.
COMPUTE remains the authoritative recomputation function after any dependency
changes. This entry avoids evaluating COMPUTE merely to rediscover a value
and graph edges already produced by a compiler or pure projection pass."
@ -619,50 +649,159 @@ When CREATE is non-nil, install and return a fresh hash table when absent."
(signal 'tp-reactive-error (list :outside-transaction function)))
(push function tp--transaction-after-commit-callbacks))
;;;###autoload
(defun tp-transaction-participate (key publish rollback)
"Register rollback-capable PUBLISH work under transaction-local KEY.
PUBLISH runs after every affected surface has published its candidate buffer
and side state, but before the transaction commits its source values. If this
or any later publication step fails, ROLLBACK runs in reverse publication
order. Both functions take no arguments. KEY must be unique in the outer
transaction."
(defun tp--transaction-participant-precommit-function-p (function)
"Return non-nil when FUNCTION is a declared internal participant validator."
(or (null function)
(and (symbolp function)
(memq function
tp--transaction-participant-precommit-allowed-functions)
(fboundp function))))
(defun tp--transaction-register-participant (participant)
"Register structured PARTICIPANT once in the active transaction."
(unless tp--transaction-active
(signal 'tp-reactive-error
(list :participant-outside-transaction
(tp--transaction-participant-key participant))))
(let ((key (tp--transaction-participant-key participant)))
(unless key
(signal 'tp-reactive-error (list :participant-key key)))
(when (member key tp--transaction-participant-keys)
(signal 'tp-reactive-error (list :duplicate-participant-key key)))
(push (tp--copy-property-value key) tp--transaction-participant-keys)
(push participant tp--transaction-participants)
participant))
(defun tp--transaction-make-participant
(key stage rollback protocol precommit after-commit journal)
"Build a participant from KEY, STAGE, ROLLBACK, and PROTOCOL.
PRECOMMIT and AFTER-COMMIT are optional internal callbacks; JOURNAL is opaque
owner-local rollback state."
(unless (functionp stage)
(signal 'wrong-type-argument (list 'functionp stage)))
(unless (functionp rollback)
(signal 'wrong-type-argument (list 'functionp rollback)))
(unless (tp--transaction-participant-precommit-function-p precommit)
(signal 'tp-reactive-error
(list :invalid-participant-precommit precommit)))
(unless (or (null after-commit) (functionp after-commit))
(signal 'wrong-type-argument (list 'functionp after-commit)))
(tp--make-transaction-participant
:key (tp--copy-property-value key)
:rollback rollback
:protocol protocol
:order (prog1 tp--transaction-participant-order
(cl-incf tp--transaction-participant-order))
:stage stage
:precommit precommit
:after-commit after-commit
:journal journal
:state 'prepared))
(cl-defun tp--transaction-participate-v2
(&key key stage rollback precommit after-commit journal)
"Register internal KEY with structured STAGE and ROLLBACK capabilities.
PRECOMMIT and AFTER-COMMIT are optional declared callbacks. JOURNAL is the
participant's opaque owner-local state."
(unless tp--transaction-active
(signal 'tp-reactive-error (list :participant-outside-transaction key)))
(unless key
(signal 'tp-reactive-error (list :participant-key key)))
(unless (functionp publish)
(signal 'wrong-type-argument (list 'functionp publish)))
(unless (functionp rollback)
(signal 'wrong-type-argument (list 'functionp rollback)))
(when (member key tp--transaction-participant-keys)
(signal 'tp-reactive-error (list :duplicate-participant-key key)))
(push (tp--copy-property-value key) tp--transaction-participant-keys)
(push (tp--make-transaction-participant
:key (tp--copy-property-value key)
:publish publish :rollback rollback)
tp--transaction-participants)
(tp--transaction-register-participant
(tp--transaction-make-participant
key stage rollback 'v2 precommit after-commit journal)))
;;;###autoload
(cl-defun tp-transaction-participate-v2
(&key key stage rollback precommit after-commit journal)
"Register a structured rollback-capable participant under KEY.
STAGE and ROLLBACK are required no-argument functions. PRECOMMIT may be one
declared package-owned validator; AFTER-COMMIT is contained work queued only
after final accept. JOURNAL is opaque owner-local rollback state. Return KEY
without exposing TP's internal participant object."
(tp--transaction-participate-v2
:key key :stage stage :rollback rollback :precommit precommit
:after-commit after-commit :journal journal)
key)
(defun tp--publish-transaction-participants ()
"Publish registered transaction participants in declaration order."
(dolist (participant (nreverse tp--transaction-participants))
(defun tp--transaction-participants-in-registration-order ()
"Return the authoritative participants in deterministic declaration order."
(reverse tp--transaction-participants))
(defun tp--transaction-validate-structured-participants ()
"Return the frozen participant vector after exact identity validation."
(let* ((participants tp--transaction-structured-participants)
(registered (tp--transaction-participants-in-registration-order))
(count (length registered)))
(unless (and (vectorp participants) (= (length participants) count))
(signal 'tp-publication-binding-error
(list :participant-count participants registered)))
(cl-loop for participant in registered
for index from 0
unless (eq participant (aref participants index))
do (signal 'tp-publication-binding-error
(list :participant-order index participant
(aref participants index))))
(when tp--transaction-publication-batch
(let ((candidate-participants
(tp-publication-batch-candidate-participants
tp--transaction-publication-batch)))
(unless (eq candidate-participants participants)
(signal 'tp-publication-binding-error
(list :participant-vector candidate-participants
participants)))))
participants))
(defun tp--stage-structured-transaction-participants ()
"Stage the frozen structured participant vector in declaration order."
(let ((participants (tp--transaction-validate-structured-participants)))
(dotimes (index (length participants))
(let ((participant (aref participants index)))
(push participant tp--transaction-published-participants)
(funcall (tp--transaction-participant-publish participant))))
(setf (tp--transaction-participant-state participant) 'staged)
(funcall (tp--transaction-participant-stage participant))))))
(defun tp--rollback-transaction-participants ()
"Rollback published participants and return any failures."
(let (failures)
(dolist (participant tp--transaction-published-participants)
(unwind-protect
(condition-case failure
(funcall (tp--transaction-participant-rollback participant))
((error quit)
(push (list 'participants
(tp--transaction-participant-key participant)
failure)
failures))))
failures)))
(setf (tp--transaction-participant-state participant) 'rolled-back)))
(dolist (participant tp--transaction-participants)
(when (eq (tp--transaction-participant-state participant) 'prepared)
(setf (tp--transaction-participant-state participant) 'rolled-back)))
(nreverse failures)))
(defun tp--run-structured-transaction-participant-precommits ()
"Run validators from the frozen structured participant vector."
(let ((participants (tp--transaction-validate-structured-participants)))
(dotimes (index (length participants))
(when-let* ((function
(tp--transaction-participant-precommit
(aref participants index))))
(unless (tp--transaction-participant-precommit-function-p function)
(signal 'tp-reactive-error
(list :invalid-participant-precommit function)))
(funcall function)))))
(defun tp--commit-structured-transaction-participants ()
"Commit states from the frozen structured participant vector."
(let ((participants (tp--transaction-validate-structured-participants)))
(dotimes (index (length participants))
(let ((participant (aref participants index)))
(when (eq (tp--transaction-participant-state participant) 'staged)
(setf (tp--transaction-participant-state participant) 'committed)
(when-let* ((function
(tp--transaction-participant-after-commit participant)))
(tp--enqueue-after-commit function)))))))
(defun tp--dequeue-dirty-binding ()
"Return and remove the next queued dirty binding."
(let (binding)
@ -749,6 +888,409 @@ transaction."
tp--transaction-final-accept-function function)))
(setq tp--transaction-final-accept-function function))
(defun tp--transaction-current-outcome-cell ()
"Return the active transaction's caller-retainable one-slot outcome cell."
(unless tp--transaction-active
(signal 'tp-reactive-error (list :outcome-cell-outside-transaction)))
tp--transaction-outcome-cell)
(defun tp--transaction-enter-phase (phase)
"Record the completed phase duration and enter PHASE."
(let ((now (float-time)))
(when (and tp--transaction-phase tp--transaction-phase-start)
(push (cons tp--transaction-phase
(- now tp--transaction-phase-start))
tp--transaction-phase-timings))
(setq tp--transaction-phase phase
tp--transaction-phase-start now)))
(defun tp--transaction-publish-outcome (outcome)
"Publish internal OUTCOME without changing the public transaction return."
(setq tp--transaction-outcome outcome
tp--last-transaction-outcome outcome)
(when (vectorp tp--transaction-outcome-cell)
(aset tp--transaction-outcome-cell 0 outcome))
(when tp--transaction-publication-batch
(setf (tp-publication-batch-candidate-outcome
tp--transaction-publication-batch)
outcome))
outcome)
(defun tp--transaction-batch-journal-view (surface-journals)
"Return a fixed view vector over current journals and SURFACE-JOURNALS."
(vector tp--transaction-extensions
tp--transaction-signal-values
tp--transaction-binding-snapshots
tp--transaction-counter-start
tp--transaction-signal-commit-journal
surface-journals))
(defun tp--transaction-begin-publication-batch
(batch-id entries surface-journals stage-entries)
"Install BATCH-ID for ENTRIES, SURFACE-JOURNALS, and STAGE-ENTRIES."
(unless tp--transaction-active
(signal 'tp-reactive-error (list :batch-outside-transaction batch-id)))
(when tp--transaction-publication-batch
(signal 'tp-publication-state-error
(list :duplicate-transaction-batch batch-id)))
(setq tp--transaction-publication-batch
(tp--publication-batch-prepare
:transaction-id tp--transaction-id
:batch-id batch-id
:entries entries
:participants
tp--transaction-structured-participants
:journals (tp--transaction-batch-journal-view surface-journals)
:stage-entries stage-entries
:final-accept tp--transaction-final-accept-function
:diagnostics nil))
tp--transaction-publication-batch)
(defun tp--transaction-batch-transition (next)
"Move the active publication candidate to NEXT when one exists."
(when tp--transaction-publication-batch
(tp--publication-batch-transition
tp--transaction-publication-batch next)))
(cl-defun tp--transaction-register-final-marker
(&key owner-key expected-token expected-version next-values inverse-values
slot-write-count operation-key)
"Register a bounded opaque marker for OWNER-KEY before precommit.
EXPECTED-TOKEN and EXPECTED-VERSION bind owner state. NEXT-VALUES and
INVERSE-VALUES are prebuilt opaque payloads. SLOT-WRITE-COUNT is checked
against the trusted OPERATION-KEY descriptor and the transaction bound."
(unless (and tp--transaction-active
(memq tp--transaction-phase
'(body recompute publication participants))
(not tp--transaction-final-markers-frozen-p))
(signal 'tp-final-marker-error
(list :registration-phase tp--transaction-phase)))
(when (>= tp--transaction-final-marker-count tp--final-marker-max-count)
(signal 'tp-final-marker-error
(list :marker-count tp--transaction-final-marker-count)))
(let ((duplicate nil))
(dotimes (index tp--transaction-final-marker-count)
(when (equal owner-key
(aref tp--transaction-final-marker-owner-keys index))
(setq duplicate t)))
(when duplicate
(signal 'tp-final-marker-error (list :duplicate-owner-key owner-key))))
(let ((marker
(tp--final-accept-marker-create
:owner-key owner-key
:expected-token expected-token
:expected-version expected-version
:next-values next-values
:inverse-values inverse-values
:slot-write-count slot-write-count
:operation-key operation-key)))
(when (> (+ tp--transaction-final-marker-slot-writes slot-write-count)
tp--final-marker-max-slot-writes)
(signal 'tp-final-marker-error
(list :slot-write-bound
tp--transaction-final-marker-slot-writes
slot-write-count)))
(aset tp--transaction-final-marker-registry
tp--transaction-final-marker-count marker)
(aset tp--transaction-final-marker-owner-keys
tp--transaction-final-marker-count
(tp--copy-property-value owner-key))
(cl-incf tp--transaction-final-marker-count)
(cl-incf tp--transaction-final-marker-slot-writes slot-write-count)
marker))
(cl-defun tp-transaction-register-final-marker
(&key owner-key expected-token expected-version next-values inverse-values
slot-write-count operation-key)
"Register one bounded final-accept authority marker.
OWNER-KEY must be unique in the active transaction. EXPECTED-TOKEN and
EXPECTED-VERSION bind owner state; NEXT-VALUES and INVERSE-VALUES are prebuilt
slot-write vectors with fixed SLOT-WRITE-COUNT. OPERATION-KEY must resolve
through TP's closed marker-operation whitelist."
(tp--transaction-register-final-marker
:owner-key owner-key
:expected-token expected-token
:expected-version expected-version
:next-values next-values
:inverse-values inverse-values
:slot-write-count slot-write-count
:operation-key operation-key))
(defun tp--transaction-freeze-final-markers ()
"Validate and seal every marker before signal commit and final accept."
(when (and (> tp--transaction-final-marker-count 0)
(null tp--transaction-publication-batch))
(signal 'tp-final-marker-error (list :marker-without-publication-batch)))
(dotimes (index tp--transaction-final-marker-count)
(tp--final-accept-marker-validate
(aref tp--transaction-final-marker-registry index)))
(setq tp--transaction-final-markers-frozen-p t)
(when tp--transaction-publication-batch
(setf (tp-publication-batch-candidate-markers
tp--transaction-publication-batch)
(cons tp--transaction-final-marker-registry
tp--transaction-final-marker-count)))
tp--transaction-final-marker-count)
(defun tp--transaction-sync-publication-batch ()
"Refresh fixed batch view slots after precommit and signal journaling."
(when tp--transaction-publication-batch
(setf (tp-publication-batch-candidate-final-accept
tp--transaction-publication-batch)
tp--transaction-final-accept-function)
(let ((journals
(tp-publication-batch-candidate-journals
tp--transaction-publication-batch)))
(when (vectorp journals)
(aset journals 4 tp--transaction-signal-commit-journal)))))
(defun tp--transaction-prepare-success-outcome ()
"Preallocate the active batch's success evidence before final accept."
(when tp--transaction-publication-batch
(let ((candidate tp--transaction-publication-batch)
(text-operations 0)
(property-operations 0)
(touched-characters 0)
target-counts)
(dolist (entry (tp-publication-batch-candidate-entries candidate))
(let ((counts (tp-publication-target-entry-operation-counts entry)))
(unless counts
(signal 'tp-publication-binding-error
(list :missing-operation-counts
(tp-publication-target-entry-surface-id entry))))
(cl-incf text-operations (or (plist-get counts :text-operations) 0))
(cl-incf property-operations
(or (plist-get counts :property-operations) 0))
(cl-incf touched-characters
(or (plist-get counts :touched-characters) 0))
(push (tp--copy-property-value counts) target-counts)))
(setf
(tp-publication-batch-candidate-operation-counts candidate)
(list :targets
(length (tp-publication-batch-candidate-entries candidate))
:participants (length tp--transaction-participants)
:signals (length tp--transaction-signals)
:markers tp--transaction-final-marker-count
:text-operations text-operations
:property-operations property-operations
:touched-characters touched-characters
:target-counts (nreverse target-counts))
(tp-publication-batch-candidate-phase-timings candidate)
(nreverse (copy-sequence tp--transaction-phase-timings))
(tp-publication-batch-candidate-diagnostics candidate)
(tp--copy-property-value tp--transaction-contained-failures))
(setf (tp-publication-batch-candidate-success-outcome-draft candidate)
(tp--committed-success-outcome-draft
candidate
(tp-publication-batch-candidate-operation-counts candidate)
(tp-publication-batch-candidate-phase-timings candidate)
(tp-publication-batch-candidate-diagnostics candidate)
tp--transaction-final-marker-count)))))
(defun tp--transaction-apply-one-final-marker (marker)
"Apply one prevalidated MARKER through its closed package primitive."
(funcall
(tp--final-marker-operation-apply
(tp-final-accept-marker-operation marker))
marker))
(defun tp--transaction-restore-one-final-marker (marker)
"Restore one prevalidated MARKER through its closed package primitive."
(funcall
(tp--final-marker-operation-restore
(tp-final-accept-marker-operation marker))
marker))
(defun tp--transaction-restore-final-marker-at (index failures-cell)
"Restore marker INDEX, then exhaustively continue using FAILURES-CELL."
(when (>= index 0)
(let ((marker (aref tp--transaction-final-marker-registry index)))
(unwind-protect
(when (memq (tp-final-accept-marker-state marker)
'(applying applied))
(setf (tp-final-accept-marker-state marker) 'restoring)
(condition-case failure
(progn
(tp--transaction-restore-one-final-marker marker)
(setf (tp-final-accept-marker-state marker) 'restored))
((error quit)
(setf (tp-final-accept-marker-state marker) 'restore-failed)
(aset
failures-cell 0
(cons (list 'final-markers
(tp-final-accept-marker-owner-key marker)
failure)
(aref failures-cell 0))))))
;; This cleanup runs even when a test or corrupted primitive exits by
;; an arbitrary nonlocal throw, so no earlier applied marker is skipped.
(tp--transaction-restore-final-marker-at
(1- index) failures-cell)))))
(defun tp--transaction-restore-applied-final-markers ()
"Reverse every applied marker and return contained restore failures."
(let ((index (1- tp--transaction-applied-final-marker-count))
(failures-cell (vector nil)))
(setq tp--transaction-applied-final-marker-count 0)
(tp--transaction-restore-final-marker-at index failures-cell)
(nreverse (aref failures-cell 0))))
(defun tp--transaction-apply-final-markers ()
"Apply every sealed marker in registration order."
(dotimes (index tp--transaction-final-marker-count)
(let ((marker (aref tp--transaction-final-marker-registry index)))
;; Count and mark first so mutate-then-signal is still reverse-restored.
(setq tp--transaction-applied-final-marker-count (1+ index))
(setf (tp-final-accept-marker-state marker) 'applying)
(tp--transaction-apply-one-final-marker marker)
(setf (tp-final-accept-marker-state marker) 'applied))))
(defun tp--transaction-commit-final-markers ()
"Finalize marker state through fixed writes after successful accept."
(dotimes (index tp--transaction-final-marker-count)
(setf (tp-final-accept-marker-state
(aref tp--transaction-final-marker-registry index))
'committed))
(setq tp--transaction-applied-final-marker-count 0))
(defun tp--transaction-run-final-accept ()
"Apply markers, invoke the existing single final accept, and finalize tags."
(tp--transaction-batch-transition 'final-accepting)
(let (accepted)
(unwind-protect
(progn
(tp--transaction-apply-final-markers)
(if tp--transaction-publication-batch
(let ((candidate-function
(tp-publication-batch-candidate-final-accept
tp--transaction-publication-batch)))
(unless (eq candidate-function
tp--transaction-final-accept-function)
(signal 'tp-publication-binding-error
(list :final-accept candidate-function
tp--transaction-final-accept-function)))
(funcall candidate-function))
(funcall tp--transaction-final-accept-function))
(setq accepted t))
(unless accepted
(setq tp--transaction-marker-restore-failures
(tp--transaction-restore-applied-final-markers))))
(when accepted
(tp--transaction-commit-final-markers)
(when tp--transaction-publication-batch
(let* ((candidate tp--transaction-publication-batch)
(outcome
(tp-publication-batch-candidate-success-outcome-draft
candidate)))
;; Every fallible validation and allocation happened before accept.
(setf (tp-publication-batch-candidate-state candidate) 'committed
(tp-publication-batch-candidate-resolution candidate) 'committed)
;; The success tag is a read-only slot with one coordinator-owned
;; fixed write after the existing final accept has returned.
(aset outcome tp--committed-success-outcome-tag-slot
'committed-success)
(tp--transaction-publish-outcome outcome))))))
(defun tp--transaction-run-shadow-proof (phase)
"Compare structured artifacts with the selected single live result for PHASE."
(when tp--transaction-publication-batch
(let ((ok t) results outcome-equivalent)
(dolist (entry
(tp-publication-batch-candidate-entries
tp--transaction-publication-batch))
(let ((validator (tp-publication-target-entry-shadow-validator entry)))
(condition-case failure
(let ((result (and validator (funcall validator entry phase))))
(setf (tp-publication-target-entry-shadow-actual entry) result
(tp-publication-target-entry-shadow-proven-p entry)
(and result (plist-get result :equivalent)))
(unless (tp-publication-target-entry-shadow-proven-p entry)
(setq ok nil))
(when (eq phase 'rollback)
(setf (tp-publication-target-entry-rollback-result entry)
(if (plist-get result :equivalent) 'restored 'mismatch)
(tp-publication-target-entry-post-rollback-state entry)
(plist-get result :actual)))
(push result results))
((error quit)
(setq ok nil)
(push (list :equivalent nil :failure failure) results)))))
(setq outcome-equivalent
(pcase phase
('commit
(tp--committed-success-outcome-valid-for-p
tp--transaction-outcome tp--transaction-publication-batch))
('rollback
(and tp--transaction-outcome
(tp--publication-failure-outcome-valid-for-p
tp--transaction-outcome
tp--transaction-publication-batch)))))
(when (and (eq phase 'commit) (not outcome-equivalent))
(setq ok nil))
(let ((proof (list :phase phase :equivalent ok
:outcome-equivalent outcome-equivalent
:entries (nreverse results))))
(setf (tp-publication-batch-candidate-shadow-proof
tp--transaction-publication-batch)
proof)
(setq tp--last-shadow-proof
(list :phase phase :equivalent ok
:outcome-equivalent outcome-equivalent
:entry-count
(length
(tp-publication-batch-candidate-entries
tp--transaction-publication-batch))))
(unless ok
(push (list 'shadow-proof phase proof)
tp--transaction-contained-failures))
proof))))
(defun tp--transaction-finalize-rollback-shadow-outcome ()
"Correlate the failure outcome with the already compared rollback artifacts."
(when-let* ((candidate tp--transaction-publication-batch)
(proof (tp-publication-batch-candidate-shadow-proof candidate)))
(let* ((outcome-equivalent
(tp--publication-failure-outcome-valid-for-p
tp--transaction-outcome candidate))
(equivalent
(and (plist-get proof :equivalent) outcome-equivalent)))
(setq proof (plist-put proof :outcome-equivalent outcome-equivalent)
proof (plist-put proof :equivalent equivalent))
(setf (tp-publication-batch-candidate-shadow-proof candidate) proof)
(setq tp--last-shadow-proof
(list :phase 'rollback :equivalent equivalent
:outcome-equivalent outcome-equivalent
:entry-count
(length (tp-publication-batch-candidate-entries candidate))))
(unless equivalent
(push (list 'shadow-proof 'rollback-outcome proof)
tp--transaction-contained-failures))
proof)))
(defun tp--transaction-finish-rollback (primary-condition rollback-failures)
"Finalize failure evidence for PRIMARY-CONDITION and ROLLBACK-FAILURES."
(dotimes (index tp--transaction-final-marker-count)
(let ((marker (aref tp--transaction-final-marker-registry index)))
(when (eq (tp-final-accept-marker-state marker) 'prepared)
(setf (tp-final-accept-marker-state marker) 'rolled-back))))
(when tp--transaction-publication-batch
(let ((candidate tp--transaction-publication-batch))
(unless (tp--publication-batch-terminal-p candidate)
(if (eq (tp-publication-batch-candidate-state candidate) 'prepared)
(progn
(setf (tp-publication-batch-candidate-state candidate) 'discarded
(tp-publication-batch-candidate-resolution candidate)
'discarded))
(tp--publication-batch-transition candidate 'rolled-back)))
(tp--transaction-run-shadow-proof 'rollback)
(when (and primary-condition
(eq (tp-publication-batch-candidate-state candidate)
'rolled-back))
(tp--transaction-publish-outcome
(tp--publication-failure-outcome-create
candidate tp--transaction-phase primary-condition rollback-failures
tp--transaction-contained-failures))
(tp--transaction-finalize-rollback-shadow-outcome)))))
(defun tp--run-contained-transaction-functions (phase functions)
"Run postaccept PHASE FUNCTIONS and record contained failures."
(dolist (function (tp--transaction-hook-functions functions))
@ -841,10 +1383,11 @@ transaction."
(defun tp--rollback-transaction-state (counter-snapshot)
"Restore COUNTER-SNAPSHOT through every rollback phase.
Return contained failures in phase order."
(let ((failures (tp--rollback-transaction-participants)))
(let ((failures (copy-sequence tp--transaction-marker-restore-failures)))
(setq failures
(append
failures
(tp--rollback-transaction-participants)
(tp--rollback-hook-phase
'rollback-hooks tp--transaction-rollback-functions)
(tp--rollback-signal-journal)))
@ -888,8 +1431,14 @@ the primary condition data."
(funcall function)
(let (after-commit result
(tp--transaction-contained-failures nil))
(setq tp--last-transaction-outcome nil
tp--last-shadow-proof nil)
(setq result
(let ((tp--transaction-active t)
(tp--transaction-id (tp--next-transaction-id))
(tp--transaction-phase 'body)
(tp--transaction-phase-start (float-time))
(tp--transaction-phase-timings nil)
(tp--transaction-signal-values
(make-hash-table :test #'eq))
(tp--transaction-signals nil)
@ -904,8 +1453,22 @@ the primary condition data."
(tp--transaction-after-commit-callbacks nil)
(tp--transaction-participants nil)
(tp--transaction-participant-keys nil)
(tp--transaction-participant-order 0)
(tp--transaction-published-participants nil)
(tp--transaction-signal-commit-journal nil)
(tp--transaction-publication-batch nil)
(tp--transaction-structured-participants nil)
(tp--transaction-final-marker-registry
(make-vector tp--final-marker-max-count nil))
(tp--transaction-final-marker-owner-keys
(make-vector tp--final-marker-max-count nil))
(tp--transaction-final-marker-count 0)
(tp--transaction-final-marker-slot-writes 0)
(tp--transaction-final-markers-frozen-p nil)
(tp--transaction-applied-final-marker-count 0)
(tp--transaction-marker-restore-failures nil)
(tp--transaction-outcome nil)
(tp--transaction-outcome-cell (vector nil))
(tp--transaction-final-accept-function
#'tp--transaction-noop-final-accept)
(counter-snapshot (copy-sequence tp--reactive-counters))
@ -917,11 +1480,27 @@ the primary condition data."
(condition-case condition
(progn
(setq transaction-result (funcall function))
(tp--transaction-enter-phase 'recompute)
(tp--flush-dirty-bindings)
(tp--transaction-enter-phase 'publication)
(setq tp--transaction-structured-participants
(vconcat
(tp--transaction-participants-in-registration-order)))
(run-hooks 'tp--transaction-publish-functions)
(tp--publish-transaction-participants)
(tp--transaction-batch-transition 'participants)
(tp--transaction-enter-phase 'participants)
(tp--stage-structured-transaction-participants)
(tp--transaction-batch-transition 'precommit)
(tp--transaction-enter-phase 'precommit)
(tp--run-structured-transaction-participant-precommits)
(tp--run-transaction-precommit-functions)
(tp--transaction-freeze-final-markers)
(tp--transaction-sync-publication-batch)
(tp--transaction-enter-phase 'signal-commit)
(tp--commit-signal-values)
(tp--transaction-sync-publication-batch)
(tp--transaction-enter-phase 'final-accept)
(tp--transaction-prepare-success-outcome)
(condition-case deferred-quit
(progn
(let ((inhibit-quit t)
@ -936,9 +1515,10 @@ the primary condition data."
(list
:invalid-final-accept-function
tp--transaction-final-accept-function)))
(funcall
tp--transaction-final-accept-function)
(tp--transaction-run-final-accept)
(setq success t)
(tp--commit-structured-transaction-participants)
(tp--transaction-run-shadow-proof 'commit)
(when quit-flag
(setq pending-quit t
quit-flag nil))
@ -971,9 +1551,14 @@ the primary condition data."
(let ((inhibit-quit t)
(quit-flag nil))
(unwind-protect
(setq rollback-failures
(progn
(setq tp--transaction-phase
(or tp--transaction-phase 'rollback)
rollback-failures
(tp--rollback-transaction-state
counter-snapshot))
(tp--transaction-finish-rollback
primary-condition rollback-failures))
(setq quit-flag nil)))))
(when primary-condition
(tp--resignal-transaction-primary

View File

@ -205,12 +205,51 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
#'tp--merge-face-values
(lambda (_old new) new)))
(defun tp--native-keymap-equal-p (left right)
"Compare native snapshots LEFT and RIGHT, retaining commands and menu order."
(let ((seen (make-hash-table :test #'eq)))
(cl-labels
((bindings (map)
(let ((local (copy-sequence (if (symbolp map)
(indirect-function map) map)))
entries)
(set-keymap-parent local nil)
(map-keymap (lambda (key value) (push (cons key value) entries)) local)
entries))
(same (old new)
(cond
((eq old new) t)
((memq new (gethash old seen)) t)
((and (keymapp old) (keymapp new))
(puthash old (cons new (gethash old seen)) seen)
(and (equal-including-properties (keymap-prompt old)
(keymap-prompt new))
(same (bindings old) (bindings new))
(same (keymap-parent old) (keymap-parent new))))
((or (functionp old) (functionp new)) nil)
((and (consp old) (consp new))
(puthash old (cons new (gethash old seen)) seen)
(and (same (car old) (car new)) (same (cdr old) (cdr new))))
((and (vectorp old) (vectorp new) (= (length old) (length new)))
(puthash old (cons new (gethash old seen)) seen)
(cl-loop for index below (length old)
always (same (aref old index) (aref new index))))
(t (equal old new)))))
(same left right))))
(defun tp--native-property-value-equal-p (left right)
"Compare native values LEFT and RIGHT while preserving callable identity."
(cond
((and (keymapp left) (keymapp right)) (tp--native-keymap-equal-p left right))
((or (functionp left) (functionp right)) (eq left right))
(t (equal left right))))
(defun tp-register-text-property (property)
"Register and return a direct policy for Emacs PROPERTY."
(let ((id (tp-text-property-id property)))
(or (tp-property-policy id)
(tp-define-property-policy
id :equality #'equal
id :equality #'tp--native-property-value-equal-p
:merge (tp--text-property-merge-function property)
:projector (lambda (value) (list property value))))))

File diff suppressed because it is too large Load Diff

822
tp-transaction.el Normal file
View File

@ -0,0 +1,822 @@
;;; tp-transaction.el --- Structured publication transaction contracts -*- 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:
;; Internal immutable artifacts and one-shot state machines for TP publication.
;; The package-owned entry-stage capability stored in a batch candidate drives
;; publication. This module never edits a buffer itself: `tp-reactive' drives
;; the state machine and `tp-surface' supplies and stages exact target entries
;; backed by the shared prepare journals and snapshots.
;;; Code:
(require 'cl-lib)
(require 'tp-core)
(define-error 'tp-transaction-contract-error
"Invalid TP publication transaction contract")
(define-error 'tp-publication-binding-error
"TP publication artifact binding mismatch"
'tp-transaction-contract-error)
(define-error 'tp-publication-state-error
"Invalid TP publication artifact state transition"
'tp-transaction-contract-error)
(define-error 'tp-final-marker-error
"Invalid TP final-accept marker"
'tp-transaction-contract-error)
(defconst tp-transaction-protocol 'tp-transaction-protocol-v2
"Transaction protocol implemented by this TP package version.")
(defconst tp--publication-batch-transitions
'((prepared staged rolled-back discarded)
(staged participants rolled-back)
(participants precommit rolled-back)
(precommit final-accepting rolled-back)
(final-accepting committed rolled-back))
"Allowed one-way state transitions for publication batch candidates.")
(defconst tp--publication-batch-terminal-states
'(committed rolled-back discarded)
"Terminal publication batch candidate states.")
(defconst tp--publication-batch-stage-entry-functions
'(tp--surface-stage-publication-entries)
"Closed package-owned publication entry stage capabilities.")
(defconst tp--final-marker-max-count 8
"Maximum number of opaque final markers in one transaction.")
(defconst tp--final-marker-max-slot-writes 16
"Maximum total fixed marker slot writes in one transaction.")
(defvar tp--transaction-id-counter 0)
(defvar tp--publication-batch-id-counter 0)
(defvar tp--publication-candidate-id-counter 0)
(defvar tp--final-accept-id-counter 0)
(defun tp--next-transaction-id ()
"Return a fresh monotonic internal transaction identifier."
(cl-incf tp--transaction-id-counter))
(defun tp--next-publication-batch-id ()
"Return a fresh monotonic publication batch identifier."
(cl-incf tp--publication-batch-id-counter))
(defun tp--next-publication-candidate-id ()
"Return a fresh monotonic target candidate identifier."
(cl-incf tp--publication-candidate-id-counter))
(defun tp--next-final-accept-id ()
"Return a fresh monotonic final-accept identifier."
(cl-incf tp--final-accept-id-counter))
(defun tp--proper-unique-list-p (items)
"Return non-nil when ITEMS is a proper list with no equal duplicates."
(and (proper-list-p items)
(let ((seen (make-hash-table :test #'equal))
(unique t))
(dolist (item items unique)
(if (gethash item seen)
(setq unique nil)
(puthash item t seen))))))
(cl-defstruct (tp-publication-target-entry
(:constructor tp--make-publication-target-entry)
(:copier nil))
"One exact, immutable target binding in a publication candidate."
(transaction-id nil :read-only t)
(batch-id nil :read-only t)
(candidate-id nil :read-only t)
(surface-id nil :read-only t)
(mount-ids nil :read-only t)
(buffer nil :read-only t)
(old-revision nil :read-only t)
(new-revision nil :read-only t)
(plan nil :read-only t)
(diff nil :read-only t)
(ledger nil :read-only t)
(objects nil :read-only t)
(ranges nil :read-only t)
(client-state nil :read-only t)
(rollback-snapshot nil :read-only t)
(authority-token nil :read-only t)
(mapping-generation nil :read-only t)
operation-counts
(shadow-expected nil :read-only t)
(shadow-validator nil :read-only t)
rollback-result post-rollback-state shadow-actual shadow-proven-p)
(defun tp--publication-target-entry-arguments-valid-p
(transaction-id batch-id candidate-id surface-id mount-ids buffer
old-revision new-revision authority-token shadow-validator)
"Return non-nil when target arguments bind TRANSACTION-ID and BATCH-ID.
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION,
AUTHORITY-TOKEN, and SHADOW-VALIDATOR must have valid publication shapes."
(and transaction-id batch-id candidate-id surface-id
(bufferp buffer) (buffer-live-p buffer)
(integerp old-revision) (>= old-revision 0)
(integerp new-revision) (= new-revision (1+ old-revision))
(tp--proper-unique-list-p mount-ids)
authority-token
(or (null shadow-validator) (functionp shadow-validator))))
(cl-defun tp--publication-target-entry-create
(&key transaction-id batch-id candidate-id surface-id mount-ids buffer
old-revision new-revision plan diff ledger objects ranges client-state
rollback-snapshot authority-token mapping-generation shadow-expected
shadow-validator operation-counts)
"Create an exact TRANSACTION-ID and BATCH-ID target binding.
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION, PLAN,
DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
AUTHORITY-TOKEN describe the target. MAPPING-GENERATION is optional.
OPERATION-COUNTS is filled from the live report. SHADOW-EXPECTED and
SHADOW-VALIDATOR are private comparison artifacts."
(unless (tp--publication-target-entry-arguments-valid-p
transaction-id batch-id candidate-id surface-id mount-ids buffer
old-revision new-revision authority-token shadow-validator)
(signal 'tp-publication-binding-error
(list :target-entry transaction-id batch-id candidate-id surface-id
buffer old-revision new-revision mount-ids authority-token)))
(tp--make-publication-target-entry
:transaction-id transaction-id
:batch-id batch-id
:candidate-id candidate-id
:surface-id (tp--copy-property-value surface-id)
:mount-ids (tp--copy-property-value mount-ids)
:buffer buffer
:old-revision old-revision
:new-revision new-revision
:plan plan
:diff (tp--copy-property-value diff)
:ledger ledger
:objects objects
:ranges ranges
:client-state (tp--copy-property-value client-state)
:rollback-snapshot rollback-snapshot
:authority-token authority-token
:mapping-generation mapping-generation
:operation-counts (tp--copy-property-value operation-counts)
:shadow-expected shadow-expected
:shadow-validator shadow-validator))
(cl-defstruct (tp-publication-outcome-entry
(:constructor tp--make-publication-outcome-entry)
(:copier nil))
"Frozen observational binding copied from one target entry."
(batch-id nil :read-only t)
(candidate-id nil :read-only t)
(surface-id nil :read-only t)
(mount-ids nil :read-only t)
(buffer nil :read-only t)
(authority-token nil :read-only t)
(old-revision nil :read-only t)
(new-revision nil :read-only t)
(mapping-generation nil :read-only t)
(operation-counts nil :read-only t))
(defun tp--publication-outcome-entry-from-target (entry)
"Return an observational outcome entry frozen from target ENTRY."
(tp--make-publication-outcome-entry
:batch-id (tp-publication-target-entry-batch-id entry)
:candidate-id (tp-publication-target-entry-candidate-id entry)
:surface-id
(tp--copy-property-value (tp-publication-target-entry-surface-id entry))
:mount-ids
(tp--copy-property-value (tp-publication-target-entry-mount-ids entry))
:buffer (tp-publication-target-entry-buffer entry)
:authority-token (tp-publication-target-entry-authority-token entry)
:old-revision (tp-publication-target-entry-old-revision entry)
:new-revision (tp-publication-target-entry-new-revision entry)
:mapping-generation
(tp-publication-target-entry-mapping-generation entry)
:operation-counts
(tp--copy-property-value
(tp-publication-target-entry-operation-counts entry))))
(cl-defstruct (tp-committed-success-outcome
(:constructor tp--make-committed-success-outcome)
(:copier nil))
"Preallocated immutable evidence finalized only after final accept."
(tag nil :read-only t)
(transaction-id nil :read-only t)
(final-accept-id nil :read-only t)
(batch-id nil :read-only t)
(entries nil :read-only t)
(mapping-generation nil :read-only t)
(operation-counts nil :read-only t)
(phase-timings nil :read-only t)
(diagnostics nil :read-only t)
(marker-count nil :read-only t))
(defconst tp--committed-success-outcome-tag-slot 1
"Private record offset for the sole postaccept success-tag write.")
(cl-defstruct (tp-publication-failure-outcome
(:constructor tp--make-publication-failure-outcome)
(:copier nil))
"Immutable observational evidence built after publication rollback."
(tag 'publication-failure :read-only t)
(transaction-id nil :read-only t)
(batch-id nil :read-only t)
(failure-stage nil :read-only t)
(primary-condition nil :read-only t)
(target-results nil :read-only t)
(rollback-failures nil :read-only t)
(post-rollback-state nil :read-only t)
(diagnostics nil :read-only t))
(cl-defstruct (tp-publication-batch-candidate
(:constructor tp--make-publication-batch-candidate)
(:copier nil))
"A one-shot structured publication authority over shared rollback state."
(transaction-id nil :read-only t)
(id nil :read-only t)
state
resolution
(entries nil :read-only t)
(participants nil :read-only t)
(journals nil :read-only t)
(stage-entries nil :read-only t)
final-accept
(final-accept-id nil :read-only t)
diagnostics
operation-counts
phase-timings
markers
success-outcome-draft
outcome
shadow-proof)
(defun tp--publication-target-entry-bound-p (entry transaction-id batch-id)
"Return non-nil when ENTRY is exactly bound to TRANSACTION-ID and BATCH-ID."
(and (tp-publication-target-entry-p entry)
(equal transaction-id
(tp-publication-target-entry-transaction-id entry))
(equal batch-id (tp-publication-target-entry-batch-id entry))))
(defun tp--publication-batch-entries-valid-p
(entries transaction-id batch-id)
"Return non-nil when ENTRIES bind TRANSACTION-ID and BATCH-ID exactly."
(and (proper-list-p entries)
entries
(cl-every (lambda (entry)
(tp--publication-target-entry-bound-p
entry transaction-id batch-id))
entries)
(tp--proper-unique-list-p
(mapcar #'tp-publication-target-entry-candidate-id entries))
(tp--proper-unique-list-p
(mapcar #'tp-publication-target-entry-surface-id entries))
(tp--proper-unique-list-p
(mapcar #'tp-publication-target-entry-authority-token entries))
(let ((generation
(tp-publication-target-entry-mapping-generation (car entries))))
(cl-every
(lambda (entry)
(equal generation
(tp-publication-target-entry-mapping-generation entry)))
entries))))
(cl-defun tp--publication-batch-prepare
(&key transaction-id batch-id entries participants journals stage-entries
final-accept diagnostics)
"Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES.
PARTICIPANTS is an ordered reference vector, JOURNALS is the shared rollback
view, STAGE-ENTRIES is an optional package-owned execution capability,
FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains known
preaccept observations."
(unless (and transaction-id batch-id
(tp--publication-batch-entries-valid-p
entries transaction-id batch-id)
(vectorp participants)
(or (null stage-entries)
(and (symbolp stage-entries)
(memq stage-entries
tp--publication-batch-stage-entry-functions)
(fboundp stage-entries)))
(functionp final-accept))
(signal 'tp-publication-binding-error
(list :batch transaction-id batch-id entries participants)))
(tp--make-publication-batch-candidate
:transaction-id transaction-id
:id batch-id
:state 'prepared
:entries (copy-sequence entries)
:participants participants
:journals journals
:stage-entries stage-entries
:final-accept final-accept
:final-accept-id (tp--next-final-accept-id)
:diagnostics (tp--copy-property-value diagnostics)))
(defun tp--publication-batch-execute-stage (candidate)
"Execute CANDIDATE's package-owned entry stage capability exactly once."
(unless (and (tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate) 'staged)
(memq (tp-publication-batch-candidate-stage-entries candidate)
tp--publication-batch-stage-entry-functions))
(signal 'tp-publication-state-error
(list :batch-stage candidate)))
(funcall (tp-publication-batch-candidate-stage-entries candidate) candidate))
(defun tp--publication-batch-terminal-p (candidate)
"Return non-nil when CANDIDATE has one terminal disposition."
(and (tp-publication-batch-candidate-p candidate)
(memq (tp-publication-batch-candidate-state candidate)
tp--publication-batch-terminal-states)))
(defun tp--publication-batch-transition (candidate next)
"Move CANDIDATE to NEXT through its one-way state machine."
(unless (tp-publication-batch-candidate-p candidate)
(signal 'wrong-type-argument
(list 'tp-publication-batch-candidate-p candidate)))
(let* ((current (tp-publication-batch-candidate-state candidate))
(allowed (cdr (assq current tp--publication-batch-transitions))))
(unless (memq next allowed)
(signal 'tp-publication-state-error
(list :batch-state current next
(tp-publication-batch-candidate-id candidate))))
(setf (tp-publication-batch-candidate-state candidate) next)
(when (memq next tp--publication-batch-terminal-states)
(setf (tp-publication-batch-candidate-resolution candidate) next))
candidate))
(defun tp--publication-batch-discard (candidate reason)
"Discard prepared CANDIDATE for REASON and return nil."
(unless (and (tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate) 'prepared))
(signal 'tp-publication-state-error
(list :discard
(and (tp-publication-batch-candidate-p candidate)
(tp-publication-batch-candidate-state candidate)))))
(setf (tp-publication-batch-candidate-diagnostics candidate)
(append (tp-publication-batch-candidate-diagnostics candidate)
(list (list :discard reason))))
(tp--publication-batch-transition candidate 'discarded)
nil)
(defun tp--committed-success-outcome-draft
(candidate operation-counts phase-timings diagnostics marker-count)
"Preallocate CANDIDATE evidence using OPERATION-COUNTS and PHASE-TIMINGS.
DIAGNOSTICS contains known preaccept failures and MARKER-COUNT is fixed."
(unless (tp-publication-batch-candidate-p candidate)
(signal 'wrong-type-argument
(list 'tp-publication-batch-candidate-p candidate)))
(setf (tp-publication-batch-candidate-operation-counts candidate)
(tp--copy-property-value operation-counts)
(tp-publication-batch-candidate-phase-timings candidate)
(tp--copy-property-value phase-timings)
(tp-publication-batch-candidate-diagnostics candidate)
(tp--copy-property-value diagnostics))
(tp--make-committed-success-outcome
:transaction-id
(tp-publication-batch-candidate-transaction-id candidate)
:final-accept-id
(tp-publication-batch-candidate-final-accept-id candidate)
:batch-id (tp-publication-batch-candidate-id candidate)
:entries
(mapcar #'tp--publication-outcome-entry-from-target
(tp-publication-batch-candidate-entries candidate))
:mapping-generation
(let ((entries (tp-publication-batch-candidate-entries candidate)))
(and entries
(tp-publication-target-entry-mapping-generation (car entries))))
:operation-counts
(tp--copy-property-value
(tp-publication-batch-candidate-operation-counts candidate))
:phase-timings
(tp--copy-property-value
(tp-publication-batch-candidate-phase-timings candidate))
:diagnostics
(tp--copy-property-value
(tp-publication-batch-candidate-diagnostics candidate))
:marker-count marker-count))
(defun tp--committed-success-outcome-finalize (outcome)
"Finalize preallocated OUTCOME exactly once after final accept."
(unless (and (tp-committed-success-outcome-p outcome)
(null (tp-committed-success-outcome-tag outcome)))
(signal 'tp-publication-state-error (list :success-outcome outcome)))
;; The slot is read-only to every accessor. This single fixed vector write is
;; the coordinator's postaccept tag finalization primitive.
(aset outcome tp--committed-success-outcome-tag-slot 'committed-success)
outcome)
(defun tp--publication-outcome-entry-matches-target-p (outcome-entry target)
"Return non-nil when OUTCOME-ENTRY is exactly bound to TARGET."
(and (tp-publication-outcome-entry-p outcome-entry)
(tp-publication-target-entry-p target)
(equal (tp-publication-outcome-entry-batch-id outcome-entry)
(tp-publication-target-entry-batch-id target))
(equal (tp-publication-outcome-entry-candidate-id outcome-entry)
(tp-publication-target-entry-candidate-id target))
(equal (tp-publication-outcome-entry-surface-id outcome-entry)
(tp-publication-target-entry-surface-id target))
(equal (tp-publication-outcome-entry-mount-ids outcome-entry)
(tp-publication-target-entry-mount-ids target))
(eq (tp-publication-outcome-entry-buffer outcome-entry)
(tp-publication-target-entry-buffer target))
(eq (tp-publication-outcome-entry-authority-token outcome-entry)
(tp-publication-target-entry-authority-token target))
(= (tp-publication-outcome-entry-old-revision outcome-entry)
(tp-publication-target-entry-old-revision target))
(= (tp-publication-outcome-entry-new-revision outcome-entry)
(tp-publication-target-entry-new-revision target))
(equal (tp-publication-outcome-entry-mapping-generation outcome-entry)
(tp-publication-target-entry-mapping-generation target))
(equal (tp-publication-outcome-entry-operation-counts outcome-entry)
(tp-publication-target-entry-operation-counts target))))
(defun tp--committed-success-outcome-valid-for-p
(outcome candidate &optional mapping-generation)
"Purely validate OUTCOME against exact CANDIDATE and MAPPING-GENERATION."
(and (tp-committed-success-outcome-p outcome)
(eq (tp-committed-success-outcome-tag outcome) 'committed-success)
(tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate) 'committed)
(equal (tp-committed-success-outcome-transaction-id outcome)
(tp-publication-batch-candidate-transaction-id candidate))
(equal (tp-committed-success-outcome-batch-id outcome)
(tp-publication-batch-candidate-id candidate))
(equal (tp-committed-success-outcome-operation-counts outcome)
(tp-publication-batch-candidate-operation-counts candidate))
(equal (tp-committed-success-outcome-phase-timings outcome)
(tp-publication-batch-candidate-phase-timings candidate))
(equal (tp-committed-success-outcome-diagnostics outcome)
(tp-publication-batch-candidate-diagnostics candidate))
(= (tp-committed-success-outcome-marker-count outcome)
(if (consp (tp-publication-batch-candidate-markers candidate))
(cdr (tp-publication-batch-candidate-markers candidate))
0))
(or (null mapping-generation)
(equal mapping-generation
(tp-committed-success-outcome-mapping-generation outcome)))
(let ((outcome-entries
(append (tp-committed-success-outcome-entries outcome) nil))
(targets (tp-publication-batch-candidate-entries candidate)))
(and (= (length outcome-entries) (length targets))
(cl-every #'identity
(cl-mapcar
#'tp--publication-outcome-entry-matches-target-p
outcome-entries targets))))))
(defun tp--committed-success-outcome-snapshot (outcome)
"Return a defensive observational plist for committed OUTCOME."
(unless (and (tp-committed-success-outcome-p outcome)
(eq (tp-committed-success-outcome-tag outcome)
'committed-success))
(signal 'tp-publication-binding-error (list :outcome outcome)))
(list
:tag 'committed-success
:transaction-id (tp-committed-success-outcome-transaction-id outcome)
:final-accept-id (tp-committed-success-outcome-final-accept-id outcome)
:batch-id (tp-committed-success-outcome-batch-id outcome)
:entries
(mapcar
(lambda (entry)
(list :batch-id (tp-publication-outcome-entry-batch-id entry)
:candidate-id (tp-publication-outcome-entry-candidate-id entry)
:surface-id
(tp--copy-property-value
(tp-publication-outcome-entry-surface-id entry))
:mount-ids
(tp--copy-property-value
(tp-publication-outcome-entry-mount-ids entry))
:buffer (tp-publication-outcome-entry-buffer entry)
:authority-token
(tp-publication-outcome-entry-authority-token entry)
:old-revision
(tp-publication-outcome-entry-old-revision entry)
:new-revision
(tp-publication-outcome-entry-new-revision entry)
:mapping-generation
(tp-publication-outcome-entry-mapping-generation entry)
:operation-counts
(tp--copy-property-value
(tp-publication-outcome-entry-operation-counts entry))))
(append (tp-committed-success-outcome-entries outcome) nil))
:mapping-generation
(tp-committed-success-outcome-mapping-generation outcome)
:operation-counts
(tp--copy-property-value
(tp-committed-success-outcome-operation-counts outcome))
:phase-timings
(tp--copy-property-value
(tp-committed-success-outcome-phase-timings outcome))
:diagnostics
(tp--copy-property-value
(tp-committed-success-outcome-diagnostics outcome))
:marker-count (tp-committed-success-outcome-marker-count outcome)))
(defun tp--publication-failure-outcome-valid-for-p (outcome candidate)
"Purely validate failure OUTCOME against rolled-back CANDIDATE."
(and (tp-publication-failure-outcome-p outcome)
(eq (tp-publication-failure-outcome-tag outcome)
'publication-failure)
(tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate) 'rolled-back)
(equal (tp-publication-failure-outcome-transaction-id outcome)
(tp-publication-batch-candidate-transaction-id candidate))
(equal (tp-publication-failure-outcome-batch-id outcome)
(tp-publication-batch-candidate-id candidate))
(let ((results (tp-publication-failure-outcome-target-results outcome))
(entries (tp-publication-batch-candidate-entries candidate)))
(and (= (length results) (length entries))
(cl-every
#'identity
(cl-mapcar
(lambda (result entry)
(and
(equal (plist-get result :candidate-id)
(tp-publication-target-entry-candidate-id entry))
(equal (plist-get result :surface-id)
(tp-publication-target-entry-surface-id entry))))
results entries))))))
(defun tp--publication-failure-outcome-create
(candidate stage primary-condition rollback-failures diagnostics)
"Build rolled-back CANDIDATE evidence for STAGE and PRIMARY-CONDITION.
ROLLBACK-FAILURES and DIAGNOSTICS are observational snapshots."
(unless (and (tp-publication-batch-candidate-p candidate)
(eq (tp-publication-batch-candidate-state candidate)
'rolled-back))
(signal 'tp-publication-state-error (list :failure-outcome candidate)))
(let ((entries (tp-publication-batch-candidate-entries candidate)))
(tp--make-publication-failure-outcome
:transaction-id
(tp-publication-batch-candidate-transaction-id candidate)
:batch-id (tp-publication-batch-candidate-id candidate)
:failure-stage stage
:primary-condition (tp--copy-property-value primary-condition)
:target-results
(mapcar
(lambda (entry)
(list :candidate-id
(tp-publication-target-entry-candidate-id entry)
:surface-id
(tp--copy-property-value
(tp-publication-target-entry-surface-id entry))
:result
(tp--copy-property-value
(tp-publication-target-entry-rollback-result entry))))
entries)
:rollback-failures (tp--copy-property-value rollback-failures)
:post-rollback-state
(mapcar
(lambda (entry)
(list :candidate-id
(tp-publication-target-entry-candidate-id entry)
:surface-id
(tp--copy-property-value
(tp-publication-target-entry-surface-id entry))
:state
(tp--copy-property-value
(tp-publication-target-entry-post-rollback-state entry))))
entries)
:diagnostics (tp--copy-property-value diagnostics))))
(cl-defstruct (tp--final-marker-operation
(:constructor tp--make-final-marker-operation)
(:copier nil))
"One trusted operation descriptor resolved before final accept."
(key nil :read-only t)
(validate nil :read-only t)
(apply nil :read-only t)
(restore nil :read-only t)
(max-slot-writes nil :read-only t))
(cl-defstruct (tp-final-marker-expectation
(:constructor tp--make-final-marker-expectation)
(:copier nil))
"One prebuilt expected scalar stored in a fixed vector slot."
(target nil :read-only t)
(index nil :read-only t)
(value nil :read-only t))
(cl-defstruct (tp-final-marker-slot-write
(:constructor tp--make-final-marker-slot-write)
(:copier nil))
"One prebuilt fixed vector slot write."
(target nil :read-only t)
(index nil :read-only t)
(value nil :read-only t))
(defun tp--final-marker-vector-index-p (target index)
"Return non-nil when INDEX denotes a writable slot in TARGET."
(and (vectorp target) (integerp index) (<= 0 index) (< index (length target))))
(cl-defun tp--final-marker-expectation-create (&key target index value)
"Create an expectation that TARGET slot INDEX currently equals VALUE."
(unless (tp--final-marker-vector-index-p target index)
(signal 'tp-final-marker-error (list :expectation target index)))
(tp--make-final-marker-expectation
:target target :index index :value value))
(cl-defun tp-final-marker-expectation-create (&key target index value)
"Create a final-marker expectation for TARGET slot INDEX and VALUE."
(tp--final-marker-expectation-create
:target target :index index :value value))
(cl-defun tp--final-marker-slot-write-create (&key target index value)
"Create one prebuilt write of VALUE into TARGET slot INDEX."
(unless (tp--final-marker-vector-index-p target index)
(signal 'tp-final-marker-error (list :slot-write target index)))
(tp--make-final-marker-slot-write :target target :index index :value value))
(cl-defun tp-final-marker-slot-write-create (&key target index value)
"Create one bounded final-marker write to TARGET slot INDEX with VALUE."
(tp--final-marker-slot-write-create
:target target :index index :value value))
(defun tp--final-marker-expectation-current-p (expectation)
"Return non-nil when EXPECTATION matches its current fixed slot."
(and (tp-final-marker-expectation-p expectation)
(equal
(aref (tp-final-marker-expectation-target expectation)
(tp-final-marker-expectation-index expectation))
(tp-final-marker-expectation-value expectation))))
(defun tp--final-marker-slot-write-shape-p (write)
"Return non-nil when WRITE still denotes one valid fixed vector slot."
(and (tp-final-marker-slot-write-p write)
(tp--final-marker-vector-index-p
(tp-final-marker-slot-write-target write)
(tp-final-marker-slot-write-index write))))
(defun tp--final-marker-vector-payload-shape-p (marker)
"Return non-nil when MARKER has exact paired fixed vector slot payloads."
(let ((next (tp-final-accept-marker-next-values marker))
(inverse (tp-final-accept-marker-inverse-values marker))
(count (tp-final-accept-marker-slot-write-count marker))
seen valid)
(setq valid
(and (vectorp next) (vectorp inverse)
(= (length next) count) (= (length inverse) count)))
(let ((index 0))
(while (and valid (< index count))
(let ((next-write (aref next index))
(inverse-write (aref inverse index)))
(setq valid
(and
(tp--final-marker-slot-write-shape-p next-write)
(tp--final-marker-slot-write-shape-p inverse-write)
(eq (tp-final-marker-slot-write-target next-write)
(tp-final-marker-slot-write-target inverse-write))
(= (tp-final-marker-slot-write-index next-write)
(tp-final-marker-slot-write-index inverse-write))
(not
(cl-find-if
(lambda (entry)
(and
(eq (car entry)
(tp-final-marker-slot-write-target next-write))
(= (cdr entry)
(tp-final-marker-slot-write-index next-write))))
seen))))
(when valid
(push (cons (tp-final-marker-slot-write-target next-write)
(tp-final-marker-slot-write-index next-write))
seen)))
(setq index (1+ index))))
valid))
(defun tp--final-marker-vector-slots-validate (marker)
"Validate MARKER expectations and inverse values without changing state."
(and
(tp--final-marker-vector-payload-shape-p marker)
(tp--final-marker-expectation-current-p
(tp-final-accept-marker-expected-token marker))
(tp--final-marker-expectation-current-p
(tp-final-accept-marker-expected-version marker))
(let* ((inverse (tp-final-accept-marker-inverse-values marker))
(count (length inverse))
(index 0)
(valid t))
(while (and valid (< index count))
(let ((write (aref inverse index)))
(setq valid
(equal
(aref (tp-final-marker-slot-write-target write)
(tp-final-marker-slot-write-index write))
(tp-final-marker-slot-write-value write))))
(setq index (1+ index)))
valid)))
(defun tp--final-marker-vector-slots-apply (marker)
"Apply MARKER's fixed next-value vector slots in order."
(let* ((writes (tp-final-accept-marker-next-values marker))
(count (length writes))
(index 0))
(while (< index count)
(let ((write (aref writes index)))
(aset (tp-final-marker-slot-write-target write)
(tp-final-marker-slot-write-index write)
(tp-final-marker-slot-write-value write)))
(setq index (1+ index)))))
(defun tp--final-marker-vector-slots-restore (marker)
"Restore MARKER's fixed inverse-value vector slots in reverse order."
(let* ((writes (tp-final-accept-marker-inverse-values marker))
(index (1- (length writes))))
(while (>= index 0)
(let ((write (aref writes index)))
(aset (tp-final-marker-slot-write-target write)
(tp-final-marker-slot-write-index write)
(tp-final-marker-slot-write-value write)))
(setq index (1- index)))))
(defconst tp--final-marker-operation-whitelist
(list
(tp--make-final-marker-operation
:key 'tp-vector-slots/v1
:validate (symbol-function 'tp--final-marker-vector-slots-validate)
:apply (symbol-function 'tp--final-marker-vector-slots-apply)
:restore (symbol-function 'tp--final-marker-vector-slots-restore)
:max-slot-writes tp--final-marker-max-slot-writes))
"Closed package-owned final-marker primitive whitelist.")
(defun tp--final-marker-operation-resolve (key)
"Return the trusted final marker operation registered for KEY."
(let ((operation
(cl-find key tp--final-marker-operation-whitelist
:key #'tp--final-marker-operation-key :test #'eq)))
(or operation
(signal 'tp-final-marker-error (list :operation-not-whitelisted key)))))
(cl-defstruct (tp-final-accept-marker
(:constructor tp--make-final-accept-marker)
(:copier nil))
"One opaque, bounded, one-shot final-accept authority marker."
(owner-key nil :read-only t)
(expected-token nil :read-only t)
(expected-version nil :read-only t)
(next-values nil :read-only t)
(inverse-values nil :read-only t)
(slot-write-count nil :read-only t)
(operation-key nil :read-only t)
(operation nil :read-only t)
state)
(cl-defun tp--final-accept-marker-create
(&key owner-key expected-token expected-version next-values inverse-values
slot-write-count operation-key)
"Create an OWNER-KEY marker after resolving OPERATION-KEY.
EXPECTED-TOKEN and EXPECTED-VERSION bind owner state. NEXT-VALUES and
INVERSE-VALUES are opaque prebuilt payloads with fixed SLOT-WRITE-COUNT."
(let ((operation (tp--final-marker-operation-resolve operation-key)))
(unless (and owner-key
(tp-final-marker-expectation-p expected-token)
(tp-final-marker-expectation-p expected-version)
(integerp
(tp-final-marker-expectation-value expected-version))
(>= (tp-final-marker-expectation-value expected-version) 0)
(integerp slot-write-count) (> slot-write-count 0)
(<= slot-write-count
(tp--final-marker-operation-max-slot-writes operation)))
(signal 'tp-final-marker-error
(list :marker owner-key expected-token expected-version
slot-write-count operation-key)))
(let ((marker
(tp--make-final-accept-marker
:owner-key (tp--copy-property-value owner-key)
:expected-token expected-token
:expected-version expected-version
:next-values (and (vectorp next-values)
(copy-sequence next-values))
:inverse-values (and (vectorp inverse-values)
(copy-sequence inverse-values))
:slot-write-count slot-write-count
:operation-key operation-key
:operation operation
:state 'prepared)))
(unless (tp--final-marker-vector-payload-shape-p marker)
(signal 'tp-final-marker-error
(list :marker-payload owner-key slot-write-count)))
marker)))
(defun tp--final-accept-marker-validate (marker)
"Validate MARKER's expected owner state before the critical section."
(unless (and (tp-final-accept-marker-p marker)
(eq (tp-final-accept-marker-state marker) 'prepared)
(funcall
(tp--final-marker-operation-validate
(tp-final-accept-marker-operation marker))
marker))
(signal 'tp-final-marker-error
(list :expected-state
(and (tp-final-accept-marker-p marker)
(tp-final-accept-marker-owner-key marker)))))
marker)
(provide 'tp-transaction)
;;; tp-transaction.el ends here

20
tp.el
View File

@ -2,7 +2,7 @@
;; Copyright (C) 2024-2026 Geekinney
;; Version: 1.0.0
;; Version: 2.0.0
;; Keywords: convenience text-properties
;; Author: Geekinney (kinneyzhang666@gmail.com)
;; Package-Requires: ((emacs "28.1"))
@ -25,6 +25,8 @@
;; canonical requests/results, and debug logging.
;; tp-style.el Native property policies, contribution composition,
;; named declarations, and explicit computed values.
;; tp-transaction.el
;; Structured publication batch, marker, and outcome contracts.
;; tp-reactive.el Exact signals, bindings, transactions, and scoped variable
;; adapters.
;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes,
@ -53,6 +55,7 @@
(require 'tp-core)
(require 'tp-style)
(require 'tp-transaction)
(require 'tp-reactive)
(require 'tp-surface)
(require 'tp-layer)
@ -62,5 +65,20 @@
(require 'tp-palette)
(require 'tp-builtins)
(defconst tp--runtime-manifest
`(:package tp :version "2.0.0"
:transaction-protocol ,tp-transaction-protocol
:batch-artifacts t
:batch-execute t
:structured-participant-api tp-transaction-participate-v2
:single-live-writer t
:final-marker-operation tp-vector-slots/v1)
"Immutable package capability facts for cross-package compatibility checks.")
;;;###autoload
(defun tp-runtime-manifest ()
"Return a defensive snapshot of TP's package capability manifest."
(tp--copy-property-value tp--runtime-manifest))
(provide 'tp)
;;; tp.el ends here